Artifact f4bcc1a3770c3c417d38613fa967cc683c078dad:
- File lalr/associators.ss — part of check-in [89d5aac0dc] at 2016-08-17 07:45:09 on branch trunk — added lalr (user: ovenpasta@pizzahack.eu size: 20764)
0000: 3b 3b 3b 20 61 73 73 6f 63 69 61 74 6f 72 73 2e ;;; associators. 0010: 73 73 0a 3b 3b 3b 0a 3b 3b 3b 20 28 65 76 61 6c ss.;;;.;;; (eval 0020: 2d 77 68 65 6e 20 28 63 6f 6d 70 69 6c 65 29 20 -when (compile) 0030: 28 6f 70 74 69 6d 69 7a 65 2d 6c 65 76 65 6c 20 (optimize-level 0040: 32 29 29 0a 3b 3b 3b 0a 3b 3b 3b 20 4d 61 72 6b 2)).;;;.;;; Mark 0050: 20 4a 6f 68 6e 73 6f 6e 2c 20 41 70 72 69 6c 20 Johnson, April 0060: 31 39 39 33 2e 0a 3b 3b 3b 0a 3b 3b 3b 20 41 6e 1993..;;;.;;; An 0070: 20 61 73 73 6f 63 69 61 74 6f 72 20 69 73 20 61 associator is a 0080: 20 73 75 69 74 65 20 6f 66 20 66 75 6e 63 74 69 suite of functi 0090: 6f 6e 73 20 66 6f 72 20 6d 61 6e 69 70 75 6c 61 ons for manipula 00a0: 74 69 6e 67 20 61 20 66 69 6e 69 74 65 20 66 75 ting a finite fu 00b0: 6e 63 74 69 6f 6e 20 20 0a 3b 3b 3b 20 66 72 6f nction .;;; fro 00c0: 6d 20 6b 65 79 73 20 74 6f 20 76 61 6c 75 65 73 m keys to values 00d0: 2e 20 54 68 69 73 20 66 69 6c 65 20 63 6f 6e 74 . This file cont 00e0: 61 69 6e 73 20 61 73 73 6f 63 69 61 74 6f 72 73 ains associators 00f0: 20 62 61 73 65 64 20 6f 6e 20 61 76 6c 20 74 72 based on avl tr 0100: 65 65 73 0a 3b 3b 3b 20 28 77 68 69 63 68 20 61 ees.;;; (which a 0110: 72 65 20 62 61 6c 61 6e 63 65 64 20 62 69 6e 61 re balanced bina 0120: 72 79 20 74 72 65 65 73 29 20 61 6e 64 20 74 72 ry trees) and tr 0130: 69 65 73 20 28 77 68 69 63 68 20 65 78 74 65 6e ies (which exten 0140: 64 20 61 6e 20 61 73 73 6f 63 69 61 74 6f 72 0a d an associator. 0150: 3b 3b 3b 20 66 72 6f 6d 20 6b 65 79 73 20 6f 66 ;;; from keys of 0160: 20 74 79 70 65 20 54 20 74 6f 20 6b 65 79 73 20 type T to keys 0170: 6f 66 20 74 79 70 65 20 6c 69 73 74 2d 6f 66 2d of type list-of- 0180: 54 29 2c 20 61 73 20 77 65 6c 6c 20 61 73 20 61 T), as well as a 0190: 73 73 6f 63 69 61 74 6f 72 73 0a 3b 3b 3b 20 62 ssociators.;;; b 01a0: 61 73 65 64 20 6f 6e 20 61 73 73 6f 63 69 61 74 ased on associat 01b0: 69 6f 6e 20 6c 69 73 74 73 20 61 6e 64 20 76 65 ion lists and ve 01c0: 63 74 6f 72 73 2e 0a 3b 3b 3b 0a 3b 3b 3b 20 41 ctors..;;;.;;; A 01d0: 74 20 74 68 65 20 62 6f 74 74 6f 6d 20 6f 66 20 t the bottom of 01e0: 74 68 69 73 20 66 69 6c 65 20 74 68 65 72 65 20 this file there 01f0: 61 72 65 20 70 72 65 64 65 66 69 6e 65 64 20 61 are predefined a 0200: 73 73 6f 63 69 61 74 6f 72 73 20 66 6f 72 20 61 ssociators for a 0210: 74 6f 6d 73 0a 3b 3b 3b 20 61 6e 64 20 66 6f 72 toms.;;; and for 0220: 20 6c 69 73 74 73 20 6f 66 20 61 74 6f 6d 73 2e lists of atoms. 0230: 0a 3b 3b 3b 0a 3b 3b 3b 20 42 65 63 61 75 73 65 .;;;.;;; Because 0240: 20 61 6c 6c 20 61 73 73 6f 63 69 61 74 6f 72 73 all associators 0250: 20 68 61 76 65 20 74 68 65 20 73 61 6d 65 20 69 have the same i 0260: 6e 74 65 72 66 61 63 65 2c 20 69 74 20 73 68 6f nterface, it sho 0270: 75 6c 64 20 62 65 20 70 6f 73 73 69 62 6c 65 0a uld be possible. 0280: 3b 3b 3b 20 74 6f 20 65 2e 67 2e 2c 20 64 65 76 ;;; to e.g., dev 0290: 65 6c 6f 70 20 61 20 70 72 6f 67 72 61 6d 20 75 elop a program u 02a0: 73 69 6e 67 20 73 69 6d 70 6c 65 2c 20 67 65 6e sing simple, gen 02b0: 65 72 61 6c 20 61 73 73 6f 63 69 61 74 6f 72 73 eral associators 02c0: 20 28 65 2e 67 2e 2c 0a 3b 3b 3b 20 74 68 65 20 (e.g.,.;;; the 02d0: 61 73 73 6f 63 69 61 74 6f 72 73 20 62 61 73 65 associators base 02e0: 64 20 6f 6e 20 61 73 73 6f 63 69 61 74 69 6f 6e d on association 02f0: 20 6c 69 73 74 73 29 2c 20 61 6e 64 20 73 75 62 lists), and sub 0300: 73 74 69 74 75 74 65 20 6d 6f 72 65 0a 3b 3b 3b stitute more.;;; 0310: 20 65 66 66 69 63 69 65 6e 74 2c 20 73 70 65 63 efficient, spec 0320: 69 61 6c 69 7a 65 64 20 61 73 73 6f 63 69 61 74 ialized associat 0330: 6f 72 73 20 69 66 20 6e 65 65 64 65 64 2e 0a 3b ors if needed..; 0340: 3b 3b 0a 3b 3b 3b 20 41 6e 20 61 73 73 6f 63 69 ;;.;;; An associ 0350: 61 74 6f 72 2d 6d 61 6b 65 72 20 69 73 20 61 20 ator-maker is a 0360: 66 75 6e 63 74 69 6f 6e 20 77 68 69 63 68 20 6d function which m 0370: 61 70 73 20 6b 65 79 77 6f 72 64 73 20 69 6e 74 aps keywords int 0380: 6f 20 61 70 70 72 6f 70 72 69 61 74 65 0a 3b 3b o appropriate.;; 0390: 3b 20 61 73 73 6f 63 69 61 74 6f 72 20 6d 61 6e ; associator man 03a0: 69 70 75 6c 61 74 69 6f 6e 20 66 75 6e 63 74 69 ipulation functi 03b0: 6f 6e 73 2e 20 20 48 65 72 65 20 61 72 65 20 74 ons. Here are t 03c0: 68 65 20 6b 65 79 77 6f 72 64 73 20 61 6e 20 61 he keywords an a 03d0: 73 73 6f 63 69 61 74 6f 72 0a 3b 3b 3b 20 73 68 ssociator.;;; sh 03e0: 6f 75 6c 64 20 75 6e 64 65 72 73 74 61 6e 64 3a ould understand: 03f0: 0a 3b 3b 3b 0a 3b 3b 3b 20 28 28 61 73 73 6f 63 .;;;.;;; ((assoc 0400: 69 61 74 6f 72 2d 6d 61 6b 65 72 20 27 6d 61 6b iator-maker 'mak 0410: 65 29 29 20 72 65 74 75 72 6e 73 20 61 20 6e 65 e)) returns a ne 0420: 77 20 61 73 73 6f 63 69 61 74 6f 72 20 74 68 61 w associator tha 0430: 74 20 61 73 73 6f 63 69 61 74 65 73 0a 3b 3b 3b t associates.;;; 0440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 # 0450: 66 20 77 69 74 68 20 65 76 65 72 79 20 76 61 6c f with every val 0460: 75 65 2e 0a 3b 3b 3b 20 28 28 61 73 73 6f 63 69 ue..;;; ((associ 0470: 61 74 6f 72 2d 6d 61 6b 65 72 20 27 72 65 66 29 ator-maker 'ref) 0480: 20 61 73 73 6f 63 69 61 74 6f 72 20 6b 65 79 29 associator key) 0490: 20 72 65 74 75 72 6e 73 20 76 61 6c 75 65 20 61 returns value a 04a0: 73 73 6f 63 69 61 74 65 64 20 77 69 74 68 20 6b ssociated with k 04b0: 65 79 0a 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 ey.;;; 04c0: 20 20 20 20 69 6e 20 61 73 73 6f 63 69 61 74 6f in associato 04d0: 72 2e 0a 3b 3b 3b 20 28 28 61 73 73 6f 63 69 61 r..;;; ((associa 04e0: 74 6f 72 2d 6d 61 6b 65 72 20 27 73 65 74 21 29 tor-maker 'set!) 04f0: 20 61 73 73 6f 63 69 61 74 6f 72 20 6b 65 79 20 associator key 0500: 76 61 6c 75 65 29 20 64 65 73 74 72 75 63 74 69 value) destructi 0510: 76 65 6c 79 20 63 68 61 6e 67 65 73 20 74 68 65 vely changes the 0520: 0a 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 .;;; 0530: 20 20 76 61 6c 75 65 20 61 73 73 6f 63 69 61 74 value associat 0540: 65 64 20 77 69 74 68 20 6b 65 79 20 69 6e 20 61 ed with key in a 0550: 73 73 6f 63 69 61 74 6f 72 20 74 6f 20 62 65 20 ssociator to be 0560: 76 61 6c 75 65 2c 20 61 6e 64 0a 3b 3b 3b 20 20 value, and.;;; 0570: 20 20 20 20 20 20 20 20 20 20 20 20 72 65 74 75 retu 0580: 72 6e 73 20 74 68 65 20 6f 6c 64 20 76 61 6c 75 rns the old valu 0590: 65 2e 0a 3b 3b 3b 20 28 28 61 73 73 6f 63 69 61 e..;;; ((associa 05a0: 74 6f 72 2d 6d 61 6b 65 72 20 27 75 70 64 61 74 tor-maker 'updat 05b0: 65 21 29 20 61 73 73 6f 63 69 61 74 6f 72 20 6b e!) associator k 05c0: 65 79 20 75 70 64 61 74 65 2d 66 6e 29 20 64 65 ey update-fn) de 05d0: 73 74 72 75 63 74 69 76 65 6c 79 0a 3b 3b 3b 20 structively.;;; 05e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 63 68 61 cha 05f0: 6e 67 65 73 20 74 68 65 20 76 61 6c 75 65 20 61 nges the value a 0600: 73 73 6f 63 69 61 74 65 64 20 77 69 74 68 20 6b ssociated with k 0610: 65 79 20 74 6f 20 28 75 70 64 61 74 65 2d 66 6e ey to (update-fn 0620: 20 6b 65 79 20 0a 3b 3b 3b 20 20 20 20 20 20 20 key .;;; 0630: 20 20 20 20 20 20 20 6f 6c 64 2d 76 61 6c 75 65 old-value 0640: 29 2c 20 77 68 65 72 65 20 6f 6c 64 2d 76 61 6c ), where old-val 0650: 75 65 20 77 61 73 20 74 68 65 20 76 61 6c 75 65 ue was the value 0660: 20 74 68 61 74 20 74 68 65 20 61 73 73 6f 63 69 that the associ 0670: 61 74 6f 72 0a 3b 3b 3b 20 20 20 20 20 20 20 20 ator.;;; 0680: 20 20 20 20 20 20 70 72 65 76 69 6f 75 73 6c 79 previously 0690: 20 61 73 73 6f 63 69 61 74 65 64 20 77 69 74 68 associated with 06a0: 20 76 61 6c 75 65 2e 0a 3b 3b 3b 20 28 28 61 73 value..;;; ((as 06b0: 73 6f 63 69 61 74 6f 72 2d 6d 61 6b 65 72 20 27 sociator-maker ' 06c0: 70 75 73 68 21 29 20 61 73 73 6f 63 69 61 74 6f push!) associato 06d0: 72 20 6b 65 79 20 65 6c 74 29 20 64 65 73 74 72 r key elt) destr 06e0: 75 63 74 69 76 65 6c 79 20 63 68 61 6e 67 65 73 uctively changes 06f0: 20 74 68 65 0a 3b 3b 3b 20 20 20 20 20 20 20 20 the.;;; 0700: 20 20 20 20 20 20 76 61 6c 75 65 20 61 73 73 6f value asso 0710: 63 69 61 74 65 64 20 77 69 74 68 20 6b 65 79 20 ciated with key 0720: 74 6f 20 28 63 6f 6e 73 20 65 6c 74 20 65 6c 74 to (cons elt elt 0730: 73 29 2c 20 77 68 65 72 65 20 65 6c 74 73 20 69 s), where elts i 0740: 73 0a 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 20 s.;;; 0750: 20 20 20 27 28 29 20 69 66 20 74 68 65 20 76 61 '() if the va 0760: 6c 75 65 20 61 73 73 6f 63 69 61 74 65 64 20 77 lue associated w 0770: 69 74 68 20 6b 65 79 20 77 61 73 20 23 66 2c 20 ith key was #f, 0780: 61 6e 64 20 74 68 65 20 76 61 6c 75 65 0a 3b 3b and the value.;; 0790: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ; 07a0: 61 73 73 6f 63 69 61 74 65 64 20 77 69 74 68 20 associated with 07b0: 6b 65 79 20 6f 74 68 65 72 77 69 73 65 2e 0a 3b key otherwise..; 07c0: 3b 3b 20 28 28 61 73 73 6f 63 69 61 74 6f 72 2d ;; ((associator- 07d0: 6d 61 6b 65 72 20 27 69 6e 63 21 29 20 61 73 73 maker 'inc!) ass 07e0: 6f 63 69 61 74 6f 72 20 6b 65 79 20 69 6e 63 29 ociator key inc) 07f0: 20 64 65 73 74 72 75 63 74 69 76 65 6c 79 20 63 destructively c 0800: 68 61 6e 67 65 73 20 74 68 65 0a 3b 3b 3b 20 20 hanges the.;;; 0810: 20 20 20 20 20 20 20 20 20 20 20 20 76 61 6c 75 valu 0820: 65 20 61 73 73 6f 63 69 61 74 65 64 20 77 69 74 e associated wit 0830: 68 20 6b 65 79 20 74 6f 20 28 2b 20 69 6e 63 20 h key to (+ inc 0840: 76 61 6c 75 65 29 2c 20 77 68 65 72 65 20 76 61 value), where va 0850: 6c 75 65 20 69 73 20 30 20 0a 3b 3b 3b 20 20 20 lue is 0 .;;; 0860: 20 20 20 20 20 20 20 20 20 20 20 69 66 20 74 68 if th 0870: 65 20 76 61 6c 75 65 20 61 73 73 6f 63 69 61 74 e value associat 0880: 65 64 20 77 69 74 68 20 6b 65 79 20 77 61 73 20 ed with key was 0890: 23 66 2c 20 61 6e 64 20 74 68 65 20 76 61 6c 75 #f, and the valu 08a0: 65 0a 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 20 e.;;; 08b0: 20 20 20 61 73 73 6f 63 69 61 74 65 64 20 77 69 associated wi 08c0: 74 68 20 6b 65 79 20 6f 74 68 65 72 77 69 73 65 th key otherwise 08d0: 2e 0a 3b 3b 3b 20 28 28 61 73 73 6f 63 69 61 74 ..;;; ((associat 08e0: 6f 72 2d 6d 61 6b 65 72 20 27 6d 61 70 29 20 61 or-maker 'map) a 08f0: 73 73 6f 63 69 61 74 6f 72 20 66 6e 29 20 72 65 ssociator fn) re 0900: 74 75 72 6e 73 20 61 20 6e 65 77 20 61 73 73 6f turns a new asso 0910: 63 69 61 74 6f 72 20 74 68 61 74 0a 3b 3b 3b 20 ciator that.;;; 0920: 20 20 20 20 20 20 20 20 20 20 20 20 20 61 73 73 ass 0930: 69 67 6e 73 20 28 66 6e 20 6b 65 79 20 76 61 6c igns (fn key val 0940: 75 65 29 20 74 6f 20 65 61 63 68 20 6b 65 79 20 ue) to each key 0950: 77 68 65 72 65 20 61 73 73 6f 63 69 61 74 6f 72 where associator 0960: 0a 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 .;;; 0970: 20 20 61 73 73 69 67 6e 65 64 20 61 20 6e 6f 6e assigned a non 0980: 2d 23 66 20 76 61 6c 75 65 20 76 61 6c 75 65 20 -#f value value 0990: 74 6f 20 6b 65 79 2e 0a 3b 3b 3b 20 28 28 61 73 to key..;;; ((as 09a0: 73 6f 63 69 61 74 6f 72 2d 6d 61 6b 65 72 20 27 sociator-maker ' 09b0: 6d 61 70 21 29 20 61 73 73 6f 63 69 61 74 6f 72 map!) associator 09c0: 20 66 6e 29 20 69 73 20 74 68 65 20 73 61 6d 65 fn) is the same 09d0: 20 61 73 20 6d 61 70 2c 20 65 78 63 65 70 74 0a as map, except. 09e0: 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;; 09f0: 20 74 68 61 74 20 61 73 73 6f 63 69 61 74 6f 72 that associator 0a00: 20 69 73 20 64 65 73 74 72 75 63 74 69 76 65 6c is destructivel 0a10: 79 20 75 70 64 61 74 65 64 2e 0a 3b 3b 3b 20 28 y updated..;;; ( 0a20: 28 61 73 73 6f 63 69 61 74 6f 72 2d 6d 61 6b 65 (associator-make 0a30: 72 20 27 66 6f 72 2d 65 61 63 68 29 20 61 73 73 r 'for-each) ass 0a40: 6f 63 69 61 74 6f 72 20 66 6e 29 20 63 61 6c 6c ociator fn) call 0a50: 73 20 28 66 6e 20 6b 65 79 20 76 61 6c 75 65 29 s (fn key value) 0a60: 20 6f 6e 0a 3b 3b 3b 20 20 20 20 20 20 20 20 20 on.;;; 0a70: 20 20 20 20 20 65 61 63 68 20 6b 65 79 2d 76 61 each key-va 0a80: 6c 75 65 20 70 61 69 72 20 69 6e 20 61 73 73 6f lue pair in asso 0a90: 63 69 61 74 6f 72 20 73 75 63 68 20 74 68 61 74 ciator such that 0aa0: 20 76 61 6c 75 65 20 3d 2f 3d 20 23 66 2e 0a 3b value =/= #f..; 0ab0: 3b 3b 20 28 28 61 73 73 6f 63 69 61 74 6f 72 2d ;; ((associator- 0ac0: 6d 61 6b 65 72 20 27 72 65 64 75 63 65 29 20 61 maker 'reduce) a 0ad0: 73 73 6f 63 69 61 74 6f 72 20 66 6e 20 73 74 61 ssociator fn sta 0ae0: 72 74 29 20 63 61 6c 6c 73 0a 3b 3b 3b 20 20 20 rt) calls.;;; 0af0: 20 20 20 20 20 20 20 20 20 20 20 28 66 6e 20 6b (fn k 0b00: 65 79 20 76 61 6c 75 65 20 73 6f 2d 66 61 72 29 ey value so-far) 0b10: 20 6f 6e 20 65 61 63 68 20 6b 65 79 2d 76 61 6c on each key-val 0b20: 75 65 20 70 61 69 72 20 69 6e 20 61 73 73 6f 63 ue pair in assoc 0b30: 69 61 74 6f 72 2c 0a 3b 3b 3b 20 20 20 20 20 20 iator,.;;; 0b40: 20 20 20 20 20 20 20 20 77 68 65 72 65 20 73 6f where so 0b50: 2d 66 61 72 20 69 73 20 74 68 65 20 76 61 6c 75 -far is the valu 0b60: 65 20 72 65 74 75 72 6e 65 64 20 66 72 6f 6d 20 e returned from 0b70: 74 68 65 20 70 72 65 76 69 6f 75 73 20 66 6e 0a the previous fn. 0b80: 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;; 0b90: 20 63 61 6c 6c 20 28 73 6f 2d 66 61 72 20 69 6e call (so-far in 0ba0: 20 74 68 65 20 66 69 72 73 74 20 66 6e 20 63 61 the first fn ca 0bb0: 6c 6c 20 69 73 20 73 74 61 72 74 29 2e 20 0a 3b ll is start). .; 0bc0: 3b 3b 0a 3b 3b 3b 20 54 68 65 20 69 64 65 61 20 ;;.;;; The idea 0bd0: 69 73 20 74 68 61 74 20 67 69 76 65 6e 20 61 6e is that given an 0be0: 20 61 73 73 6f 63 69 61 74 6f 72 2d 6d 61 6b 65 associator-make 0bf0: 72 2c 20 74 68 65 20 76 61 72 69 6f 75 73 20 61 r, the various a 0c00: 73 73 6f 63 69 61 74 6f 72 20 0a 3b 3b 3b 20 6d ssociator .;;; m 0c10: 61 6e 69 70 75 6c 61 74 69 6f 6e 20 66 75 6e 63 anipulation func 0c20: 74 69 6f 6e 73 20 77 69 6c 6c 20 62 65 20 61 73 tions will be as 0c30: 73 69 67 6e 65 64 20 74 6f 20 6c 6f 63 61 6c 20 signed to local 0c40: 76 61 72 69 61 62 6c 65 73 2c 20 72 61 74 68 65 variables, rathe 0c50: 72 20 74 68 61 6e 0a 3b 3b 3b 20 6f 62 74 61 69 r than.;;; obtai 0c60: 6e 65 64 20 62 79 20 61 73 73 6f 63 69 61 74 6f ned by associato 0c70: 72 2d 6d 61 6b 65 72 20 65 61 63 68 20 74 69 6d r-maker each tim 0c80: 65 20 74 68 65 20 6d 61 6e 69 70 75 6c 61 74 69 e the manipulati 0c90: 6f 6e 20 66 75 6e 63 74 69 6f 6e 73 20 61 72 65 on functions are 0ca0: 20 75 73 65 64 2e 0a 3b 3b 3b 0a 3b 3b 3b 20 4f used..;;;.;;; O 0cb0: 66 74 65 6e 20 61 20 70 61 72 74 69 63 75 6c 61 ften a particula 0cc0: 72 20 74 79 70 65 20 6f 66 20 61 73 73 6f 63 69 r type of associ 0cd0: 61 74 6f 72 20 6e 65 65 64 73 20 61 64 64 69 74 ator needs addit 0ce0: 69 6f 6e 61 6c 20 70 61 72 61 6d 65 74 65 72 73 ional parameters 0cf0: 2c 20 65 2e 67 2e 2c 0a 3b 3b 3b 20 61 6e 20 6f , e.g.,.;;; an o 0d00: 72 64 65 72 69 6e 67 20 6f 72 20 65 71 75 61 6c rdering or equal 0d10: 69 74 79 20 70 72 65 64 69 63 61 74 65 2e 20 20 ity predicate. 0d20: 54 68 65 20 61 76 6c 2d 6d 61 6b 65 72 2c 20 66 The avl-maker, f 0d30: 6f 72 20 65 78 61 6d 70 6c 65 2c 20 74 61 6b 65 or example, take 0d40: 73 20 61 6e 0a 3b 3b 3b 20 6f 72 64 65 72 69 6e s an.;;; orderin 0d50: 67 20 70 72 65 64 69 63 61 74 65 20 61 6e 64 20 g predicate and 0d60: 72 65 74 75 72 6e 73 20 61 6e 20 61 73 73 6f 63 returns an assoc 0d70: 69 61 74 6f 72 2d 6d 61 6b 65 72 2e 0a 0a 28 64 iator-maker...(d 0d80: 65 66 69 6e 65 20 28 61 73 73 6f 63 3a 69 6e 63 efine (assoc:inc 0d90: 21 2d 6d 61 6b 65 72 20 75 70 64 61 74 65 21 29 !-maker update!) 0da0: 0a 20 20 28 6c 61 6d 62 64 61 20 28 61 73 73 6f . (lambda (asso 0db0: 63 20 6b 65 79 20 69 6e 63 29 0a 20 20 20 20 28 c key inc). ( 0dc0: 69 66 20 28 6e 6f 74 20 28 7a 65 72 6f 3f 20 69 if (not (zero? i 0dd0: 6e 63 29 29 0a 20 20 20 20 20 20 28 75 70 64 61 nc)). (upda 0de0: 74 65 21 20 61 73 73 6f 63 20 6b 65 79 20 28 6c te! assoc key (l 0df0: 61 6d 62 64 61 20 28 76 61 6c 29 20 28 69 66 20 ambda (val) (if 0e00: 76 61 6c 20 28 2b 20 76 61 6c 20 69 6e 63 29 20 val (+ val inc) 0e10: 69 6e 63 29 29 29 29 29 29 0a 0a 28 64 65 66 69 inc))))))..(defi 0e20: 6e 65 20 28 61 73 73 6f 63 3a 70 75 73 68 21 2d ne (assoc:push!- 0e30: 6d 61 6b 65 72 20 75 70 64 61 74 65 21 29 0a 20 maker update!). 0e40: 20 28 6c 61 6d 62 64 61 20 28 61 73 73 6f 63 20 (lambda (assoc 0e50: 6b 65 79 20 65 6c 74 29 0a 20 20 20 20 28 75 70 key elt). (up 0e60: 64 61 74 65 21 20 61 73 73 6f 63 20 6b 65 79 20 date! assoc key 0e70: 28 6c 61 6d 62 64 61 20 28 65 6c 74 73 29 20 28 (lambda (elts) ( 0e80: 69 66 20 65 6c 74 73 20 28 63 6f 6e 73 20 65 6c if elts (cons el 0e90: 74 20 65 6c 74 73 29 20 28 6c 69 73 74 20 65 6c t elts) (list el 0ea0: 74 29 29 29 29 29 29 0a 0a 3b 3b 3b 20 61 6c 69 t))))))..;;; ali 0eb0: 73 74 2d 61 73 73 6f 63 69 61 74 6f 72 73 20 61 st-associators a 0ec0: 72 65 20 73 69 6d 70 6c 65 20 61 73 73 6f 63 69 re simple associ 0ed0: 61 74 69 6f 6e 20 6c 69 73 74 73 2e 0a 3b 3b 3b ation lists..;;; 0ee0: 20 54 68 65 79 20 61 72 65 20 6c 69 73 74 73 20 They are lists 0ef0: 6f 66 20 74 68 65 20 66 6f 72 6d 20 28 40 20 28 of the form (@ ( 0f00: 6b 65 79 31 20 2e 20 76 61 6c 31 29 20 2e 2e 2e key1 . val1) ... 0f10: 29 0a 3b 3b 3b 20 54 68 65 79 20 68 61 76 65 20 ).;;; They have 0f20: 74 68 65 20 61 64 76 61 6e 74 61 67 65 20 6f 66 the advantage of 0f30: 20 62 65 69 6e 67 20 65 61 73 69 6c 79 20 72 65 being easily re 0f40: 61 64 61 62 6c 65 2e 0a 0a 28 64 65 66 69 6e 65 adable...(define 0f50: 20 28 61 6c 69 73 74 2d 6d 61 6b 65 72 20 65 71 (alist-maker eq 0f60: 70 3f 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 28 p?).. (define ( 0f70: 66 69 6e 64 2d 70 61 69 72 20 61 76 73 20 6b 65 find-pair avs ke 0f80: 79 29 0a 20 20 20 20 28 69 66 20 28 70 61 69 72 y). (if (pair 0f90: 3f 20 61 76 73 29 0a 20 20 20 20 20 20 28 69 66 ? avs). (if 0fa0: 20 28 65 71 70 3f 20 28 63 61 61 72 20 61 76 73 (eqp? (caar avs 0fb0: 29 20 6b 65 79 29 0a 20 20 20 20 20 20 20 20 28 ) key). ( 0fc0: 63 61 72 20 61 76 73 29 0a 20 20 20 20 20 20 20 car avs). 0fd0: 20 28 66 69 6e 64 2d 70 61 69 72 20 28 63 64 72 (find-pair (cdr 0fe0: 20 61 76 73 29 20 6b 65 79 29 29 0a 20 20 20 20 avs) key)). 0ff0: 20 20 23 66 29 29 0a 0a 20 20 28 64 65 66 69 6e #f)).. (defin 1000: 65 20 28 70 75 73 68 20 61 6c 69 73 74 20 6b 65 e (push alist ke 1010: 79 20 76 61 6c 75 65 29 0a 20 20 20 20 28 73 65 y value). (se 1020: 74 2d 63 64 72 21 20 61 6c 69 73 74 20 28 63 6f t-cdr! alist (co 1030: 6e 73 20 28 63 6f 6e 73 20 6b 65 79 20 76 61 6c ns (cons key val 1040: 75 65 29 20 28 63 64 72 20 61 6c 69 73 74 29 29 ue) (cdr alist)) 1050: 29 0a 20 20 20 20 23 66 29 0a 0a 20 20 28 64 65 ). #f).. (de 1060: 66 69 6e 65 20 28 6c 6f 6f 6b 75 70 20 61 6c 69 fine (lookup ali 1070: 73 74 20 6b 65 79 29 0a 20 20 20 20 28 6c 65 74 st key). (let 1080: 20 28 28 70 20 28 66 69 6e 64 2d 70 61 69 72 20 ((p (find-pair 1090: 28 63 64 72 20 61 6c 69 73 74 29 20 6b 65 79 29 (cdr alist) key) 10a0: 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 70 61 )). (if (pa 10b0: 69 72 3f 20 70 29 0a 20 20 20 20 20 20 20 20 28 ir? p). ( 10c0: 63 64 72 20 70 29 0a 20 20 20 20 20 20 20 20 23 cdr p). # 10d0: 66 29 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 f))).. (define 10e0: 28 75 70 64 61 74 65 21 20 61 6c 69 73 74 20 6b (update! alist k 10f0: 65 79 20 75 70 64 61 74 65 2d 66 6e 29 0a 20 20 ey update-fn). 1100: 20 20 28 6c 65 74 20 28 28 70 20 28 66 69 6e 64 (let ((p (find 1110: 2d 70 61 69 72 20 28 63 64 72 20 61 6c 69 73 74 -pair (cdr alist 1120: 29 20 6b 65 79 29 29 29 0a 20 20 20 20 20 20 28 ) key))). ( 1130: 69 66 20 28 70 61 69 72 3f 20 70 29 0a 20 20 20 if (pair? p). 1140: 20 20 20 20 20 28 6c 65 74 20 28 28 76 20 28 63 (let ((v (c 1150: 64 72 20 70 29 29 29 0a 20 20 20 20 20 20 20 20 dr p))). 1160: 20 20 28 73 65 74 2d 63 64 72 21 20 70 20 28 75 (set-cdr! p (u 1170: 70 64 61 74 65 2d 66 6e 20 76 29 29 0a 20 20 20 pdate-fn v)). 1180: 20 20 20 20 20 20 20 76 29 0a 20 20 20 20 20 20 v). 1190: 20 20 28 70 75 73 68 20 61 6c 69 73 74 20 6b 65 (push alist ke 11a0: 79 20 28 75 70 64 61 74 65 2d 66 6e 20 23 66 29 y (update-fn #f) 11b0: 29 29 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 )))).. (define 11c0: 28 72 65 64 75 63 65 20 61 76 73 20 66 6e 20 73 (reduce avs fn s 11d0: 74 61 72 74 29 0a 20 20 20 20 28 69 66 20 28 70 tart). (if (p 11e0: 61 69 72 3f 20 61 76 73 29 0a 20 20 20 20 20 20 air? avs). 11f0: 28 72 65 64 75 63 65 20 28 63 64 72 20 61 76 73 (reduce (cdr avs 1200: 29 20 66 6e 0a 20 20 20 20 20 20 20 20 20 20 20 ) fn. 1210: 20 20 20 28 69 66 20 28 63 64 61 72 20 61 76 73 (if (cdar avs 1220: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 1230: 20 20 28 66 6e 20 28 63 61 61 72 20 61 76 73 29 (fn (caar avs) 1240: 20 28 63 64 61 72 20 61 76 73 29 20 73 74 61 72 (cdar avs) star 1250: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t). 1260: 20 20 20 73 74 61 72 74 29 29 0a 20 20 20 20 20 start)). 1270: 20 73 74 61 72 74 29 29 0a 0a 20 20 28 6c 61 6d start)).. (lam 1280: 62 64 61 20 28 73 65 6c 65 63 74 6f 72 29 0a 20 bda (selector). 1290: 20 20 20 28 63 61 73 65 20 73 65 6c 65 63 74 6f (case selecto 12a0: 72 0a 20 20 20 20 20 20 28 28 6d 61 6b 65 29 20 r. ((make) 12b0: 28 6c 61 6d 62 64 61 20 28 29 20 28 6c 69 73 74 (lambda () (list 12c0: 20 27 40 29 29 29 0a 20 20 20 20 20 20 28 28 72 '@))). ((r 12d0: 65 66 29 20 6c 6f 6f 6b 75 70 29 0a 20 20 20 20 ef) lookup). 12e0: 20 20 28 28 73 65 74 21 29 20 28 6c 61 6d 62 64 ((set!) (lambd 12f0: 61 20 28 61 6c 69 73 74 20 6b 65 79 20 76 61 6c a (alist key val 1300: 75 65 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 ue) . 1310: 20 20 20 20 20 20 20 20 28 75 70 64 61 74 65 21 (update! 1320: 20 61 6c 69 73 74 20 6b 65 79 20 28 6c 61 6d 62 alist key (lamb 1330: 64 61 20 28 6f 6c 64 76 61 6c 75 65 29 20 76 61 da (oldvalue) va 1340: 6c 75 65 29 29 29 29 0a 20 20 20 20 20 20 28 28 lue)))). (( 1350: 75 70 64 61 74 65 21 29 20 75 70 64 61 74 65 21 update!) update! 1360: 29 0a 20 20 20 20 20 20 28 28 69 6e 63 21 29 20 ). ((inc!) 1370: 28 61 73 73 6f 63 3a 69 6e 63 21 2d 6d 61 6b 65 (assoc:inc!-make 1380: 72 20 75 70 64 61 74 65 21 29 29 0a 20 20 20 20 r update!)). 1390: 20 20 28 28 70 75 73 68 21 29 20 28 61 73 73 6f ((push!) (asso 13a0: 63 3a 70 75 73 68 21 2d 6d 61 6b 65 72 20 75 70 c:push!-maker up 13b0: 64 61 74 65 21 29 29 0a 20 20 20 20 20 20 28 28 date!)). (( 13c0: 6d 61 70 29 20 28 6c 61 6d 62 64 61 20 28 61 6c map) (lambda (al 13d0: 69 73 74 20 66 6e 29 0a 20 20 20 20 20 20 20 20 ist fn). 13e0: 20 20 20 20 20 20 20 28 63 6f 6e 73 20 27 40 20 (cons '@ 13f0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 70 29 (map (lambda (p) 1400: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 1410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1420: 20 28 63 6f 6e 73 20 28 63 61 72 20 70 29 20 28 (cons (car p) ( 1430: 69 66 20 28 63 64 72 20 70 29 0a 20 20 20 20 20 if (cdr p). 1440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1450: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1460: 20 20 20 20 20 20 20 20 20 20 28 66 6e 20 28 63 (fn (c 1470: 61 72 20 70 29 20 28 63 64 72 20 70 29 29 0a 20 ar p) (cdr p)). 1480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 14a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 #f 14b0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))). 14c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 14d0: 20 28 63 64 72 20 61 6c 69 73 74 29 29 29 29 29 (cdr alist))))) 14e0: 0a 20 20 20 20 20 20 28 28 66 6f 72 2d 65 61 63 . ((for-eac 14f0: 68 29 20 28 6c 61 6d 62 64 61 20 28 61 6c 69 73 h) (lambda (alis 1500: 74 20 66 6e 29 0a 20 20 20 20 20 20 20 20 20 20 t fn). 1510: 20 20 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 (for-ea 1520: 63 68 20 28 6c 61 6d 62 64 61 20 28 70 29 20 0a ch (lambda (p) . 1530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i 1550: 66 20 28 63 64 72 20 70 29 0a 20 20 20 20 20 20 f (cdr p). 1560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1570: 20 20 20 20 20 20 20 20 20 20 28 66 6e 20 28 63 (fn (c 1580: 61 72 20 70 29 20 28 63 64 72 20 70 29 29 29 29 ar p) (cdr p)))) 1590: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 15a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 64 (cd 15b0: 72 20 61 6c 69 73 74 29 29 29 29 0a 20 20 20 20 r alist)))). 15c0: 20 20 28 28 6d 61 70 21 29 20 28 6c 61 6d 62 64 ((map!) (lambd 15d0: 61 20 28 61 6c 69 73 74 20 66 6e 29 0a 20 20 20 a (alist fn). 15e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 6f (fo 15f0: 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda ( 1600: 70 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 p) . 1610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1620: 28 69 66 20 28 63 64 72 20 70 29 0a 20 20 20 20 (if (cdr p). 1630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1640: 20 20 20 20 20 20 20 20 20 20 28 73 65 74 2d 63 (set-c 1650: 64 72 21 20 70 20 28 66 6e 20 28 63 61 72 20 70 dr! p (fn (car p 1660: 29 20 28 63 64 72 20 70 29 29 29 29 29 0a 20 20 ) (cdr p))))). 1670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1680: 20 20 20 20 20 20 20 20 28 63 64 72 20 61 6c 69 (cdr ali 1690: 73 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 st)). 16a0: 20 20 20 20 20 61 6c 69 73 74 29 29 0a 20 20 20 alist)). 16b0: 20 20 20 28 28 72 65 64 75 63 65 29 20 28 6c 61 ((reduce) (la 16c0: 6d 62 64 61 20 28 61 6c 69 73 74 20 66 6e 20 73 mbda (alist fn s 16d0: 74 61 72 74 29 0a 20 20 20 20 20 20 20 20 20 20 tart). 16e0: 20 20 20 20 20 20 20 20 28 72 65 64 75 63 65 20 (reduce 16f0: 28 63 64 72 20 61 6c 69 73 74 29 20 66 6e 20 73 (cdr alist) fn s 1700: 74 61 72 74 29 29 29 0a 20 20 20 20 20 20 28 65 tart))). (e 1710: 6c 73 65 20 28 65 72 72 6f 72 20 22 55 6e 69 6d lse (error "Unim 1720: 70 6c 65 6d 65 6e 74 65 64 20 73 65 6c 65 63 74 plemented select 1730: 6f 72 3a 20 22 20 73 65 6c 65 63 74 6f 72 29 29 or: " selector)) 1740: 29 29 29 0a 0a 3b 3b 3b 20 61 76 6c 2d 61 73 73 )))..;;; avl-ass 1750: 6f 63 69 61 74 6f 72 73 20 61 72 65 20 62 61 6c ociators are bal 1760: 61 6e 63 65 64 20 62 69 6e 61 72 79 20 74 72 65 anced binary tre 1770: 65 73 0a 0a 28 64 65 66 69 6e 65 20 28 61 76 6c es..(define (avl 1780: 2d 6d 61 6b 65 72 20 6f 72 64 65 72 65 64 3f 29 -maker ordered?) 1790: 0a 20 20 0a 20 20 28 64 65 66 69 6e 65 20 28 6e . . (define (n 17a0: 6f 64 65 2d 68 65 69 67 68 74 20 6e 6f 64 65 29 ode-height node) 17b0: 20 28 69 66 20 6e 6f 64 65 20 28 76 65 63 74 6f (if node (vecto 17c0: 72 2d 72 65 66 20 6e 6f 64 65 20 30 29 20 30 29 r-ref node 0) 0) 17d0: 29 0a 20 20 28 64 65 66 69 6e 65 20 28 6e 6f 64 ). (define (nod 17e0: 65 2d 6c 65 66 74 20 6e 6f 64 65 29 20 28 76 65 e-left node) (ve 17f0: 63 74 6f 72 2d 72 65 66 20 6e 6f 64 65 20 31 29 ctor-ref node 1) 1800: 29 0a 20 20 28 64 65 66 69 6e 65 20 28 6e 6f 64 ). (define (nod 1810: 65 2d 6b 65 79 20 6e 6f 64 65 29 20 28 76 65 63 e-key node) (vec 1820: 74 6f 72 2d 72 65 66 20 6e 6f 64 65 20 32 29 29 tor-ref node 2)) 1830: 0a 20 20 28 64 65 66 69 6e 65 20 28 6e 6f 64 65 . (define (node 1840: 2d 76 61 6c 75 65 20 6e 6f 64 65 29 20 28 76 65 -value node) (ve 1850: 63 74 6f 72 2d 72 65 66 20 6e 6f 64 65 20 33 29 ctor-ref node 3) 1860: 29 0a 20 20 28 64 65 66 69 6e 65 20 28 6e 6f 64 ). (define (nod 1870: 65 2d 72 69 67 68 74 20 6e 6f 64 65 29 20 28 76 e-right node) (v 1880: 65 63 74 6f 72 2d 72 65 66 20 6e 6f 64 65 20 34 ector-ref node 4 1890: 29 29 0a 20 20 0a 20 20 28 64 65 66 69 6e 65 20 )). . (define 18a0: 28 73 65 74 2d 6e 6f 64 65 2d 68 65 69 67 68 74 (set-node-height 18b0: 21 20 6e 6f 64 65 20 68 65 69 67 68 74 29 20 28 ! node height) ( 18c0: 76 65 63 74 6f 72 2d 73 65 74 21 20 6e 6f 64 65 vector-set! node 18d0: 20 30 20 68 65 69 67 68 74 29 29 0a 20 20 28 64 0 height)). (d 18e0: 65 66 69 6e 65 20 28 73 65 74 2d 6e 6f 64 65 2d efine (set-node- 18f0: 6c 65 66 74 21 20 6e 6f 64 65 20 6c 65 66 74 29 left! node left) 1900: 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 6e 6f (vector-set! no 1910: 64 65 20 31 20 6c 65 66 74 29 29 0a 20 20 28 64 de 1 left)). (d 1920: 65 66 69 6e 65 20 28 73 65 74 2d 6e 6f 64 65 2d efine (set-node- 1930: 6b 65 79 21 20 6e 6f 64 65 20 6b 65 79 29 20 28 key! node key) ( 1940: 76 65 63 74 6f 72 2d 73 65 74 21 20 6e 6f 64 65 vector-set! node 1950: 20 32 20 6b 65 79 29 29 0a 20 20 28 64 65 66 69 2 key)). (defi 1960: 6e 65 20 28 73 65 74 2d 6e 6f 64 65 2d 76 61 6c ne (set-node-val 1970: 75 65 21 20 6e 6f 64 65 20 76 61 6c 75 65 29 20 ue! node value) 1980: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 6e 6f 64 (vector-set! nod 1990: 65 20 33 20 76 61 6c 75 65 29 29 0a 20 20 28 64 e 3 value)). (d 19a0: 65 66 69 6e 65 20 28 73 65 74 2d 6e 6f 64 65 2d efine (set-node- 19b0: 72 69 67 68 74 21 20 6e 6f 64 65 20 72 69 67 68 right! node righ 19c0: 74 29 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 t) (vector-set! 19d0: 6e 6f 64 65 20 34 20 72 69 67 68 74 29 29 0a 20 node 4 right)). 19e0: 20 0a 20 20 28 64 65 66 69 6e 65 20 28 73 65 74 . (define (set 19f0: 2d 6e 6f 64 65 2d 6b 65 79 2d 76 61 6c 75 65 21 -node-key-value! 1a00: 20 6e 6f 64 65 20 6b 65 79 20 76 61 6c 75 65 29 node key value) 1a10: 0a 20 20 20 20 28 73 65 74 2d 6e 6f 64 65 2d 68 . (set-node-h 1a20: 65 69 67 68 74 21 20 6e 6f 64 65 20 31 29 0a 20 eight! node 1). 1a30: 20 20 20 28 73 65 74 2d 6e 6f 64 65 2d 6b 65 79 (set-node-key 1a40: 21 20 6e 6f 64 65 20 6b 65 79 29 0a 20 20 20 20 ! node key). 1a50: 28 73 65 74 2d 6e 6f 64 65 2d 76 61 6c 75 65 21 (set-node-value! 1a60: 20 6e 6f 64 65 20 76 61 6c 75 65 29 29 0a 20 20 node value)). 1a70: 0a 20 20 28 64 65 66 69 6e 65 20 28 65 6d 70 74 . (define (empt 1a80: 79 3f 20 6e 6f 64 65 29 0a 20 20 20 20 28 6e 6f y? node). (no 1a90: 74 20 28 76 65 63 74 6f 72 2d 72 65 66 20 6e 6f t (vector-ref no 1aa0: 64 65 20 30 29 29 29 0a 20 20 0a 20 20 28 64 65 de 0))). . (de 1ab0: 66 69 6e 65 20 28 73 65 61 72 63 68 20 6b 65 79 fine (search key 1ac0: 20 6e 6f 64 65 29 0a 20 20 20 20 28 69 66 20 6e node). (if n 1ad0: 6f 64 65 0a 20 20 20 20 20 20 20 20 28 63 6f 6e ode. (con 1ae0: 64 20 28 28 6f 72 64 65 72 65 64 3f 20 6b 65 79 d ((ordered? key 1af0: 20 28 6e 6f 64 65 2d 6b 65 79 20 6e 6f 64 65 29 (node-key node) 1b00: 29 20 28 73 65 61 72 63 68 20 6b 65 79 20 28 6e ) (search key (n 1b10: 6f 64 65 2d 6c 65 66 74 20 6e 6f 64 65 29 29 29 ode-left node))) 1b20: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . ( 1b30: 28 6f 72 64 65 72 65 64 3f 20 28 6e 6f 64 65 2d (ordered? (node- 1b40: 6b 65 79 20 6e 6f 64 65 29 20 6b 65 79 29 20 28 key node) key) ( 1b50: 73 65 61 72 63 68 20 6b 65 79 20 28 6e 6f 64 65 search key (node 1b60: 2d 72 69 67 68 74 20 6e 6f 64 65 29 29 29 0a 20 -right node))). 1b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c (el 1b80: 73 65 20 28 6e 6f 64 65 2d 76 61 6c 75 65 20 6e se (node-value n 1b90: 6f 64 65 29 29 29 0a 20 20 20 20 20 20 20 20 23 ode))). # 1ba0: 66 29 29 0a 20 20 0a 20 20 28 64 65 66 69 6e 65 f)). . (define 1bb0: 20 28 63 6f 6d 70 75 74 65 2d 68 65 69 67 68 74 (compute-height 1bc0: 21 20 6e 6f 64 65 29 0a 20 20 20 20 28 73 65 74 ! node). (set 1bd0: 2d 6e 6f 64 65 2d 68 65 69 67 68 74 21 20 6e 6f -node-height! no 1be0: 64 65 20 28 2b 20 28 6d 61 78 20 28 6e 6f 64 65 de (+ (max (node 1bf0: 2d 68 65 69 67 68 74 20 28 6e 6f 64 65 2d 6c 65 -height (node-le 1c00: 66 74 20 6e 6f 64 65 29 29 0a 20 20 20 20 20 20 ft node)). 1c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6e 6f (no 1c30: 64 65 2d 68 65 69 67 68 74 20 28 6e 6f 64 65 2d de-height (node- 1c40: 72 69 67 68 74 20 6e 6f 64 65 29 29 29 0a 20 20 right node))). 1c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1c60: 20 20 20 20 20 20 20 20 20 20 20 20 31 29 29 29 1))) 1c70: 0a 20 20 0a 20 20 28 64 65 66 69 6e 65 20 28 72 . . (define (r 1c80: 6f 74 61 74 65 2d 6c 65 66 74 21 20 61 29 0a 20 otate-left! a). 1c90: 20 20 20 28 6c 65 74 2a 20 28 28 62 20 28 6e 6f (let* ((b (no 1ca0: 64 65 2d 72 69 67 68 74 20 61 29 29 0a 20 20 20 de-right a)). 1cb0: 20 20 20 20 20 20 20 20 28 62 2d 6b 65 79 20 28 (b-key ( 1cc0: 6e 6f 64 65 2d 6b 65 79 20 62 29 29 0a 20 20 20 node-key b)). 1cd0: 20 20 20 20 20 20 20 20 28 62 2d 76 61 6c 75 65 (b-value 1ce0: 20 28 6e 6f 64 65 2d 76 61 6c 75 65 20 62 29 29 (node-value b)) 1cf0: 0a 20 20 20 20 20 20 20 20 20 20 20 28 62 2d 72 . (b-r 1d00: 69 67 68 74 20 28 6e 6f 64 65 2d 72 69 67 68 74 ight (node-right 1d10: 20 62 29 29 29 0a 20 20 20 20 20 20 28 73 65 74 b))). (set 1d20: 2d 6e 6f 64 65 2d 72 69 67 68 74 21 20 62 20 28 -node-right! b ( 1d30: 6e 6f 64 65 2d 6c 65 66 74 20 62 29 29 0a 20 20 node-left b)). 1d40: 20 20 20 20 28 73 65 74 2d 6e 6f 64 65 2d 6c 65 (set-node-le 1d50: 66 74 21 20 62 20 28 6e 6f 64 65 2d 6c 65 66 74 ft! b (node-left 1d60: 20 61 29 29 0a 20 20 20 20 20 20 28 73 65 74 2d a)). (set- 1d70: 6e 6f 64 65 2d 6b 65 79 21 20 62 20 28 6e 6f 64 node-key! b (nod 1d80: 65 2d 6b 65 79 20 61 29 29 0a 20 20 20 20 20 20 e-key a)). 1d90: 28 73 65 74 2d 6e 6f 64 65 2d 76 61 6c 75 65 21 (set-node-value! 1da0: 20 62 20 28 6e 6f 64 65 2d 76 61 6c 75 65 20 61 b (node-value a 1db0: 29 29 0a 20 20 20 20 20 20 28 63 6f 6d 70 75 74 )). (comput 1dc0: 65 2d 68 65 69 67 68 74 21 20 62 29 0a 20 20 20 e-height! b). 1dd0: 20 20 20 28 73 65 74 2d 6e 6f 64 65 2d 6c 65 66 (set-node-lef 1de0: 74 21 20 61 20 62 29 0a 20 20 20 20 20 20 28 73 t! a b). (s 1df0: 65 74 2d 6e 6f 64 65 2d 6b 65 79 21 20 61 20 62 et-node-key! a b 1e00: 2d 6b 65 79 29 0a 20 20 20 20 20 20 28 73 65 74 -key). (set 1e10: 2d 6e 6f 64 65 2d 76 61 6c 75 65 21 20 61 20 62 -node-value! a b 1e20: 2d 76 61 6c 75 65 29 0a 20 20 20 20 20 20 28 73 -value). (s 1e30: 65 74 2d 6e 6f 64 65 2d 72 69 67 68 74 21 20 61 et-node-right! a 1e40: 20 62 2d 72 69 67 68 74 29 0a 20 20 20 20 20 20 b-right). 1e50: 3b 20 28 63 6f 6d 70 75 74 65 2d 68 65 69 67 68 ; (compute-heigh 1e60: 74 21 20 61 29 0a 20 20 20 20 20 20 61 29 29 0a t! a). a)). 1e70: 20 20 0a 20 20 28 64 65 66 69 6e 65 20 28 72 6f . (define (ro 1e80: 74 61 74 65 2d 72 69 67 68 74 21 20 61 29 0a 20 tate-right! a). 1e90: 20 20 20 28 6c 65 74 2a 20 28 28 62 20 28 6e 6f (let* ((b (no 1ea0: 64 65 2d 6c 65 66 74 20 61 29 29 0a 20 20 20 20 de-left a)). 1eb0: 20 20 20 20 20 20 20 28 62 2d 6b 65 79 20 28 6e (b-key (n 1ec0: 6f 64 65 2d 6b 65 79 20 62 29 29 0a 20 20 20 20 ode-key b)). 1ed0: 20 20 20 20 20 20 20 28 62 2d 76 61 6c 75 65 20 (b-value 1ee0: 28 6e 6f 64 65 2d 76 61 6c 75 65 20 62 29 29 0a (node-value b)). 1ef0: 20 20 20 20 20 20 20 20 20 20 20 28 62 2d 6c 65 (b-le 1f00: 66 74 20 28 6e 6f 64 65 2d 6c 65 66 74 20 62 29 ft (node-left b) 1f10: 29 29 0a 20 20 20 20 20 20 28 73 65 74 2d 6e 6f )). (set-no 1f20: 64 65 2d 6c 65 66 74 21 20 62 20 28 6e 6f 64 65 de-left! b (node 1f30: 2d 72 69 67 68 74 20 62 29 29 0a 20 20 20 20 20 -right b)). 1f40: 20 28 73 65 74 2d 6e 6f 64 65 2d 72 69 67 68 74 (set-node-right 1f50: 21 20 62 20 28 6e 6f 64 65 2d 72 69 67 68 74 20 ! b (node-right 1f60: 61 29 29 0a 20 20 20 20 20 20 28 73 65 74 2d 6e a)). (set-n 1f70: 6f 64 65 2d 6b 65 79 21 20 62 20 28 6e 6f 64 65 ode-key! b (node 1f80: 2d 6b 65 79 20 61 29 29 0a 20 20 20 20 20 20 28 -key a)). ( 1f90: 73 65 74 2d 6e 6f 64 65 2d 76 61 6c 75 65 21 20 set-node-value! 1fa0: 62 20 28 6e 6f 64 65 2d 76 61 6c 75 65 20 61 29 b (node-value a) 1fb0: 29 0a 20 20 20 20 20 20 28 63 6f 6d 70 75 74 65 ). (compute 1fc0: 2d 68 65 69 67 68 74 21 20 62 29 0a 20 20 20 20 -height! b). 1fd0: 20 20 28 73 65 74 2d 6e 6f 64 65 2d 72 69 67 68 (set-node-righ 1fe0: 74 21 20 61 20 62 29 0a 20 20 20 20 20 20 28 73 t! a b). (s 1ff0: 65 74 2d 6e 6f 64 65 2d 6b 65 79 21 20 61 20 62 et-node-key! a b 2000: 2d 6b 65 79 29 0a 20 20 20 20 20 20 28 73 65 74 -key). (set 2010: 2d 6e 6f 64 65 2d 76 61 6c 75 65 21 20 61 20 62 -node-value! a b 2020: 2d 76 61 6c 75 65 29 0a 20 20 20 20 20 20 28 73 -value). (s 2030: 65 74 2d 6e 6f 64 65 2d 6c 65 66 74 21 20 61 20 et-node-left! a 2040: 62 2d 6c 65 66 74 29 0a 20 20 20 20 20 20 3b 20 b-left). ; 2050: 28 63 6f 6d 70 75 74 65 2d 68 65 69 67 68 74 21 (compute-height! 2060: 20 61 29 0a 20 20 20 20 20 20 61 29 29 0a 20 20 a). a)). 2070: 0a 20 20 28 64 65 66 69 6e 65 20 28 72 65 62 61 . (define (reba 2080: 6c 61 6e 63 65 2d 6e 6f 64 65 21 20 6e 6f 64 65 lance-node! node 2090: 29 0a 20 20 20 20 28 63 61 73 65 20 28 2d 20 28 ). (case (- ( 20a0: 6e 6f 64 65 2d 68 65 69 67 68 74 20 28 6e 6f 64 node-height (nod 20b0: 65 2d 6c 65 66 74 20 6e 6f 64 65 29 29 20 0a 20 e-left node)) . 20c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6e 6f 64 (nod 20d0: 65 2d 68 65 69 67 68 74 20 28 6e 6f 64 65 2d 72 e-height (node-r 20e0: 69 67 68 74 20 6e 6f 64 65 29 29 29 0a 20 20 20 ight node))). 20f0: 20 20 20 28 28 32 29 20 28 72 6f 74 61 74 65 2d ((2) (rotate- 2100: 72 69 67 68 74 21 20 6e 6f 64 65 29 29 0a 20 20 right! node)). 2110: 20 20 20 20 28 28 2d 32 29 20 28 72 6f 74 61 74 ((-2) (rotat 2120: 65 2d 6c 65 66 74 21 20 6e 6f 64 65 29 29 29 0a e-left! node))). 2130: 20 20 20 20 28 63 6f 6d 70 75 74 65 2d 68 65 69 (compute-hei 2140: 67 68 74 21 20 6e 6f 64 65 29 29 0a 20 20 0a 20 ght! node)). . 2150: 20 28 64 65 66 69 6e 65 20 28 69 6e 73 65 72 74 (define (insert 2160: 21 20 6b 65 79 20 76 61 6c 75 65 20 6e 6f 64 65 ! key value node 2170: 29 0a 20 20 20 20 28 6c 65 74 20 28 28 6f 6c 64 ). (let ((old 2180: 2d 76 61 6c 75 65 0a 20 20 20 20 20 20 20 20 20 -value. 2190: 20 20 28 63 6f 6e 64 20 28 28 6f 72 64 65 72 65 (cond ((ordere 21a0: 64 3f 20 6b 65 79 20 28 6e 6f 64 65 2d 6b 65 79 d? key (node-key 21b0: 20 6e 6f 64 65 29 29 0a 20 20 20 20 20 20 20 20 node)). 21c0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e (if (n 21d0: 6f 64 65 2d 6c 65 66 74 20 6e 6f 64 65 29 0a 20 ode-left node). 21e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 21f0: 20 20 20 20 20 28 69 6e 73 65 72 74 21 20 6b 65 (insert! ke 2200: 79 20 76 61 6c 75 65 20 28 6e 6f 64 65 2d 6c 65 y value (node-le 2210: 66 74 20 6e 6f 64 65 29 29 0a 20 20 20 20 20 20 ft node)). 2220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2230: 28 62 65 67 69 6e 20 0a 20 20 20 20 20 20 20 20 (begin . 2240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 2250: 73 65 74 2d 6e 6f 64 65 2d 6c 65 66 74 21 20 6e set-node-left! n 2260: 6f 64 65 20 28 76 65 63 74 6f 72 20 31 20 23 66 ode (vector 1 #f 2270: 20 6b 65 79 20 76 61 6c 75 65 20 23 66 29 29 0a key value #f)). 2280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2290: 20 20 20 20 20 20 20 23 66 29 29 29 0a 20 20 20 #f))). 22a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 (( 22b0: 6f 72 64 65 72 65 64 3f 20 28 6e 6f 64 65 2d 6b ordered? (node-k 22c0: 65 79 20 6e 6f 64 65 29 20 6b 65 79 29 0a 20 20 ey node) key). 22d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22e0: 28 69 66 20 28 6e 6f 64 65 2d 72 69 67 68 74 20 (if (node-right 22f0: 6e 6f 64 65 29 0a 20 20 20 20 20 20 20 20 20 20 node). 2300: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 6e 73 (ins 2310: 65 72 74 21 20 6b 65 79 20 76 61 6c 75 65 20 28 ert! key value ( 2320: 6e 6f 64 65 2d 72 69 67 68 74 20 6e 6f 64 65 29 node-right node) 2330: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 2340: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 0a (begin . 2350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2360: 20 20 20 20 20 20 20 28 73 65 74 2d 6e 6f 64 65 (set-node 2370: 2d 72 69 67 68 74 21 20 6e 6f 64 65 20 28 76 65 -right! node (ve 2380: 63 74 6f 72 20 31 20 23 66 20 6b 65 79 20 76 61 ctor 1 #f key va 2390: 6c 75 65 20 23 66 29 29 0a 20 20 20 20 20 20 20 lue #f)). 23a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23b0: 23 66 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 #f))). 23c0: 20 20 20 20 20 20 20 28 65 6c 73 65 20 28 6c 65 (else (le 23d0: 74 20 28 28 6f 6c 64 2d 76 61 6c 75 65 20 28 6e t ((old-value (n 23e0: 6f 64 65 2d 76 61 6c 75 65 20 6e 6f 64 65 29 29 ode-value node)) 23f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 2400: 20 20 20 20 20 20 20 20 20 20 20 3b 20 28 73 65 ; (se 2410: 74 2d 6e 6f 64 65 2d 6b 65 79 21 20 6e 6f 64 65 t-node-key! node 2420: 20 6b 65 79 29 0a 20 20 20 20 20 20 20 20 20 20 key). 2430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 2440: 73 65 74 2d 6e 6f 64 65 2d 76 61 6c 75 65 21 20 set-node-value! 2450: 6e 6f 64 65 20 76 61 6c 75 65 29 0a 20 20 20 20 node value). 2460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2470: 20 20 20 20 20 6f 6c 64 2d 76 61 6c 75 65 29 29 old-value)) 2480: 29 29 29 0a 20 20 20 20 20 20 28 72 65 62 61 6c ))). (rebal 2490: 61 6e 63 65 2d 6e 6f 64 65 21 20 6e 6f 64 65 29 ance-node! node) 24a0: 20 20 20 20 20 0a 20 20 20 20 20 20 6f 6c 64 2d . old- 24b0: 76 61 6c 75 65 29 29 0a 20 20 0a 20 20 28 64 65 value)). . (de 24c0: 66 69 6e 65 20 28 75 70 64 61 74 65 21 20 74 72 fine (update! tr 24d0: 65 65 20 6b 65 79 20 75 70 64 61 74 65 2d 66 6e ee key update-fn 24e0: 29 0a 0a 20 20 20 20 28 64 65 66 69 6e 65 20 28 ).. (define ( 24f0: 75 70 64 61 74 65 72 20 6b 65 79 20 75 70 64 61 updater key upda 2500: 74 65 2d 66 6e 20 6e 6f 64 65 29 0a 20 20 20 20 te-fn node). 2510: 20 20 28 63 6f 6e 64 20 28 28 6f 72 64 65 72 65 (cond ((ordere 2520: 64 3f 20 6b 65 79 20 28 6e 6f 64 65 2d 6b 65 79 d? key (node-key 2530: 20 6e 6f 64 65 29 29 0a 20 20 20 20 20 20 20 20 node)). 2540: 20 20 20 20 20 28 69 66 20 28 6e 6f 64 65 2d 6c (if (node-l 2550: 65 66 74 20 6e 6f 64 65 29 0a 20 20 20 20 20 20 eft node). 2560: 20 20 20 20 20 20 20 20 20 28 75 70 64 61 74 65 (update 2570: 72 20 6b 65 79 20 75 70 64 61 74 65 2d 66 6e 20 r key update-fn 2580: 28 6e 6f 64 65 2d 6c 65 66 74 20 6e 6f 64 65 29 (node-left node) 2590: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 25a0: 20 28 73 65 74 2d 6e 6f 64 65 2d 6c 65 66 74 21 (set-node-left! 25b0: 20 6e 6f 64 65 20 28 76 65 63 74 6f 72 20 31 20 node (vector 1 25c0: 23 66 20 6b 65 79 20 28 75 70 64 61 74 65 2d 66 #f key (update-f 25d0: 6e 20 23 66 29 20 23 66 29 29 29 29 0a 20 20 20 n #f) #f)))). 25e0: 20 20 20 20 20 20 20 20 20 28 28 6f 72 64 65 72 ((order 25f0: 65 64 3f 20 28 6e 6f 64 65 2d 6b 65 79 20 6e 6f ed? (node-key no 2600: 64 65 29 20 6b 65 79 29 0a 20 20 20 20 20 20 20 de) key). 2610: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 64 65 2d (if (node- 2620: 72 69 67 68 74 20 6e 6f 64 65 29 0a 20 20 20 20 right node). 2630: 20 20 20 20 20 20 20 20 20 20 20 28 75 70 64 61 (upda 2640: 74 65 72 20 6b 65 79 20 75 70 64 61 74 65 2d 66 ter key update-f 2650: 6e 20 28 6e 6f 64 65 2d 72 69 67 68 74 20 6e 6f n (node-right no 2660: 64 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 de)). 2670: 20 20 20 20 28 73 65 74 2d 6e 6f 64 65 2d 72 69 (set-node-ri 2680: 67 68 74 21 20 6e 6f 64 65 20 28 76 65 63 74 6f ght! node (vecto 2690: 72 20 31 20 23 66 20 6b 65 79 20 28 75 70 64 61 r 1 #f key (upda 26a0: 74 65 2d 66 6e 20 23 66 29 20 23 66 29 29 29 29 te-fn #f) #f)))) 26b0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c . (el 26c0: 73 65 20 28 73 65 74 2d 6e 6f 64 65 2d 76 61 6c se (set-node-val 26d0: 75 65 21 20 6e 6f 64 65 20 28 75 70 64 61 74 65 ue! node (update 26e0: 2d 66 6e 20 28 6e 6f 64 65 2d 76 61 6c 75 65 20 -fn (node-value 26f0: 6e 6f 64 65 29 29 29 29 29 0a 20 20 20 20 20 20 node))))). 2700: 28 72 65 62 61 6c 61 6e 63 65 2d 6e 6f 64 65 21 (rebalance-node! 2710: 20 6e 6f 64 65 29 29 0a 0a 20 20 20 20 28 69 66 node)).. (if 2720: 20 28 65 6d 70 74 79 3f 20 74 72 65 65 29 0a 20 (empty? tree). 2730: 20 20 20 20 20 28 73 65 74 2d 6e 6f 64 65 2d 6b (set-node-k 2740: 65 79 2d 76 61 6c 75 65 21 20 74 72 65 65 20 6b ey-value! tree k 2750: 65 79 20 28 75 70 64 61 74 65 2d 66 6e 20 23 66 ey (update-fn #f 2760: 29 29 0a 20 20 20 20 20 20 28 75 70 64 61 74 65 )). (update 2770: 72 20 6b 65 79 20 75 70 64 61 74 65 2d 66 6e 20 r key update-fn 2780: 74 72 65 65 29 29 29 0a 20 20 0a 20 20 28 64 65 tree))). . (de 2790: 66 69 6e 65 20 28 66 6f 72 65 61 63 68 2d 6e 6f fine (foreach-no 27a0: 64 65 20 66 6e 20 6e 6f 64 65 29 0a 20 20 20 20 de fn node). 27b0: 28 69 66 20 6e 6f 64 65 20 0a 20 20 20 20 20 20 (if node . 27c0: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin. 27d0: 20 20 28 66 6f 72 65 61 63 68 2d 6e 6f 64 65 20 (foreach-node 27e0: 66 6e 20 28 6e 6f 64 65 2d 6c 65 66 74 20 6e 6f fn (node-left no 27f0: 64 65 29 29 0a 20 20 20 20 20 20 20 20 20 28 66 de)). (f 2800: 6e 20 28 6e 6f 64 65 2d 6b 65 79 20 6e 6f 64 65 n (node-key node 2810: 29 20 28 6e 6f 64 65 2d 76 61 6c 75 65 20 6e 6f ) (node-value no 2820: 64 65 29 29 0a 20 20 20 20 20 20 20 20 20 28 66 de)). (f 2830: 6f 72 65 61 63 68 2d 6e 6f 64 65 20 66 6e 20 28 oreach-node fn ( 2840: 6e 6f 64 65 2d 72 69 67 68 74 20 6e 6f 64 65 29 node-right node) 2850: 29 29 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 )))).. (define 2860: 28 6d 61 70 21 2d 6e 6f 64 65 20 66 6e 20 6e 6f (map!-node fn no 2870: 64 65 29 0a 20 20 20 20 28 69 66 20 6e 6f 64 65 de). (if node 2880: 20 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 . (begin. 2890: 20 20 20 20 20 20 20 28 6d 61 70 21 2d 6e 6f 64 (map!-nod 28a0: 65 20 66 6e 20 28 6e 6f 64 65 2d 6c 65 66 74 20 e fn (node-left 28b0: 6e 6f 64 65 29 29 0a 20 20 20 20 20 20 20 20 28 node)). ( 28c0: 73 65 74 2d 6e 6f 64 65 2d 76 61 6c 75 65 21 20 set-node-value! 28d0: 6e 6f 64 65 20 28 66 6e 20 28 6e 6f 64 65 2d 6b node (fn (node-k 28e0: 65 79 20 6e 6f 64 65 29 20 28 6e 6f 64 65 2d 76 ey node) (node-v 28f0: 61 6c 75 65 20 6e 6f 64 65 29 29 29 0a 20 20 20 alue node))). 2900: 20 20 20 20 20 28 6d 61 70 21 2d 6e 6f 64 65 20 (map!-node 2910: 66 6e 20 28 6e 6f 64 65 2d 72 69 67 68 74 20 6e fn (node-right n 2920: 6f 64 65 29 29 29 29 29 0a 0a 20 20 28 64 65 66 ode))))).. (def 2930: 69 6e 65 20 28 72 65 64 75 63 65 2d 6e 6f 64 65 ine (reduce-node 2940: 20 66 6e 20 6e 6f 64 65 20 73 6f 2d 66 61 72 29 fn node so-far) 2950: 0a 20 20 20 20 28 69 66 20 6e 6f 64 65 0a 20 20 . (if node. 2960: 20 20 20 20 20 20 28 72 65 64 75 63 65 2d 6e 6f (reduce-no 2970: 64 65 20 66 6e 20 28 6e 6f 64 65 2d 6c 65 66 74 de fn (node-left 2980: 20 6e 6f 64 65 29 0a 20 20 20 20 20 20 20 20 20 node). 2990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 29a0: 66 6e 20 28 6e 6f 64 65 2d 6b 65 79 20 6e 6f 64 fn (node-key nod 29b0: 65 29 20 28 6e 6f 64 65 2d 76 61 6c 75 65 20 6e e) (node-value n 29c0: 6f 64 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 ode). 29d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29f0: 20 28 72 65 64 75 63 65 2d 6e 6f 64 65 20 66 6e (reduce-node fn 2a00: 20 28 6e 6f 64 65 2d 72 69 67 68 74 20 6e 6f 64 (node-right nod 2a10: 65 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 e) . 2a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2a50: 73 6f 2d 66 61 72 29 29 29 0a 20 20 20 20 20 20 so-far))). 2a60: 20 20 73 6f 2d 66 61 72 29 29 0a 20 20 0a 20 20 so-far)). . 2a70: 28 64 65 66 69 6e 65 20 28 6d 61 70 2d 6e 6f 64 (define (map-nod 2a80: 65 20 66 6e 20 6e 6f 64 65 29 0a 20 20 20 20 28 e fn node). ( 2a90: 69 66 20 28 76 65 63 74 6f 72 3f 20 6e 6f 64 65 if (vector? node 2aa0: 29 0a 20 20 20 20 20 20 20 20 28 76 65 63 74 6f ). (vecto 2ab0: 72 20 28 76 65 63 74 6f 72 2d 72 65 66 20 6e 6f r (vector-ref no 2ac0: 64 65 20 30 29 0a 20 20 20 20 20 20 20 20 20 20 de 0). 2ad0: 20 20 20 20 20 20 28 6d 61 70 2d 6e 6f 64 65 20 (map-node 2ae0: 66 6e 20 28 76 65 63 74 6f 72 2d 72 65 66 20 6e fn (vector-ref n 2af0: 6f 64 65 20 31 29 29 0a 20 20 20 20 20 20 20 20 ode 1)). 2b00: 20 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d (vector- 2b10: 72 65 66 20 6e 6f 64 65 20 32 29 0a 20 20 20 20 ref node 2). 2b20: 20 20 20 20 20 20 20 20 20 20 20 20 28 66 6e 20 (fn 2b30: 28 76 65 63 74 6f 72 2d 72 65 66 20 6e 6f 64 65 (vector-ref node 2b40: 20 32 29 20 28 76 65 63 74 6f 72 2d 72 65 66 20 2) (vector-ref 2b50: 6e 6f 64 65 20 33 29 29 0a 20 20 20 20 20 20 20 node 3)). 2b60: 20 20 20 20 20 20 20 20 20 28 6d 61 70 2d 6e 6f (map-no 2b70: 64 65 20 66 6e 20 28 76 65 63 74 6f 72 2d 72 65 de fn (vector-re 2b80: 66 20 6e 6f 64 65 20 34 29 29 29 0a 20 20 20 20 f node 4))). 2b90: 20 20 20 20 23 66 29 29 0a 20 20 0a 20 20 28 6c #f)). . (l 2ba0: 61 6d 62 64 61 20 28 73 65 6c 65 63 74 6f 72 29 ambda (selector) 2bb0: 20 20 0a 20 20 20 20 28 63 61 73 65 20 73 65 6c . (case sel 2bc0: 65 63 74 6f 72 0a 20 20 20 20 20 20 28 28 6d 61 ector. ((ma 2bd0: 6b 65 29 20 28 6c 61 6d 62 64 61 20 28 29 20 28 ke) (lambda () ( 2be0: 6d 61 6b 65 2d 76 65 63 74 6f 72 20 35 20 23 66 make-vector 5 #f 2bf0: 29 29 29 0a 20 20 20 20 20 20 28 28 6d 61 6b 65 ))). ((make 2c00: 2d 77 69 74 68 2d 76 61 6c 75 65 29 20 28 6c 61 -with-value) (la 2c10: 6d 62 64 61 20 28 6b 65 79 20 76 61 6c 75 65 29 mbda (key value) 2c20: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 2c30: 20 20 20 20 20 20 20 20 20 20 20 28 76 65 63 74 (vect 2c40: 6f 72 20 31 20 23 66 20 6b 65 79 20 76 61 6c 75 or 1 #f key valu 2c50: 65 20 23 66 29 29 29 0a 20 20 20 20 20 20 28 28 e #f))). (( 2c60: 65 6d 70 74 79 3f 29 20 65 6d 70 74 79 3f 29 0a empty?) empty?). 2c70: 20 20 20 20 20 20 28 28 72 65 66 29 20 28 6c 61 ((ref) (la 2c80: 6d 62 64 61 20 28 74 72 65 65 20 6b 65 79 29 0a mbda (tree key). 2c90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 2ca0: 69 66 20 28 65 6d 70 74 79 3f 20 74 72 65 65 29 if (empty? tree) 2cb0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 2cc0: 20 20 23 66 0a 20 20 20 20 20 20 20 20 20 20 20 #f. 2cd0: 20 20 20 20 20 20 28 73 65 61 72 63 68 20 6b 65 (search ke 2ce0: 79 20 74 72 65 65 29 29 29 29 0a 20 20 20 20 20 y tree)))). 2cf0: 20 28 28 73 65 74 21 29 20 28 6c 61 6d 62 64 61 ((set!) (lambda 2d00: 20 28 74 72 65 65 20 6b 65 79 20 76 61 6c 75 65 (tree key value 2d10: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 2d20: 20 20 28 69 66 20 28 65 6d 70 74 79 3f 20 74 72 (if (empty? tr 2d30: 65 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ee). 2d40: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 (begin. 2d50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2d60: 20 28 73 65 74 2d 6e 6f 64 65 2d 6b 65 79 2d 76 (set-node-key-v 2d70: 61 6c 75 65 21 20 74 72 65 65 20 6b 65 79 20 76 alue! tree key v 2d80: 61 6c 75 65 29 0a 20 20 20 20 20 20 20 20 20 20 alue). 2d90: 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 20 20 #f). 2da0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2db0: 28 69 6e 73 65 72 74 21 20 6b 65 79 20 76 61 6c (insert! key val 2dc0: 75 65 20 74 72 65 65 29 29 29 29 0a 20 20 20 20 ue tree)))). 2dd0: 20 20 28 28 66 6f 72 2d 65 61 63 68 29 20 28 6c ((for-each) (l 2de0: 61 6d 62 64 61 20 28 74 72 65 65 20 66 6e 29 20 ambda (tree fn) 2df0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 2e00: 20 20 20 20 28 69 66 20 28 65 6d 70 74 79 3f 20 (if (empty? 2e10: 74 72 65 65 29 0a 20 20 20 20 20 20 20 20 20 20 tree). 2e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 0a #f. 2e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2e40: 20 20 20 20 20 20 20 28 66 6f 72 65 61 63 68 2d (foreach- 2e50: 6e 6f 64 65 20 66 6e 20 74 72 65 65 29 29 29 29 node fn tree)))) 2e60: 0a 20 20 20 20 20 20 28 28 6d 61 70 29 20 28 6c . ((map) (l 2e70: 61 6d 62 64 61 20 28 74 72 65 65 20 66 6e 29 0a ambda (tree fn). 2e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 2e90: 69 66 20 28 65 6d 70 74 79 3f 20 74 72 65 65 29 if (empty? tree) 2ea0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 2eb0: 20 20 20 20 28 6d 61 6b 65 2d 76 65 63 74 6f 72 (make-vector 2ec0: 20 35 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 5 #f). 2ed0: 20 20 20 20 20 20 20 20 20 20 28 6d 61 70 2d 6e (map-n 2ee0: 6f 64 65 20 66 6e 20 74 72 65 65 29 29 29 29 0a ode fn tree)))). 2ef0: 20 20 20 20 20 20 28 28 6d 61 70 21 29 20 28 6c ((map!) (l 2f00: 61 6d 62 64 61 20 28 74 72 65 65 20 66 6e 29 20 ambda (tree fn) 2f10: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 2f20: 20 28 69 66 20 28 65 6d 70 74 79 3f 20 74 72 65 (if (empty? tre 2f30: 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e). 2f40: 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 20 20 #f. 2f50: 20 20 20 20 20 20 20 20 20 20 28 6d 61 70 21 2d (map!- 2f60: 6e 6f 64 65 20 66 6e 20 74 72 65 65 29 29 0a 20 node fn tree)). 2f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 74 t 2f80: 72 65 65 29 29 0a 20 20 20 20 20 20 28 28 72 65 ree)). ((re 2f90: 64 75 63 65 29 20 28 6c 61 6d 62 64 61 20 28 74 duce) (lambda (t 2fa0: 72 65 65 20 66 6e 20 73 74 61 72 74 29 20 0a 20 ree fn start) . 2fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2fc0: 20 28 69 66 20 28 65 6d 70 74 79 3f 20 74 72 65 (if (empty? tre 2fd0: 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e). 2fe0: 20 20 20 20 20 20 20 20 20 73 74 61 72 74 0a 20 start. 2ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3000: 20 20 20 20 20 28 72 65 64 75 63 65 2d 6e 6f 64 (reduce-nod 3010: 65 20 66 6e 20 74 72 65 65 20 73 74 61 72 74 29 e fn tree start) 3020: 29 29 29 0a 20 20 20 20 20 20 28 28 75 70 64 61 ))). ((upda 3030: 74 65 21 29 20 75 70 64 61 74 65 21 29 0a 20 20 te!) update!). 3040: 20 20 20 20 28 28 69 6e 63 21 29 20 28 61 73 73 ((inc!) (ass 3050: 6f 63 3a 69 6e 63 21 2d 6d 61 6b 65 72 20 75 70 oc:inc!-maker up 3060: 64 61 74 65 21 29 29 0a 20 20 20 20 20 20 28 28 date!)). (( 3070: 70 75 73 68 21 29 20 28 61 73 73 6f 63 3a 70 75 push!) (assoc:pu 3080: 73 68 21 2d 6d 61 6b 65 72 20 75 70 64 61 74 65 sh!-maker update 3090: 21 29 29 0a 20 20 20 20 20 20 28 65 6c 73 65 20 !)). (else 30a0: 28 65 72 72 6f 72 20 22 55 6e 69 6d 70 6c 65 6d (error "Unimplem 30b0: 65 6e 74 65 64 20 73 65 6c 65 63 74 6f 72 3a 20 ented selector: 30c0: 22 20 73 65 6c 65 63 74 6f 72 29 29 29 29 29 0a " selector))))). 30d0: 0a 28 64 65 66 69 6e 65 20 28 74 72 69 65 2d 6d .(define (trie-m 30e0: 61 6b 65 72 20 61 73 73 6f 63 69 61 74 6f 72 2d aker associator- 30f0: 6d 61 6b 65 72 29 0a 20 20 28 6c 65 74 20 28 28 maker). (let (( 3100: 61 73 73 6f 63 2d 6e 65 77 20 28 61 73 73 6f 63 assoc-new (assoc 3110: 69 61 74 6f 72 2d 6d 61 6b 65 72 20 27 6d 61 6b iator-maker 'mak 3120: 65 29 29 0a 20 20 20 20 20 20 20 20 28 61 73 73 e)). (ass 3130: 6f 63 2d 75 70 64 61 74 65 21 20 28 61 73 73 6f oc-update! (asso 3140: 63 69 61 74 6f 72 2d 6d 61 6b 65 72 20 27 75 70 ciator-maker 'up 3150: 64 61 74 65 21 29 29 0a 20 20 20 20 20 20 20 20 date!)). 3160: 28 61 73 73 6f 63 2d 69 6e 73 65 72 74 21 20 28 (assoc-insert! ( 3170: 61 73 73 6f 63 69 61 74 6f 72 2d 6d 61 6b 65 72 associator-maker 3180: 20 27 73 65 74 21 29 29 0a 20 20 20 20 20 20 20 'set!)). 3190: 20 28 61 73 73 6f 63 2d 6c 6f 6f 6b 75 70 20 28 (assoc-lookup ( 31a0: 61 73 73 6f 63 69 61 74 6f 72 2d 6d 61 6b 65 72 associator-maker 31b0: 20 27 72 65 66 29 29 0a 20 20 20 20 20 20 20 20 'ref)). 31c0: 28 61 73 73 6f 63 2d 6d 61 70 20 28 61 73 73 6f (assoc-map (asso 31d0: 63 69 61 74 6f 72 2d 6d 61 6b 65 72 20 27 6d 61 ciator-maker 'ma 31e0: 70 29 29 0a 20 20 20 20 20 20 20 20 28 61 73 73 p)). (ass 31f0: 6f 63 2d 6d 61 70 21 20 28 61 73 73 6f 63 69 61 oc-map! (associa 3200: 74 6f 72 2d 6d 61 6b 65 72 20 27 6d 61 70 21 29 tor-maker 'map!) 3210: 29 0a 20 20 20 20 20 20 20 20 28 61 73 73 6f 63 ). (assoc 3220: 2d 72 65 64 75 63 65 20 28 61 73 73 6f 63 69 61 -reduce (associa 3230: 74 6f 72 2d 6d 61 6b 65 72 20 27 72 65 64 75 63 tor-maker 'reduc 3240: 65 29 29 0a 20 20 20 20 20 20 20 20 28 61 73 73 e)). (ass 3250: 6f 63 2d 66 6f 72 65 61 63 68 20 28 61 73 73 6f oc-foreach (asso 3260: 63 69 61 74 6f 72 2d 6d 61 6b 65 72 20 27 66 6f ciator-maker 'fo 3270: 72 2d 65 61 63 68 29 29 29 0a 20 20 20 20 28 64 r-each))). (d 3280: 65 66 69 6e 65 20 28 73 65 61 72 63 68 20 74 72 efine (search tr 3290: 69 65 20 6b 65 79 73 29 0a 20 20 20 20 20 20 28 ie keys). ( 32a0: 69 66 20 74 72 69 65 0a 20 20 20 20 20 20 20 20 if trie. 32b0: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6b 65 79 (if (null? key 32c0: 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 s). 32d0: 20 28 63 61 72 20 74 72 69 65 29 0a 20 20 20 20 (car trie). 32e0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e (if (n 32f0: 6f 74 20 28 6e 75 6c 6c 3f 20 28 63 64 72 20 74 ot (null? (cdr t 3300: 72 69 65 29 29 29 0a 20 20 20 20 20 20 20 20 20 rie))). 3310: 20 20 20 20 20 20 20 20 20 28 73 65 61 72 63 68 (search 3320: 20 28 61 73 73 6f 63 2d 6c 6f 6f 6b 75 70 20 28 (assoc-lookup ( 3330: 63 64 72 20 74 72 69 65 29 20 28 63 61 72 20 6b cdr trie) (car k 3340: 65 79 73 29 29 20 28 63 64 72 20 6b 65 79 73 29 eys)) (cdr keys) 3350: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 3360: 20 20 20 20 23 66 29 29 0a 20 20 20 20 20 20 20 #f)). 3370: 20 20 20 23 66 29 29 0a 20 20 20 20 28 64 65 66 #f)). (def 3380: 69 6e 65 20 28 61 73 73 6f 63 2d 6e 65 77 2d 76 ine (assoc-new-v 3390: 61 6c 75 65 20 6b 65 79 20 76 61 6c 75 65 29 0a alue key value). 33a0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 61 20 28 (let ((a ( 33b0: 61 73 73 6f 63 2d 6e 65 77 29 29 29 0a 20 20 20 assoc-new))). 33c0: 20 20 20 20 20 28 61 73 73 6f 63 2d 69 6e 73 65 (assoc-inse 33d0: 72 74 21 20 61 20 6b 65 79 20 76 61 6c 75 65 29 rt! a key value) 33e0: 0a 20 20 20 20 20 20 20 20 61 29 29 0a 20 20 20 . a)). 33f0: 20 28 64 65 66 69 6e 65 20 28 6e 65 77 2d 70 61 (define (new-pa 3400: 74 68 20 6b 65 79 73 20 76 61 6c 75 65 29 0a 20 th keys value). 3410: 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 (if (null? 3420: 6b 65 79 73 29 0a 20 20 20 20 20 20 20 20 20 20 keys). 3430: 28 6c 69 73 74 20 76 61 6c 75 65 29 0a 20 20 20 (list value). 3440: 20 20 20 20 20 20 20 28 63 6f 6e 73 20 23 66 20 (cons #f 3450: 28 61 73 73 6f 63 2d 6e 65 77 2d 76 61 6c 75 65 (assoc-new-value 3460: 20 28 63 61 72 20 6b 65 79 73 29 20 28 6e 65 77 (car keys) (new 3470: 2d 70 61 74 68 20 28 63 64 72 20 6b 65 79 73 29 -path (cdr keys) 3480: 20 76 61 6c 75 65 29 29 29 29 29 0a 20 20 20 20 value))))). 3490: 28 64 65 66 69 6e 65 20 28 69 6e 73 65 72 74 21 (define (insert! 34a0: 20 74 72 69 65 20 6b 65 79 73 20 76 61 6c 75 65 trie keys value 34b0: 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 6f ). (let ((o 34c0: 6c 64 2d 76 61 6c 75 65 20 23 66 29 29 0a 20 20 ld-value #f)). 34d0: 20 20 20 20 20 20 28 64 65 66 69 6e 65 20 28 69 (define (i 34e0: 6e 73 65 72 74 65 72 20 6b 65 79 73 20 74 72 69 nserter keys tri 34f0: 65 29 0a 20 20 20 20 20 20 20 20 20 20 28 63 6f e). (co 3500: 6e 64 20 28 28 6e 75 6c 6c 3f 20 6b 65 79 73 29 nd ((null? keys) 3510: 20 28 73 65 74 21 20 6f 6c 64 2d 76 61 6c 75 65 (set! old-value 3520: 20 28 63 61 72 20 74 72 69 65 29 29 20 28 73 65 (car trie)) (se 3530: 74 2d 63 61 72 21 20 74 72 69 65 20 76 61 6c 75 t-car! trie valu 3540: 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 e)). 3550: 20 20 20 20 28 28 6e 75 6c 6c 3f 20 28 63 64 72 ((null? (cdr 3560: 20 74 72 69 65 29 29 0a 20 20 20 20 20 20 20 20 trie)). 3570: 20 20 20 20 20 20 20 20 20 28 73 65 74 2d 63 64 (set-cd 3580: 72 21 20 74 72 69 65 20 28 61 73 73 6f 63 2d 6e r! trie (assoc-n 3590: 65 77 2d 76 61 6c 75 65 20 28 63 61 72 20 6b 65 ew-value (car ke 35a0: 79 73 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 ys) . 35b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 35c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 35d0: 20 20 20 20 20 20 28 6e 65 77 2d 70 61 74 68 20 (new-path 35e0: 28 63 64 72 20 6b 65 79 73 29 20 76 61 6c 75 65 (cdr keys) value 35f0: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))). 3600: 20 20 20 20 20 28 65 6c 73 65 20 28 61 73 73 6f (else (asso 3610: 63 2d 75 70 64 61 74 65 21 20 28 63 64 72 20 74 c-update! (cdr t 3620: 72 69 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 rie). 3630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3640: 20 20 20 20 20 20 20 20 20 20 28 63 61 72 20 6b (car k 3650: 65 79 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 eys). 3660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3670: 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 (lambd 3680: 61 20 28 73 75 62 2d 74 72 69 65 29 0a 20 20 20 a (sub-trie). 3690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 36a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 36b0: 20 20 20 20 28 69 66 20 73 75 62 2d 74 72 69 65 (if sub-trie 36c0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 36d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 36e0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 6e 73 (ins 36f0: 65 72 74 65 72 20 28 63 64 72 20 6b 65 79 73 29 erter (cdr keys) 3700: 20 73 75 62 2d 74 72 69 65 29 0a 20 20 20 20 20 sub-trie). 3710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3730: 20 20 20 20 20 20 28 6e 65 77 2d 70 61 74 68 20 (new-path 3740: 28 63 64 72 20 6b 65 79 73 29 20 76 61 6c 75 65 (cdr keys) value 3750: 29 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 )))))). 3760: 20 74 72 69 65 29 0a 20 20 20 20 20 20 20 20 28 trie). ( 3770: 69 6e 73 65 72 74 65 72 20 6b 65 79 73 20 74 72 inserter keys tr 3780: 69 65 29 0a 20 20 20 20 20 20 20 20 6f 6c 64 2d ie). old- 3790: 76 61 6c 75 65 29 29 0a 20 20 20 20 28 64 65 66 value)). (def 37a0: 69 6e 65 20 28 75 70 64 61 74 65 21 20 74 72 69 ine (update! tri 37b0: 65 20 6b 65 79 73 20 75 70 64 61 74 65 2d 66 6e e keys update-fn 37c0: 29 0a 20 20 20 20 20 20 28 64 65 66 69 6e 65 20 ). (define 37d0: 28 75 70 64 61 74 65 72 20 6b 65 79 73 20 74 72 (updater keys tr 37e0: 69 65 29 0a 20 20 20 20 20 20 20 20 28 63 6f 6e ie). (con 37f0: 64 20 28 28 6e 75 6c 6c 3f 20 74 72 69 65 29 20 d ((null? trie) 3800: 28 6e 65 77 2d 70 61 74 68 20 6b 65 79 73 20 28 (new-path keys ( 3810: 75 70 64 61 74 65 2d 66 6e 20 23 66 29 29 29 0a update-fn #f))). 3820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 (( 3830: 6e 75 6c 6c 3f 20 6b 65 79 73 29 20 28 73 65 74 null? keys) (set 3840: 2d 63 61 72 21 20 74 72 69 65 20 28 75 70 64 61 -car! trie (upda 3850: 74 65 2d 66 6e 20 28 63 61 72 20 74 72 69 65 29 te-fn (car trie) 3860: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))). 3870: 20 20 28 28 6e 75 6c 6c 3f 20 28 63 64 72 20 74 ((null? (cdr t 3880: 72 69 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 rie)). 3890: 20 20 20 20 20 28 73 65 74 2d 63 64 72 21 20 74 (set-cdr! t 38a0: 72 69 65 20 28 61 73 73 6f 63 2d 6e 65 77 2d 76 rie (assoc-new-v 38b0: 61 6c 75 65 20 28 63 61 72 20 6b 65 79 73 29 20 alue (car keys) 38c0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 38d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 38e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 38f0: 28 6e 65 77 2d 70 61 74 68 20 28 63 64 72 20 6b (new-path (cdr k 3900: 65 79 73 29 20 0a 20 20 20 20 20 20 20 20 20 20 eys) . 3910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 3940: 75 70 64 61 74 65 2d 66 6e 20 23 66 29 29 29 29 update-fn #f)))) 3950: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 3960: 28 65 6c 73 65 20 28 61 73 73 6f 63 2d 75 70 64 (else (assoc-upd 3970: 61 74 65 21 20 28 63 64 72 20 74 72 69 65 29 0a ate! (cdr trie). 3980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 39a0: 20 20 20 28 63 61 72 20 6b 65 79 73 29 0a 20 20 (car keys). 39b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 39c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 39d0: 20 28 6c 61 6d 62 64 61 20 28 73 75 62 2d 74 72 (lambda (sub-tr 39e0: 69 65 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 ie) . 39f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3a00: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 73 75 (if su 3a10: 62 2d 74 72 69 65 0a 20 20 20 20 20 20 20 20 20 b-trie. 3a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 75 (u 3a40: 70 64 61 74 65 72 20 28 63 64 72 20 6b 65 79 73 pdater (cdr keys 3a50: 29 20 73 75 62 2d 74 72 69 65 29 0a 20 20 20 20 ) sub-trie). 3a60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3a80: 20 20 20 28 6e 65 77 2d 70 61 74 68 20 28 63 64 (new-path (cd 3a90: 72 20 6b 65 79 73 29 20 28 75 70 64 61 74 65 2d r keys) (update- 3aa0: 66 6e 20 23 66 29 29 29 29 29 29 29 0a 20 20 20 fn #f))))))). 3ab0: 20 20 20 20 20 74 72 69 65 29 0a 20 20 20 20 20 trie). 3ac0: 20 28 75 70 64 61 74 65 72 20 6b 65 79 73 20 74 (updater keys t 3ad0: 72 69 65 29 29 0a 20 20 20 20 28 64 65 66 69 6e rie)). (defin 3ae0: 65 20 28 72 65 64 75 63 65 2d 74 72 69 65 20 66 e (reduce-trie f 3af0: 6e 20 6b 65 79 73 20 74 72 69 65 20 73 6f 2d 66 n keys trie so-f 3b00: 61 72 30 29 0a 20 20 20 20 20 20 28 69 66 20 28 ar0). (if ( 3b10: 70 61 69 72 3f 20 74 72 69 65 29 0a 20 20 20 20 pair? trie). 3b20: 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 6f 2d (let ((so- 3b30: 66 61 72 31 20 28 69 66 20 28 63 61 72 20 74 72 far1 (if (car tr 3b40: 69 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ie). 3b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b60: 20 28 66 6e 20 28 72 65 76 65 72 73 65 20 6b 65 (fn (reverse ke 3b70: 79 73 29 20 28 63 61 72 20 74 72 69 65 29 20 73 ys) (car trie) s 3b80: 6f 2d 66 61 72 30 29 0a 20 20 20 20 20 20 20 20 o-far0). 3b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3ba0: 20 20 20 20 20 73 6f 2d 66 61 72 30 29 29 29 0a so-far0))). 3bb0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if 3bc0: 28 6e 75 6c 6c 3f 20 28 63 64 72 20 74 72 69 65 (null? (cdr trie 3bd0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )). 3be0: 20 20 20 73 6f 2d 66 61 72 31 0a 20 20 20 20 20 so-far1. 3bf0: 20 20 20 20 20 20 20 20 20 20 20 28 61 73 73 6f (asso 3c00: 63 2d 72 65 64 75 63 65 20 28 63 64 72 20 74 72 c-reduce (cdr tr 3c10: 69 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ie). 3c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3c30: 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 20 6e (lambda (key n 3c40: 65 77 2d 74 72 69 65 20 73 6f 2d 66 61 72 32 29 ew-trie so-far2) 3c50: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 3c60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3c70: 20 28 72 65 64 75 63 65 2d 74 72 69 65 20 66 6e (reduce-trie fn 3c80: 20 28 63 6f 6e 73 20 6b 65 79 20 6b 65 79 73 29 (cons key keys) 3c90: 20 6e 65 77 2d 74 72 69 65 20 0a 20 20 20 20 20 new-trie . 3ca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3cc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3cd0: 20 20 20 20 20 20 20 20 20 20 20 73 6f 2d 66 61 so-fa 3ce0: 72 32 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 r2)). 3cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3d00: 20 20 20 73 6f 2d 66 61 72 31 29 29 29 0a 20 20 so-far1))). 3d10: 20 20 20 20 20 20 20 20 73 6f 2d 66 61 72 30 29 so-far0) 3d20: 29 0a 20 20 20 20 28 64 65 66 69 6e 65 20 28 66 ). (define (f 3d30: 6f 72 65 61 63 68 2d 74 72 69 65 20 66 6e 20 6b oreach-trie fn k 3d40: 65 79 73 20 74 72 69 65 29 0a 20 20 20 20 20 20 eys trie). 3d50: 28 69 66 20 28 70 61 69 72 3f 20 74 72 69 65 29 (if (pair? trie) 3d60: 0a 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 . (begi 3d70: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 28 69 66 n. (if 3d80: 20 28 63 61 72 20 74 72 69 65 29 20 0a 20 20 20 (car trie) . 3d90: 20 20 20 20 20 20 20 20 20 20 20 20 28 66 6e 20 (fn 3da0: 28 72 65 76 65 72 73 65 20 6b 65 79 73 29 20 28 (reverse keys) ( 3db0: 63 61 72 20 74 72 69 65 29 29 29 0a 20 20 20 20 car trie))). 3dc0: 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 (if (not 3dd0: 28 6e 75 6c 6c 3f 20 28 63 64 72 20 74 72 69 65 (null? (cdr trie 3de0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))). 3df0: 20 20 20 28 61 73 73 6f 63 2d 66 6f 72 65 61 63 (assoc-foreac 3e00: 68 20 28 63 64 72 20 74 72 69 65 29 0a 20 20 20 h (cdr trie). 3e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3e20: 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 (lamb 3e30: 64 61 20 28 6b 65 79 20 6e 65 77 2d 74 72 69 65 da (key new-trie 3e40: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 3e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3e60: 20 20 28 66 6f 72 65 61 63 68 2d 74 72 69 65 20 (foreach-trie 3e70: 66 6e 20 28 63 6f 6e 73 20 6b 65 79 20 6b 65 79 fn (cons key key 3e80: 73 29 20 6e 65 77 2d 74 72 69 65 29 29 29 29 29 s) new-trie))))) 3e90: 29 29 0a 20 20 20 20 28 64 65 66 69 6e 65 20 28 )). (define ( 3ea0: 6d 61 70 21 2d 74 72 69 65 20 66 6e 20 6b 65 79 map!-trie fn key 3eb0: 73 20 74 72 69 65 29 0a 20 20 20 20 20 20 28 69 s trie). (i 3ec0: 66 20 28 70 61 69 72 3f 20 74 72 69 65 29 0a 20 f (pair? trie). 3ed0: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin. 3ee0: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if ( 3ef0: 63 61 72 20 74 72 69 65 29 20 0a 20 20 20 20 20 car trie) . 3f00: 20 20 20 20 20 20 20 20 20 20 28 73 65 74 2d 63 (set-c 3f10: 61 72 21 20 74 72 69 65 20 28 66 6e 20 28 72 65 ar! trie (fn (re 3f20: 76 65 72 73 65 20 6b 65 79 73 29 20 28 63 61 72 verse keys) (car 3f30: 20 74 72 69 65 29 29 29 29 0a 20 20 20 20 20 20 trie)))). 3f40: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e (if (not (n 3f50: 75 6c 6c 3f 20 28 63 64 72 20 74 72 69 65 29 29 ull? (cdr trie)) 3f60: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 3f70: 20 28 61 73 73 6f 63 2d 66 6f 72 65 61 63 68 20 (assoc-foreach 3f80: 28 63 64 72 20 74 72 69 65 29 0a 20 20 20 20 20 (cdr trie). 3f90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3fa0: 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 (lambda 3fb0: 20 28 6b 65 79 20 6e 65 77 2d 74 72 69 65 29 0a (key new-trie). 3fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3fe0: 28 6d 61 70 21 2d 74 72 69 65 20 66 6e 20 28 63 (map!-trie fn (c 3ff0: 6f 6e 73 20 6b 65 79 20 6b 65 79 73 29 20 6e 65 ons key keys) ne 4000: 77 2d 74 72 69 65 29 29 29 29 29 29 29 0a 20 20 w-trie))))))). 4010: 20 20 28 64 65 66 69 6e 65 20 28 6d 61 70 2d 74 (define (map-t 4020: 72 69 65 20 66 6e 20 6b 65 79 73 20 74 72 69 65 rie fn keys trie 4030: 29 0a 20 20 20 20 20 20 28 69 66 20 74 72 69 65 ). (if trie 4040: 0a 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 . (cons 4050: 20 28 69 66 20 28 63 61 72 20 74 72 69 65 29 0a (if (car trie). 4060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4070: 20 20 20 20 28 66 6e 20 28 72 65 76 65 72 73 65 (fn (reverse 4080: 20 6b 65 79 73 29 20 28 63 61 72 20 74 72 69 65 keys) (car trie 4090: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )). 40a0: 20 20 20 20 20 20 20 23 66 29 0a 20 20 20 20 20 #f). 40b0: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if ( 40c0: 6e 75 6c 6c 3f 20 28 63 64 72 20 74 72 69 65 29 null? (cdr trie) 40d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 40e0: 20 20 20 20 20 20 27 28 29 0a 20 20 20 20 20 20 '(). 40f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 (a 4100: 73 73 6f 63 2d 6d 61 70 20 28 63 64 72 20 74 72 ssoc-map (cdr tr 4110: 69 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ie). 4120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4130: 20 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 20 (lambda (key 4140: 6e 65 77 2d 74 72 69 65 29 0a 20 20 20 20 20 20 new-trie). 4150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4160: 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 70 2d (map- 4170: 74 72 69 65 20 66 6e 20 28 63 6f 6e 73 20 6b 65 trie fn (cons ke 4180: 79 20 6b 65 79 73 29 20 6e 65 77 2d 74 72 69 65 y keys) new-trie 4190: 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 ))))). 41a0: 23 66 29 29 0a 20 20 20 20 0a 20 20 20 20 28 6c #f)). . (l 41b0: 61 6d 62 64 61 20 28 73 65 6c 65 63 74 6f 72 29 ambda (selector) 41c0: 0a 20 20 20 20 20 20 28 63 61 73 65 20 73 65 6c . (case sel 41d0: 65 63 74 6f 72 0a 20 20 20 20 20 20 20 20 28 28 ector. (( 41e0: 6d 61 6b 65 29 20 28 6c 61 6d 62 64 61 20 28 29 make) (lambda () 41f0: 20 28 6c 69 73 74 20 23 66 29 29 29 0a 20 20 20 (list #f))). 4200: 20 20 20 20 20 28 28 72 65 66 29 20 73 65 61 72 ((ref) sear 4210: 63 68 29 0a 20 20 20 20 20 20 20 20 28 28 73 65 ch). ((se 4220: 74 21 29 20 69 6e 73 65 72 74 21 29 0a 20 20 20 t!) insert!). 4230: 20 20 20 20 20 28 28 6d 61 70 29 20 28 6c 61 6d ((map) (lam 4240: 62 64 61 20 28 74 72 69 65 20 66 6e 29 20 28 6d bda (trie fn) (m 4250: 61 70 2d 74 72 69 65 20 66 6e 20 27 28 29 20 74 ap-trie fn '() t 4260: 72 69 65 29 29 29 0a 20 20 20 20 20 20 20 20 28 rie))). ( 4270: 28 75 70 64 61 74 65 21 29 20 75 70 64 61 74 65 (update!) update 4280: 21 29 0a 20 20 20 20 20 20 20 20 28 28 72 65 64 !). ((red 4290: 75 63 65 29 20 28 6c 61 6d 62 64 61 20 28 74 72 uce) (lambda (tr 42a0: 69 65 20 66 6e 20 73 74 61 72 74 29 20 28 72 65 ie fn start) (re 42b0: 64 75 63 65 2d 74 72 69 65 20 66 6e 20 27 28 29 duce-trie fn '() 42c0: 20 74 72 69 65 20 73 74 61 72 74 29 29 29 0a 20 trie start))). 42d0: 20 20 20 20 20 20 20 28 28 66 6f 72 2d 65 61 63 ((for-eac 42e0: 68 29 20 28 6c 61 6d 62 64 61 20 28 74 72 69 65 h) (lambda (trie 42f0: 20 66 6e 29 20 28 66 6f 72 65 61 63 68 2d 74 72 fn) (foreach-tr 4300: 69 65 20 66 6e 20 27 28 29 20 74 72 69 65 29 20 ie fn '() trie) 4310: 74 72 69 65 29 29 0a 20 20 20 20 20 20 20 20 28 trie)). ( 4320: 28 6d 61 70 21 29 20 28 6c 61 6d 62 64 61 20 28 (map!) (lambda ( 4330: 74 72 69 65 20 66 6e 29 20 28 6d 61 70 21 2d 74 trie fn) (map!-t 4340: 72 69 65 20 66 6e 20 27 28 29 20 74 72 69 65 29 rie fn '() trie) 4350: 20 74 72 69 65 29 29 0a 20 20 20 20 20 20 20 20 trie)). 4360: 28 28 69 6e 63 21 29 20 28 61 73 73 6f 63 3a 69 ((inc!) (assoc:i 4370: 6e 63 21 2d 6d 61 6b 65 72 20 75 70 64 61 74 65 nc!-maker update 4380: 21 29 29 0a 20 20 20 20 20 20 20 20 28 28 70 75 !)). ((pu 4390: 73 68 21 29 20 28 61 73 73 6f 63 3a 70 75 73 68 sh!) (assoc:push 43a0: 21 2d 6d 61 6b 65 72 20 75 70 64 61 74 65 21 29 !-maker update!) 43b0: 29 0a 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 ). (else 43c0: 28 65 72 72 6f 72 20 22 55 6e 69 6d 70 6c 65 6d (error "Unimplem 43d0: 65 6e 74 65 64 20 73 65 6c 65 63 74 6f 72 3a 20 ented selector: 43e0: 22 20 73 65 6c 65 63 74 6f 72 29 29 29 29 29 29 " selector)))))) 43f0: 0a 0a 28 64 65 66 69 6e 65 20 28 76 65 63 74 6f ..(define (vecto 4400: 72 2d 61 73 73 6f 63 69 61 74 6f 72 20 73 69 7a r-associator siz 4410: 65 20 66 69 6c 6c 29 0a 20 20 28 6c 61 6d 62 64 e fill). (lambd 4420: 61 20 28 73 65 6c 65 63 74 6f 72 29 0a 20 20 20 a (selector). 4430: 20 28 63 61 73 65 20 73 65 6c 65 63 74 6f 72 0a (case selector. 4440: 20 20 20 20 20 20 28 28 6d 61 6b 65 29 20 28 6c ((make) (l 4450: 61 6d 62 64 61 20 28 29 20 28 6d 61 6b 65 2d 76 ambda () (make-v 4460: 65 63 74 6f 72 20 73 69 7a 65 20 66 69 6c 6c 29 ector size fill) 4470: 29 29 0a 20 20 20 20 20 20 28 28 72 65 66 29 20 )). ((ref) 4480: 76 65 63 74 6f 72 2d 72 65 66 29 0a 20 20 20 20 vector-ref). 4490: 20 20 28 28 73 65 74 21 29 20 28 6c 61 6d 62 64 ((set!) (lambd 44a0: 61 20 28 76 65 63 20 69 20 76 29 0a 20 20 20 20 a (vec i v). 44b0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let 44c0: 20 28 28 6f 6c 64 2d 76 61 6c 75 65 20 28 76 65 ((old-value (ve 44d0: 63 74 6f 72 2d 72 65 66 20 76 65 63 20 69 29 29 ctor-ref vec i)) 44e0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 44f0: 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 (vector-set! 4500: 20 76 65 63 20 69 20 76 29 0a 20 20 20 20 20 20 vec i v). 4510: 20 20 20 20 20 20 20 20 20 20 20 20 6f 6c 64 2d old- 4520: 76 61 6c 75 65 29 29 29 0a 20 20 20 20 20 20 28 value))). ( 4530: 28 6d 61 70 29 20 28 6c 61 6d 62 64 61 20 28 6f (map) (lambda (o 4540: 6c 64 2d 76 65 63 20 66 6e 29 0a 20 20 20 20 20 ld-vec fn). 4550: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let ( 4560: 28 6e 65 77 2d 76 65 63 20 28 6d 61 6b 65 2d 76 (new-vec (make-v 4570: 65 63 74 6f 72 20 73 69 7a 65 29 29 29 0a 20 20 ector size))). 4580: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 4590: 64 6f 20 28 28 69 20 28 2d 20 73 69 7a 65 20 31 do ((i (- size 1 45a0: 29 20 28 2d 20 69 20 31 29 29 29 0a 20 20 20 20 ) (- i 1))). 45b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 45c0: 20 28 28 6e 65 67 61 74 69 76 65 3f 20 69 29 20 ((negative? i) 45d0: 6e 65 77 2d 76 65 63 29 0a 20 20 20 20 20 20 20 new-vec). 45e0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let 45f0: 20 28 28 76 20 28 76 65 63 74 6f 72 2d 72 65 66 ((v (vector-ref 4600: 20 6f 6c 64 2d 76 65 63 20 69 29 29 29 0a 20 20 old-vec i))). 4610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4620: 20 20 20 28 69 66 20 76 0a 20 20 20 20 20 20 20 (if v. 4630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4640: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 6e 65 77 (vector-set! new 4650: 2d 76 65 63 20 69 20 28 66 6e 20 69 20 76 29 29 -vec i (fn i v)) 4660: 29 29 29 29 29 29 0a 20 20 20 20 20 20 28 28 75 )))))). ((u 4670: 70 64 61 74 65 21 29 20 28 6c 61 6d 62 64 61 20 pdate!) (lambda 4680: 28 76 65 63 20 69 20 66 29 0a 20 20 20 20 20 20 (vec i f). 4690: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 76 65 (ve 46a0: 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 69 20 ctor-set! vec i 46b0: 28 66 20 28 76 65 63 74 6f 72 2d 72 65 66 20 76 (f (vector-ref v 46c0: 65 63 20 69 29 29 29 29 29 0a 20 20 20 20 20 20 ec i))))). 46d0: 28 28 72 65 64 75 63 65 29 20 28 6c 61 6d 62 64 ((reduce) (lambd 46e0: 61 20 28 76 65 63 20 66 20 74 68 72 65 61 64 29 a (vec f thread) 46f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 4700: 20 20 20 28 64 65 66 69 6e 65 20 28 72 65 64 75 (define (redu 4710: 63 65 20 69 20 74 68 72 65 61 64 29 0a 20 20 20 ce i thread). 4720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4730: 20 28 69 66 20 28 6e 65 67 61 74 69 76 65 3f 20 (if (negative? 4740: 69 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 i). 4750: 20 20 20 20 20 20 20 20 20 74 68 72 65 61 64 0a thread. 4760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4770: 20 20 20 20 20 20 28 72 65 64 75 63 65 20 28 2d (reduce (- 4780: 20 69 20 31 29 20 0a 20 20 20 20 20 20 20 20 20 i 1) . 4790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 47a0: 20 20 20 20 20 28 6c 65 74 20 28 28 76 20 28 76 (let ((v (v 47b0: 65 63 74 6f 72 2d 72 65 66 20 76 65 63 20 69 29 ector-ref vec i) 47c0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )). 47d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 47e0: 20 20 20 28 69 66 20 76 0a 20 20 20 20 20 20 20 (if v. 47f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4800: 20 20 20 20 20 20 20 20 20 20 20 28 66 20 69 20 (f i 4810: 76 20 74 68 72 65 61 64 29 0a 20 20 20 20 20 20 v thread). 4820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4830: 20 20 20 20 20 20 20 20 20 20 20 20 74 68 72 65 thre 4840: 61 64 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 ad))))). 4850: 20 20 20 20 20 20 20 20 20 20 28 72 65 64 75 63 (reduc 4860: 65 20 28 2d 20 73 69 7a 65 20 31 29 20 74 68 72 e (- size 1) thr 4870: 65 61 64 29 29 29 0a 20 20 20 20 20 20 28 28 66 ead))). ((f 4880: 6f 72 2d 65 61 63 68 29 20 28 6c 61 6d 62 64 61 or-each) (lambda 4890: 20 28 76 65 63 20 70 72 6f 63 29 0a 20 20 20 20 (vec proc). 48a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 48b0: 28 64 6f 20 28 28 69 20 28 2d 20 73 69 7a 65 20 (do ((i (- size 48c0: 31 29 20 28 2d 20 69 20 31 29 29 29 0a 20 20 20 1) (- i 1))). 48d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 48e0: 20 20 20 20 20 28 28 6e 65 67 61 74 69 76 65 3f ((negative? 48f0: 20 69 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 i)). 4900: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 (let 4910: 28 28 76 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ((v (vector-ref 4920: 76 65 63 20 69 29 29 29 0a 20 20 20 20 20 20 20 vec i))). 4930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4940: 20 28 69 66 20 76 0a 20 20 20 20 20 20 20 20 20 (if v. 4950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4960: 20 28 70 72 6f 63 20 69 20 76 29 29 29 29 29 29 (proc i v)))))) 4970: 0a 20 20 20 20 20 20 28 28 6d 61 70 21 29 20 28 . ((map!) ( 4980: 6c 61 6d 62 64 61 20 28 76 65 63 20 70 72 6f 63 lambda (vec proc 4990: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 49a0: 20 20 28 64 6f 20 28 28 69 20 28 2d 20 73 69 7a (do ((i (- siz 49b0: 65 20 31 29 20 28 2d 20 69 20 31 29 29 29 0a 20 e 1) (- i 1))). 49c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 49d0: 20 20 20 28 28 6e 65 67 61 74 69 76 65 3f 20 69 ((negative? i 49e0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )). 49f0: 20 20 20 20 20 28 6c 65 74 20 28 28 76 20 28 76 (let ((v (v 4a00: 65 63 74 6f 72 2d 72 65 66 20 76 65 63 20 69 29 ector-ref vec i) 4a10: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )). 4a20: 20 20 20 20 20 20 20 28 69 66 20 76 0a 20 20 20 (if v. 4a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4a40: 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 (vector-set! 4a50: 76 65 63 20 69 20 28 70 72 6f 63 20 69 20 76 29 vec i (proc i v) 4a60: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))). 4a70: 20 20 20 20 20 76 65 63 29 29 0a 20 20 20 20 20 vec)). 4a80: 20 28 28 69 6e 63 21 29 20 28 6c 61 6d 62 64 61 ((inc!) (lambda 4a90: 20 28 76 65 63 20 69 20 69 6e 63 29 0a 20 20 20 (vec i inc). 4aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if 4ab0: 20 28 6e 6f 74 20 28 7a 65 72 6f 3f 20 69 6e 63 (not (zero? inc 4ac0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )). 4ad0: 20 20 20 20 20 28 6c 65 74 20 28 28 76 20 28 76 (let ((v (v 4ae0: 65 63 74 6f 72 2d 72 65 66 20 76 65 63 20 69 29 ector-ref vec i) 4af0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )). 4b00: 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 (vector-s 4b10: 65 74 21 20 76 65 63 20 69 20 28 69 66 20 76 20 et! vec i (if v 4b20: 28 2b 20 76 20 69 29 20 69 29 29 29 29 29 29 0a (+ v i) i)))))). 4b30: 20 20 20 20 20 20 28 28 70 75 73 68 21 29 20 28 ((push!) ( 4b40: 6c 61 6d 62 64 61 20 28 76 65 63 20 69 20 65 29 lambda (vec i e) 4b50: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 4b60: 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 76 (vector-set! v 4b70: 65 63 20 69 20 0a 20 20 20 20 20 20 20 20 20 20 ec i . 4b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4b90: 20 20 20 20 28 6c 65 74 20 28 28 76 20 28 76 65 (let ((v (ve 4ba0: 63 74 6f 72 2d 72 65 66 20 76 65 63 20 69 29 29 ctor-ref vec i)) 4bb0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 4bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4bd0: 20 20 28 69 66 20 76 0a 20 20 20 20 20 20 20 20 (if v. 4be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4bf0: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 (cons 4c00: 65 20 76 29 0a 20 20 20 20 20 20 20 20 20 20 20 e v). 4c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4c20: 20 20 20 20 20 20 20 28 6c 69 73 74 20 76 29 29 (list v)) 4c30: 29 29 29 29 0a 20 20 20 20 20 20 28 65 6c 73 65 )))). (else 4c40: 20 28 65 72 72 6f 72 20 22 55 6e 69 6d 70 6c 65 (error "Unimple 4c50: 6d 65 6e 74 65 64 20 73 65 6c 65 63 74 6f 72 3a mented selector: 4c60: 20 22 20 73 65 6c 65 63 74 6f 72 29 29 29 29 29 " selector))))) 4c70: 0a 0a 0a 3b 3b 3b 20 64 65 66 69 6e 65 20 61 6e ...;;; define an 4c80: 20 61 73 73 6f 63 69 61 74 6f 72 20 66 72 6f 6d associator from 4c90: 20 61 74 6f 6d 73 20 74 6f 20 76 61 6c 75 65 73 atoms to values 4ca0: 0a 0a 28 64 65 66 69 6e 65 20 61 74 6f 6d 40 0a ..(define atom@. 4cb0: 20 20 28 61 76 6c 2d 6d 61 6b 65 72 20 28 6c 61 (avl-maker (la 4cc0: 6d 62 64 61 20 28 61 31 20 61 32 29 0a 20 20 20 mbda (a1 a2). 4cd0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if 4ce0: 28 73 79 6d 62 6f 6c 3f 20 61 31 29 0a 20 20 20 (symbol? a1). 4cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i 4d00: 66 20 28 73 79 6d 62 6f 6c 3f 20 61 32 29 0a 20 f (symbol? a2). 4d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4d20: 20 20 28 73 74 72 69 6e 67 3c 3f 20 28 73 79 6d (string<? (sym 4d30: 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 61 31 29 0a bol->string a1). 4d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4d50: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 79 (sy 4d60: 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 61 32 29 mbol->string a2) 4d70: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 4d80: 20 20 20 20 20 23 66 29 0a 20 20 20 20 20 20 20 #f). 4d90: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 73 (if (s 4da0: 79 6d 62 6f 6c 3f 20 61 32 29 0a 20 20 20 20 20 ymbol? a2). 4db0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 74 #t 4dc0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 4dd0: 20 20 20 20 28 3c 20 61 31 20 61 32 29 29 29 29 (< a1 a2)))) 4de0: 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 61 74 6f ))...(define ato 4df0: 6d 40 2d 6d 61 6b 65 20 28 61 74 6f 6d 40 20 27 m@-make (atom@ ' 4e00: 6d 61 6b 65 29 29 0a 28 64 65 66 69 6e 65 20 61 make)).(define a 4e10: 74 6f 6d 40 2d 72 65 66 20 28 61 74 6f 6d 40 20 tom@-ref (atom@ 4e20: 27 72 65 66 29 29 0a 28 64 65 66 69 6e 65 20 61 'ref)).(define a 4e30: 74 6f 6d 40 2d 73 65 74 21 20 28 61 74 6f 6d 40 tom@-set! (atom@ 4e40: 20 27 73 65 74 21 29 29 0a 28 64 65 66 69 6e 65 'set!)).(define 4e50: 20 61 74 6f 6d 40 2d 6d 61 70 20 28 61 74 6f 6d atom@-map (atom 4e60: 40 20 27 6d 61 70 29 29 0a 28 64 65 66 69 6e 65 @ 'map)).(define 4e70: 20 61 74 6f 6d 40 2d 6d 61 70 21 20 28 61 74 6f atom@-map! (ato 4e80: 6d 40 20 27 6d 61 70 21 29 29 0a 28 64 65 66 69 m@ 'map!)).(defi 4e90: 6e 65 20 61 74 6f 6d 40 2d 75 70 64 61 74 65 21 ne atom@-update! 4ea0: 20 28 61 74 6f 6d 40 20 27 75 70 64 61 74 65 21 (atom@ 'update! 4eb0: 29 29 0a 28 64 65 66 69 6e 65 20 61 74 6f 6d 40 )).(define atom@ 4ec0: 2d 72 65 64 75 63 65 20 28 61 74 6f 6d 40 20 27 -reduce (atom@ ' 4ed0: 72 65 64 75 63 65 29 29 0a 28 64 65 66 69 6e 65 reduce)).(define 4ee0: 20 61 74 6f 6d 40 2d 66 6f 72 2d 65 61 63 68 20 atom@-for-each 4ef0: 28 61 74 6f 6d 40 20 27 66 6f 72 2d 65 61 63 68 (atom@ 'for-each 4f00: 29 29 0a 28 64 65 66 69 6e 65 20 61 74 6f 6d 40 )).(define atom@ 4f10: 2d 70 75 73 68 21 20 28 61 74 6f 6d 40 20 27 70 -push! (atom@ 'p 4f20: 75 73 68 21 29 29 0a 28 64 65 66 69 6e 65 20 61 ush!)).(define a 4f30: 74 6f 6d 40 2d 69 6e 63 21 20 28 61 74 6f 6d 40 tom@-inc! (atom@ 4f40: 20 27 69 6e 63 21 29 29 0a 0a 3b 3b 3b 20 64 65 'inc!))..;;; de 4f50: 66 69 6e 65 20 61 6e 20 61 73 73 6f 63 69 61 74 fine an associat 4f60: 6f 72 20 66 72 6f 6d 20 6c 69 73 74 2d 6f 66 2d or from list-of- 4f70: 73 79 6d 62 6f 6c 73 2d 3e 76 61 6c 75 65 0a 0a symbols->value.. 4f80: 28 64 65 66 69 6e 65 20 61 74 6f 6d 73 40 20 28 (define atoms@ ( 4f90: 74 72 69 65 2d 6d 61 6b 65 72 20 61 74 6f 6d 40 trie-maker atom@ 4fa0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 61 74 6f 6d ))..(define atom 4fb0: 73 40 2d 6d 61 6b 65 20 28 61 74 6f 6d 73 40 20 s@-make (atoms@ 4fc0: 27 6d 61 6b 65 29 29 0a 28 64 65 66 69 6e 65 20 'make)).(define 4fd0: 61 74 6f 6d 73 40 2d 72 65 66 20 28 61 74 6f 6d atoms@-ref (atom 4fe0: 73 40 20 27 72 65 66 29 29 0a 28 64 65 66 69 6e s@ 'ref)).(defin 4ff0: 65 20 61 74 6f 6d 73 40 2d 73 65 74 21 20 28 61 e atoms@-set! (a 5000: 74 6f 6d 73 40 20 27 73 65 74 21 29 29 0a 28 64 toms@ 'set!)).(d 5010: 65 66 69 6e 65 20 61 74 6f 6d 73 40 2d 6d 61 70 efine atoms@-map 5020: 20 28 61 74 6f 6d 73 40 20 27 6d 61 70 29 29 0a (atoms@ 'map)). 5030: 28 64 65 66 69 6e 65 20 61 74 6f 6d 73 40 2d 6d (define atoms@-m 5040: 61 70 21 20 28 61 74 6f 6d 73 40 20 27 6d 61 70 ap! (atoms@ 'map 5050: 21 29 29 0a 28 64 65 66 69 6e 65 20 61 74 6f 6d !)).(define atom 5060: 73 40 2d 75 70 64 61 74 65 21 20 28 61 74 6f 6d s@-update! (atom 5070: 73 40 20 27 75 70 64 61 74 65 21 29 29 0a 28 64 s@ 'update!)).(d 5080: 65 66 69 6e 65 20 61 74 6f 6d 73 40 2d 72 65 64 efine atoms@-red 5090: 75 63 65 20 28 61 74 6f 6d 73 40 20 27 72 65 64 uce (atoms@ 'red 50a0: 75 63 65 29 29 0a 28 64 65 66 69 6e 65 20 61 74 uce)).(define at 50b0: 6f 6d 73 40 2d 66 6f 72 2d 65 61 63 68 20 28 61 oms@-for-each (a 50c0: 74 6f 6d 73 40 20 27 66 6f 72 2d 65 61 63 68 29 toms@ 'for-each) 50d0: 29 0a 28 64 65 66 69 6e 65 20 61 74 6f 6d 73 40 ).(define atoms@ 50e0: 2d 70 75 73 68 21 20 28 61 74 6f 6d 73 40 20 27 -push! (atoms@ ' 50f0: 70 75 73 68 21 29 29 0a 28 64 65 66 69 6e 65 20 push!)).(define 5100: 61 74 6f 6d 73 40 2d 69 6e 63 21 20 28 61 74 6f atoms@-inc! (ato 5110: 6d 73 40 20 27 69 6e 63 21 29 29 0a ms@ 'inc!)).