Artifact
12ac5a7885fe4171901718edfc62354527d4a41a:
- File
data-structures.scm
— part of check-in
[edbaf21f17]
at
2016-12-09 20:15:57
on branch trunk
— added data-structures
(user:
aldo
size: 23634)
0000: 3b 3b 3b 20 64 61 74 61 2d 73 74 72 75 63 74 75 ;;; data-structu
0010: 72 65 73 2e 73 63 6d 20 2d 20 4f 70 74 69 6f 6e res.scm - Option
0020: 61 6c 20 64 61 74 61 20 73 74 72 75 63 74 75 72 al data structur
0030: 65 73 20 65 78 74 65 6e 73 69 6f 6e 73 0a 3b 0a es extensions.;.
0040: 3b 20 43 6f 70 79 72 69 67 68 74 20 28 63 29 20 ; Copyright (c)
0050: 32 30 30 38 2d 32 30 31 34 2c 20 54 68 65 20 43 2008-2014, The C
0060: 68 69 63 6b 65 6e 20 54 65 61 6d 0a 3b 20 41 6c hicken Team.; Al
0070: 6c 20 72 69 67 68 74 73 20 72 65 73 65 72 76 65 l rights reserve
0080: 64 2e 0a 3b 0a 3b 20 52 65 64 69 73 74 72 69 62 d..;.; Redistrib
0090: 75 74 69 6f 6e 20 61 6e 64 20 75 73 65 20 69 6e ution and use in
00a0: 20 73 6f 75 72 63 65 20 61 6e 64 20 62 69 6e 61 source and bina
00b0: 72 79 20 66 6f 72 6d 73 2c 20 77 69 74 68 20 6f ry forms, with o
00c0: 72 20 77 69 74 68 6f 75 74 0a 3b 20 6d 6f 64 69 r without.; modi
00d0: 66 69 63 61 74 69 6f 6e 2c 20 61 72 65 20 70 65 fication, are pe
00e0: 72 6d 69 74 74 65 64 20 70 72 6f 76 69 64 65 64 rmitted provided
00f0: 20 74 68 61 74 20 74 68 65 20 66 6f 6c 6c 6f 77 that the follow
0100: 69 6e 67 20 63 6f 6e 64 69 74 69 6f 6e 73 0a 3b ing conditions.;
0110: 20 61 72 65 20 6d 65 74 3a 0a 3b 0a 3b 20 20 20 are met:.;.;
0120: 52 65 64 69 73 74 72 69 62 75 74 69 6f 6e 73 20 Redistributions
0130: 6f 66 20 73 6f 75 72 63 65 20 63 6f 64 65 20 6d of source code m
0140: 75 73 74 20 72 65 74 61 69 6e 20 74 68 65 20 61 ust retain the a
0150: 62 6f 76 65 20 63 6f 70 79 72 69 67 68 74 20 6e bove copyright n
0160: 6f 74 69 63 65 2c 20 74 68 69 73 20 6c 69 73 74 otice, this list
0170: 20 6f 66 20 63 6f 6e 64 69 74 69 6f 6e 73 20 61 of conditions a
0180: 6e 64 20 74 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 nd the following
0190: 0a 3b 20 20 20 20 20 64 69 73 63 6c 61 69 6d 65 .; disclaime
01a0: 72 2e 20 0a 3b 20 20 20 52 65 64 69 73 74 72 69 r. .; Redistri
01b0: 62 75 74 69 6f 6e 73 20 69 6e 20 62 69 6e 61 72 butions in binar
01c0: 79 20 66 6f 72 6d 20 6d 75 73 74 20 72 65 70 72 y form must repr
01d0: 6f 64 75 63 65 20 74 68 65 20 61 62 6f 76 65 20 oduce the above
01e0: 63 6f 70 79 72 69 67 68 74 20 6e 6f 74 69 63 65 copyright notice
01f0: 2c 20 74 68 69 73 20 6c 69 73 74 20 6f 66 20 63 , this list of c
0200: 6f 6e 64 69 74 69 6f 6e 73 20 61 6e 64 20 74 68 onditions and th
0210: 65 20 66 6f 6c 6c 6f 77 69 6e 67 0a 3b 20 20 20 e following.;
0220: 20 20 64 69 73 63 6c 61 69 6d 65 72 20 69 6e 20 disclaimer in
0230: 74 68 65 20 64 6f 63 75 6d 65 6e 74 61 74 69 6f the documentatio
0240: 6e 20 61 6e 64 2f 6f 72 20 6f 74 68 65 72 20 6d n and/or other m
0250: 61 74 65 72 69 61 6c 73 20 70 72 6f 76 69 64 65 aterials provide
0260: 64 20 77 69 74 68 20 74 68 65 20 64 69 73 74 72 d with the distr
0270: 69 62 75 74 69 6f 6e 2e 20 0a 3b 20 20 20 4e 65 ibution. .; Ne
0280: 69 74 68 65 72 20 74 68 65 20 6e 61 6d 65 20 6f ither the name o
0290: 66 20 74 68 65 20 61 75 74 68 6f 72 20 6e 6f 72 f the author nor
02a0: 20 74 68 65 20 6e 61 6d 65 73 20 6f 66 20 69 74 the names of it
02b0: 73 20 63 6f 6e 74 72 69 62 75 74 6f 72 73 20 6d s contributors m
02c0: 61 79 20 62 65 20 75 73 65 64 20 74 6f 20 65 6e ay be used to en
02d0: 64 6f 72 73 65 20 6f 72 20 70 72 6f 6d 6f 74 65 dorse or promote
02e0: 0a 3b 20 20 20 20 20 70 72 6f 64 75 63 74 73 20 .; products
02f0: 64 65 72 69 76 65 64 20 66 72 6f 6d 20 74 68 69 derived from thi
0300: 73 20 73 6f 66 74 77 61 72 65 20 77 69 74 68 6f s software witho
0310: 75 74 20 73 70 65 63 69 66 69 63 20 70 72 69 6f ut specific prio
0320: 72 20 77 72 69 74 74 65 6e 20 70 65 72 6d 69 73 r written permis
0330: 73 69 6f 6e 2e 20 0a 3b 0a 3b 20 54 48 49 53 20 sion. .;.; THIS
0340: 53 4f 46 54 57 41 52 45 20 49 53 20 50 52 4f 56 SOFTWARE IS PROV
0350: 49 44 45 44 20 42 59 20 54 48 45 20 43 4f 50 59 IDED BY THE COPY
0360: 52 49 47 48 54 20 48 4f 4c 44 45 52 53 20 41 4e RIGHT HOLDERS AN
0370: 44 20 43 4f 4e 54 52 49 42 55 54 4f 52 53 20 22 D CONTRIBUTORS "
0380: 41 53 20 49 53 22 20 41 4e 44 20 41 4e 59 20 45 AS IS" AND ANY E
0390: 58 50 52 45 53 53 0a 3b 20 4f 52 20 49 4d 50 4c XPRESS.; OR IMPL
03a0: 49 45 44 20 57 41 52 52 41 4e 54 49 45 53 2c 20 IED WARRANTIES,
03b0: 49 4e 43 4c 55 44 49 4e 47 2c 20 42 55 54 20 4e INCLUDING, BUT N
03c0: 4f 54 20 4c 49 4d 49 54 45 44 20 54 4f 2c 20 54 OT LIMITED TO, T
03d0: 48 45 20 49 4d 50 4c 49 45 44 20 57 41 52 52 41 HE IMPLIED WARRA
03e0: 4e 54 49 45 53 20 4f 46 20 4d 45 52 43 48 41 4e NTIES OF MERCHAN
03f0: 54 41 42 49 4c 49 54 59 0a 3b 20 41 4e 44 20 46 TABILITY.; AND F
0400: 49 54 4e 45 53 53 20 46 4f 52 20 41 20 50 41 52 ITNESS FOR A PAR
0410: 54 49 43 55 4c 41 52 20 50 55 52 50 4f 53 45 20 TICULAR PURPOSE
0420: 41 52 45 20 44 49 53 43 4c 41 49 4d 45 44 2e 20 ARE DISCLAIMED.
0430: 49 4e 20 4e 4f 20 45 56 45 4e 54 20 53 48 41 4c IN NO EVENT SHAL
0440: 4c 20 54 48 45 20 43 4f 50 59 52 49 47 48 54 20 L THE COPYRIGHT
0450: 48 4f 4c 44 45 52 53 20 4f 52 0a 3b 20 43 4f 4e HOLDERS OR.; CON
0460: 54 52 49 42 55 54 4f 52 53 20 42 45 20 4c 49 41 TRIBUTORS BE LIA
0470: 42 4c 45 20 46 4f 52 20 41 4e 59 20 44 49 52 45 BLE FOR ANY DIRE
0480: 43 54 2c 20 49 4e 44 49 52 45 43 54 2c 20 49 4e CT, INDIRECT, IN
0490: 43 49 44 45 4e 54 41 4c 2c 20 53 50 45 43 49 41 CIDENTAL, SPECIA
04a0: 4c 2c 20 45 58 45 4d 50 4c 41 52 59 2c 20 4f 52 L, EXEMPLARY, OR
04b0: 0a 3b 20 43 4f 4e 53 45 51 55 45 4e 54 49 41 4c .; CONSEQUENTIAL
04c0: 20 44 41 4d 41 47 45 53 20 28 49 4e 43 4c 55 44 DAMAGES (INCLUD
04d0: 49 4e 47 2c 20 42 55 54 20 4e 4f 54 20 4c 49 4d ING, BUT NOT LIM
04e0: 49 54 45 44 20 54 4f 2c 20 50 52 4f 43 55 52 45 ITED TO, PROCURE
04f0: 4d 45 4e 54 20 4f 46 20 53 55 42 53 54 49 54 55 MENT OF SUBSTITU
0500: 54 45 20 47 4f 4f 44 53 20 4f 52 0a 3b 20 53 45 TE GOODS OR.; SE
0510: 52 56 49 43 45 53 3b 20 4c 4f 53 53 20 4f 46 20 RVICES; LOSS OF
0520: 55 53 45 2c 20 44 41 54 41 2c 20 4f 52 20 50 52 USE, DATA, OR PR
0530: 4f 46 49 54 53 3b 20 4f 52 20 42 55 53 49 4e 45 OFITS; OR BUSINE
0540: 53 53 20 49 4e 54 45 52 52 55 50 54 49 4f 4e 29 SS INTERRUPTION)
0550: 20 48 4f 57 45 56 45 52 20 43 41 55 53 45 44 20 HOWEVER CAUSED
0560: 41 4e 44 20 4f 4e 20 41 4e 59 0a 3b 20 54 48 45 AND ON ANY.; THE
0570: 4f 52 59 20 4f 46 20 4c 49 41 42 49 4c 49 54 59 ORY OF LIABILITY
0580: 2c 20 57 48 45 54 48 45 52 20 49 4e 20 43 4f 4e , WHETHER IN CON
0590: 54 52 41 43 54 2c 20 53 54 52 49 43 54 20 4c 49 TRACT, STRICT LI
05a0: 41 42 49 4c 49 54 59 2c 20 4f 52 20 54 4f 52 54 ABILITY, OR TORT
05b0: 20 28 49 4e 43 4c 55 44 49 4e 47 20 4e 45 47 4c (INCLUDING NEGL
05c0: 49 47 45 4e 43 45 20 4f 52 0a 3b 20 4f 54 48 45 IGENCE OR.; OTHE
05d0: 52 57 49 53 45 29 20 41 52 49 53 49 4e 47 20 49 RWISE) ARISING I
05e0: 4e 20 41 4e 59 20 57 41 59 20 4f 55 54 20 4f 46 N ANY WAY OUT OF
05f0: 20 54 48 45 20 55 53 45 20 4f 46 20 54 48 49 53 THE USE OF THIS
0600: 20 53 4f 46 54 57 41 52 45 2c 20 45 56 45 4e 20 SOFTWARE, EVEN
0610: 49 46 20 41 44 56 49 53 45 44 20 4f 46 20 54 48 IF ADVISED OF TH
0620: 45 0a 3b 20 50 4f 53 53 49 42 49 4c 49 54 59 20 E.; POSSIBILITY
0630: 4f 46 20 53 55 43 48 20 44 41 4d 41 47 45 2e 0a OF SUCH DAMAGE..
0640: 0a 3b 3b 3b 20 41 64 61 70 74 65 64 20 74 6f 20 .;;; Adapted to
0650: 43 68 65 7a 20 53 63 68 65 6d 65 0a 3b 3b 3b 20 Chez Scheme.;;;
0660: 43 6f 70 79 72 69 67 68 74 20 28 43 29 20 32 30 Copyright (C) 20
0670: 31 36 20 41 6c 64 6f 20 4e 69 63 6f 6c 61 73 20 16 Aldo Nicolas
0680: 42 72 75 6e 6f 0a 0a 28 64 65 66 69 6e 65 2d 73 Bruno..(define-s
0690: 79 6e 74 61 78 20 64 20 28 73 79 6e 74 61 78 2d yntax d (syntax-
06a0: 72 75 6c 65 73 20 28 29 20 28 28 5f 20 2e 20 5f rules () ((_ . _
06b0: 29 20 28 76 6f 69 64 29 29 29 29 0a 0a 28 64 65 ) (void))))..(de
06c0: 66 69 6e 65 2d 73 79 6e 74 61 78 20 64 65 66 69 fine-syntax defi
06d0: 6e 65 2d 61 6c 69 61 73 0a 20 20 28 73 79 6e 74 ne-alias. (synt
06e0: 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 ax-rules ().
06f0: 28 28 5f 20 6e 65 77 20 6f 6c 64 29 0a 20 20 20 ((_ new old).
0700: 20 20 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 (define-syntax
0710: 20 6e 65 77 0a 20 20 20 20 20 20 20 28 73 79 6e new. (syn
0720: 74 61 78 2d 72 75 6c 65 73 20 5f 5f 5f 20 28 29 tax-rules ___ ()
0730: 0a 09 09 20 20 20 20 20 28 28 5f 20 61 72 67 73 ... ((_ args
0740: 20 5f 5f 5f 29 0a 09 09 20 20 20 20 20 20 28 6f ___)... (o
0750: 6c 64 20 61 72 67 73 20 5f 5f 5f 29 29 29 29 29 ld args ___)))))
0760: 29 29 0a 0a 0a 3b 3b 3b 20 43 6f 6d 62 69 6e 61 ))...;;; Combina
0770: 74 6f 72 73 3a 0a 0a 28 64 65 66 69 6e 65 20 28 tors:..(define (
0780: 69 64 65 6e 74 69 74 79 20 78 29 20 78 29 0a 0a identity x) x)..
0790: 28 64 65 66 69 6e 65 20 28 63 6f 6e 6a 6f 69 6e (define (conjoin
07a0: 20 2e 20 70 72 65 64 73 29 0a 20 20 28 6c 61 6d . preds). (lam
07b0: 62 64 61 20 28 78 29 0a 20 20 20 20 28 6c 65 74 bda (x). (let
07c0: 20 6c 6f 6f 70 20 28 5b 70 72 65 64 73 20 70 72 loop ([preds pr
07d0: 65 64 73 5d 29 0a 20 20 20 20 20 20 28 6f 72 20 eds]). (or
07e0: 28 6e 75 6c 6c 3f 20 70 72 65 64 73 29 0a 09 20 (null? preds)..
07f0: 20 28 61 6e 64 20 28 28 63 61 72 20 70 72 65 64 (and ((car pred
0800: 73 29 20 78 29 0a 09 20 20 20 20 20 20 20 28 6c s) x).. (l
0810: 6f 6f 70 20 28 63 64 72 20 70 72 65 64 73 29 29 oop (cdr preds))
0820: 20 29 20 29 20 29 20 29 20 29 0a 0a 28 64 65 66 ) ) ) ) )..(def
0830: 69 6e 65 20 28 64 69 73 6a 6f 69 6e 20 2e 20 70 ine (disjoin . p
0840: 72 65 64 73 29 0a 20 20 28 6c 61 6d 62 64 61 20 reds). (lambda
0850: 28 78 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f (x). (let loo
0860: 70 20 28 5b 70 72 65 64 73 20 70 72 65 64 73 5d p ([preds preds]
0870: 29 0a 20 20 20 20 20 20 28 61 6e 64 20 28 6e 6f ). (and (no
0880: 74 20 28 6e 75 6c 6c 3f 20 70 72 65 64 73 29 29 t (null? preds))
0890: 0a 09 20 20 20 28 6f 72 20 28 28 63 61 72 20 70 .. (or ((car p
08a0: 72 65 64 73 29 20 78 29 0a 09 20 20 20 20 20 20 reds) x)..
08b0: 20 28 6c 6f 6f 70 20 28 63 64 72 20 70 72 65 64 (loop (cdr pred
08c0: 73 29 29 20 29 20 29 20 29 20 29 20 29 0a 0a 28 s)) ) ) ) ) )..(
08d0: 64 65 66 69 6e 65 20 28 63 6f 6e 73 74 61 6e 74 define (constant
08e0: 6c 79 20 2e 20 78 73 29 0a 20 20 28 69 66 20 28 ly . xs). (if (
08f0: 3d 20 31 20 28 6c 65 6e 67 74 68 20 78 73 29 29 = 1 (length xs))
0900: 0a 20 20 20 20 20 20 28 6c 65 74 20 28 5b 78 20 . (let ([x
0910: 28 63 61 72 20 78 73 29 5d 29 0a 09 28 6c 61 6d (car xs)])..(lam
0920: 62 64 61 20 5f 20 78 29 20 29 0a 20 20 20 20 20 bda _ x) ).
0930: 20 28 6c 61 6d 62 64 61 20 5f 20 28 61 70 70 6c (lambda _ (appl
0940: 79 20 76 61 6c 75 65 73 20 78 73 29 29 20 29 20 y values xs)) )
0950: 29 0a 0a 28 64 65 66 69 6e 65 20 28 66 6c 69 70 )..(define (flip
0960: 20 70 72 6f 63 29 20 28 6c 61 6d 62 64 61 20 28 proc) (lambda (
0970: 78 20 79 29 20 28 70 72 6f 63 20 79 20 78 29 29 x y) (proc y x))
0980: 29 0a 0a 28 64 65 66 69 6e 65 20 63 6f 6d 70 6c )..(define compl
0990: 65 6d 65 6e 74 0a 20 20 28 6c 61 6d 62 64 61 20 ement. (lambda
09a0: 28 70 29 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 (p). (lambda
09b0: 61 72 67 73 20 28 6e 6f 74 20 28 61 70 70 6c 79 args (not (apply
09c0: 20 70 20 61 72 67 73 29 29 29 20 29 20 29 0a 0a p args))) ) )..
09d0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 70 6f 73 65 (define (compose
09e0: 20 2e 20 66 6e 73 29 0a 20 20 28 64 65 66 69 6e . fns). (defin
09f0: 65 20 28 72 65 63 20 66 30 20 2e 20 66 6e 73 29 e (rec f0 . fns)
0a00: 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 . (if (null?
0a10: 66 6e 73 29 0a 09 66 30 0a 09 28 6c 61 6d 62 64 fns)..f0..(lambd
0a20: 61 20 61 72 67 73 0a 09 20 20 28 63 61 6c 6c 2d a args.. (call-
0a30: 77 69 74 68 2d 76 61 6c 75 65 73 0a 09 20 20 20 with-values..
0a40: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 20 28 61 (lambda () (a
0a50: 70 70 6c 79 20 28 61 70 70 6c 79 20 72 65 63 20 pply (apply rec
0a60: 66 6e 73 29 20 61 72 67 73 29 29 0a 09 20 20 20 fns) args))..
0a70: 20 66 30 29 20 29 20 29 20 29 0a 20 20 28 69 66 f0) ) ) ). (if
0a80: 20 28 6e 75 6c 6c 3f 20 66 6e 73 29 0a 20 20 20 (null? fns).
0a90: 20 20 20 76 61 6c 75 65 73 0a 20 20 20 20 20 20 values.
0aa0: 28 61 70 70 6c 79 20 72 65 63 20 66 6e 73 29 20 (apply rec fns)
0ab0: 29 20 29 0a 0a 28 64 65 66 69 6e 65 20 28 6f 20 ) )..(define (o
0ac0: 2e 20 66 6e 73 29 0a 20 20 28 69 66 20 28 6e 75 . fns). (if (nu
0ad0: 6c 6c 3f 20 66 6e 73 29 0a 20 20 20 20 20 20 69 ll? fns). i
0ae0: 64 65 6e 74 69 74 79 0a 20 20 20 20 20 20 28 6c dentity. (l
0af0: 65 74 20 6c 6f 6f 70 20 28 28 66 6e 73 20 66 6e et loop ((fns fn
0b00: 73 29 29 0a 09 28 6c 65 74 20 28 28 68 20 28 63 s))..(let ((h (c
0b10: 61 72 20 66 6e 73 29 29 0a 09 20 20 20 20 20 20 ar fns))..
0b20: 28 74 20 28 63 64 72 20 66 6e 73 29 29 20 29 0a (t (cdr fns)) ).
0b30: 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 29 . (if (null? t)
0b40: 0a 09 20 20 20 20 20 20 68 0a 09 20 20 20 20 20 .. h..
0b50: 20 28 6c 61 6d 62 64 61 20 28 78 29 20 28 68 20 (lambda (x) (h
0b60: 28 28 6c 6f 6f 70 20 74 29 20 78 29 29 29 29 29 ((loop t) x)))))
0b70: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6c 69 )))..(define (li
0b80: 73 74 2d 6f 66 3f 20 70 72 65 64 29 0a 20 20 28 st-of? pred). (
0b90: 6c 61 6d 62 64 61 20 28 6c 73 74 29 0a 20 20 20 lambda (lst).
0ba0: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 5b 6c 73 74 (let loop ([lst
0bb0: 20 6c 73 74 5d 29 0a 20 20 20 20 20 20 28 63 6f lst]). (co
0bc0: 6e 64 20 5b 28 6e 75 6c 6c 3f 20 6c 73 74 29 20 nd [(null? lst)
0bd0: 23 74 5d 0a 09 20 20 20 20 5b 28 6e 6f 74 20 28 #t].. [(not (
0be0: 70 61 69 72 3f 20 6c 73 74 29 29 20 23 66 5d 0a pair? lst)) #f].
0bf0: 09 20 20 20 20 5b 28 70 72 65 64 20 28 63 61 72 . [(pred (car
0c00: 20 6c 73 74 29 29 20 28 6c 6f 6f 70 20 28 63 64 lst)) (loop (cd
0c10: 72 20 6c 73 74 29 29 5d 0a 09 20 20 20 20 5b 65 r lst))].. [e
0c20: 6c 73 65 20 23 66 5d 20 29 20 29 20 29 20 29 0a lse #f] ) ) ) ).
0c30: 0a 28 64 65 66 69 6e 65 20 28 65 61 63 68 20 2e .(define (each .
0c40: 20 70 72 6f 63 73 29 0a 20 20 28 63 6f 6e 64 20 procs). (cond
0c50: 28 28 6e 75 6c 6c 3f 20 70 72 6f 63 73 29 20 28 ((null? procs) (
0c60: 6c 61 6d 62 64 61 20 5f 20 28 76 6f 69 64 29 29 lambda _ (void))
0c70: 29 0a 09 28 28 6e 75 6c 6c 3f 20 28 63 64 72 20 )..((null? (cdr
0c80: 70 72 6f 63 73 29 29 20 28 63 61 72 20 70 72 6f procs)) (car pro
0c90: 63 73 29 29 0a 09 28 65 6c 73 65 0a 09 20 28 6c cs))..(else.. (l
0ca0: 61 6d 62 64 61 20 61 72 67 73 0a 09 20 20 20 28 ambda args.. (
0cb0: 6c 65 74 20 6c 6f 6f 70 20 28 28 70 72 6f 63 73 let loop ((procs
0cc0: 20 70 72 6f 63 73 29 29 0a 09 20 20 20 20 20 28 procs)).. (
0cd0: 6c 65 74 20 28 28 68 20 28 63 61 72 20 70 72 6f let ((h (car pro
0ce0: 63 73 29 29 0a 09 09 20 20 20 28 74 20 28 63 64 cs))... (t (cd
0cf0: 72 20 70 72 6f 63 73 29 29 20 29 0a 09 20 20 20 r procs)) )..
0d00: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 (if (null? t
0d10: 29 0a 09 09 20 20 20 28 61 70 70 6c 79 20 68 20 )... (apply h
0d20: 61 72 67 73 29 0a 09 09 20 20 20 28 62 65 67 69 args)... (begi
0d30: 6e 0a 09 09 20 20 20 20 20 28 61 70 70 6c 79 20 n... (apply
0d40: 68 20 61 72 67 73 29 0a 09 09 20 20 20 20 20 28 h args)... (
0d50: 6c 6f 6f 70 20 74 29 20 29 20 29 20 29 20 29 20 loop t) ) ) ) )
0d60: 29 20 29 20 29 20 29 0a 0a 28 64 65 66 69 6e 65 ) ) ) )..(define
0d70: 20 28 61 6e 79 3f 20 78 29 20 23 74 29 0a 0a 0a (any? x) #t)...
0d80: 3b 3b 3b 20 4c 69 73 74 20 6f 70 65 72 61 74 6f ;;; List operato
0d90: 72 73 3a 0a 0a 0a 28 64 65 66 69 6e 65 20 28 74 rs:...(define (t
0da0: 61 69 6c 3f 20 78 20 79 29 0a 20 20 28 61 73 73 ail? x y). (ass
0db0: 65 72 74 20 28 61 6e 64 20 27 74 61 69 6c 3f 20 ert (and 'tail?
0dc0: 28 6c 69 73 74 3f 20 79 29 29 29 0a 20 20 28 6f (list? y))). (o
0dd0: 72 20 28 6e 75 6c 6c 3f 20 78 29 0a 20 20 20 20 r (null? x).
0de0: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 79 20 (let loop ((y
0df0: 79 29 29 0a 09 28 63 6f 6e 64 20 28 28 6e 75 6c y))..(cond ((nul
0e00: 6c 3f 20 79 29 20 23 66 29 0a 09 20 20 20 20 20 l? y) #f)..
0e10: 20 28 28 65 71 3f 20 78 20 79 29 20 23 74 29 0a ((eq? x y) #t).
0e20: 09 20 20 20 20 20 20 28 65 6c 73 65 20 28 6c 6f . (else (lo
0e30: 6f 70 20 28 63 64 72 20 79 29 29 29 20 29 20 29 op (cdr y))) ) )
0e40: 20 29 20 29 0a 0a 28 64 65 66 69 6e 65 20 69 6e ) )..(define in
0e50: 74 65 72 73 70 65 72 73 65 20 0a 20 20 28 6c 61 tersperse . (la
0e60: 6d 62 64 61 20 28 6c 73 74 20 78 29 0a 20 20 20 mbda (lst x).
0e70: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6e 73 20 (let loop ((ns
0e80: 6c 73 74 29 29 0a 20 20 20 20 20 20 28 69 66 20 lst)). (if
0e90: 28 6e 75 6c 6c 3f 20 6e 73 29 0a 09 20 20 6e 73 (null? ns).. ns
0ea0: 0a 09 20 20 28 6c 65 74 20 28 28 74 61 69 6c 20 .. (let ((tail
0eb0: 28 63 64 72 20 6e 73 29 29 29 0a 09 20 20 20 20 (cdr ns)))..
0ec0: 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 (if (null? tail)
0ed0: 0a 09 09 6e 73 0a 09 09 28 63 6f 6e 73 20 28 63 ...ns...(cons (c
0ee0: 61 72 20 6e 73 29 20 28 63 6f 6e 73 20 78 20 28 ar ns) (cons x (
0ef0: 6c 6f 6f 70 20 74 61 69 6c 29 29 29 20 29 20 29 loop tail))) ) )
0f00: 20 29 20 29 20 29 20 29 0a 0a 28 64 65 66 69 6e ) ) ) )..(defin
0f10: 65 20 28 62 75 74 6c 61 73 74 20 6c 73 74 29 0a e (butlast lst).
0f20: 20 20 28 61 73 73 65 72 74 20 28 61 6e 64 20 27 (assert (and '
0f30: 62 75 74 6c 61 73 74 20 28 70 61 69 72 3f 20 6c butlast (pair? l
0f40: 73 74 20 29 29 29 0a 20 20 28 6c 65 74 20 6c 6f st ))). (let lo
0f50: 6f 70 20 28 28 6c 73 74 20 6c 73 74 29 29 0a 20 op ((lst lst)).
0f60: 20 20 20 28 6c 65 74 20 28 28 6e 65 78 74 20 28 (let ((next (
0f70: 63 64 72 20 6c 73 74 20 29 29 29 0a 20 20 20 20 cdr lst ))).
0f80: 20 20 28 69 66 20 28 70 61 69 72 3f 20 6e 65 78 (if (pair? nex
0f90: 74 29 0a 09 20 20 28 63 6f 6e 73 20 28 63 61 72 t).. (cons (car
0fa0: 20 6c 73 74 29 20 28 6c 6f 6f 70 20 6e 65 78 74 lst) (loop next
0fb0: 29 29 0a 09 20 20 27 28 29 20 29 20 29 20 29 20 )).. '() ) ) )
0fc0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 66 6c 61 74 )..(define (flat
0fd0: 74 65 6e 20 2e 20 6c 69 73 74 73 30 29 0a 20 20 ten . lists0).
0fe0: 28 6c 65 74 20 6c 6f 6f 70 20 28 5b 6c 69 73 74 (let loop ([list
0ff0: 73 20 6c 69 73 74 73 30 5d 20 5b 72 65 73 74 20 s lists0] [rest
1000: 27 28 29 5d 29 0a 20 20 20 20 28 63 6f 6e 64 20 '()]). (cond
1010: 5b 28 6e 75 6c 6c 3f 20 6c 69 73 74 73 29 20 72 [(null? lists) r
1020: 65 73 74 5d 0a 09 20 20 5b 65 6c 73 65 0a 09 20 est].. [else..
1030: 20 20 28 6c 65 74 20 28 5b 68 65 61 64 20 28 63 (let ([head (c
1040: 61 72 20 6c 69 73 74 73 29 5d 0a 09 09 20 5b 74 ar lists)]... [t
1050: 61 69 6c 20 28 63 64 72 20 6c 69 73 74 73 29 5d ail (cdr lists)]
1060: 20 29 0a 09 20 20 20 20 20 28 69 66 20 28 6c 69 ).. (if (li
1070: 73 74 3f 20 68 65 61 64 29 0a 09 09 20 28 6c 6f st? head)... (lo
1080: 6f 70 20 68 65 61 64 20 28 6c 6f 6f 70 20 74 61 op head (loop ta
1090: 69 6c 20 72 65 73 74 29 29 0a 09 09 20 28 63 6f il rest))... (co
10a0: 6e 73 20 68 65 61 64 20 28 6c 6f 6f 70 20 74 61 ns head (loop ta
10b0: 69 6c 20 72 65 73 74 29 29 20 29 20 29 20 5d 20 il rest)) ) ) ]
10c0: 29 20 29 20 29 0a 0a 28 64 65 66 69 6e 65 20 63 ) ) )..(define c
10d0: 68 6f 70 0a 20 20 28 6c 61 6d 62 64 61 20 28 6c hop. (lambda (l
10e0: 73 74 20 6e 29 0a 20 20 20 20 28 61 73 73 65 72 st n). (asser
10f0: 74 20 28 61 6e 64 20 27 63 68 6f 70 20 28 65 78 t (and 'chop (ex
1100: 61 63 74 3f 20 6e 29 29 29 0a 20 20 20 20 28 77 act? n))). (w
1110: 68 65 6e 20 28 66 78 3c 3d 20 6e 20 30 29 20 28 hen (fx<= n 0) (
1120: 65 72 72 6f 72 66 20 27 63 68 6f 70 20 22 69 6e errorf 'chop "in
1130: 76 61 6c 69 64 20 6e 75 6d 65 72 69 63 20 61 72 valid numeric ar
1140: 67 75 6d 65 6e 74 20 7e 64 22 20 6e 29 29 0a 20 gument ~d" n)).
1150: 20 20 20 28 6c 65 74 20 28 5b 6c 65 6e 20 28 6c (let ([len (l
1160: 65 6e 67 74 68 20 6c 73 74 29 5d 29 0a 20 20 20 ength lst)]).
1170: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 5b 6c (let loop ([l
1180: 73 74 20 6c 73 74 5d 20 5b 69 20 6c 65 6e 5d 29 st lst] [i len])
1190: 0a 09 28 63 6f 6e 64 20 5b 28 6e 75 6c 6c 3f 20 ..(cond [(null?
11a0: 6c 73 74 29 20 27 28 29 5d 0a 09 20 20 20 20 20 lst) '()]..
11b0: 20 5b 28 66 78 3c 20 69 20 6e 29 20 28 6c 69 73 [(fx< i n) (lis
11c0: 74 20 6c 73 74 29 5d 0a 09 20 20 20 20 20 20 5b t lst)].. [
11d0: 65 6c 73 65 0a 09 20 20 20 20 20 20 20 28 64 6f else.. (do
11e0: 20 28 5b 68 64 20 27 28 29 20 28 63 6f 6e 73 20 ([hd '() (cons
11f0: 28 63 61 72 20 74 6c 29 20 68 64 29 5d 0a 09 09 (car tl) hd)]...
1200: 20 20 20 20 5b 74 6c 20 6c 73 74 20 28 63 64 72 [tl lst (cdr
1210: 20 74 6c 29 5d 20 0a 09 09 20 20 20 20 5b 63 20 tl)] ... [c
1220: 6e 20 28 66 78 2d 20 63 20 31 29 5d 20 29 0a 09 n (fx- c 1)] )..
1230: 09 20 20 20 28 28 66 78 3d 20 63 20 30 29 0a 09 . ((fx= c 0)..
1240: 09 20 20 20 20 28 63 6f 6e 73 20 28 72 65 76 65 . (cons (reve
1250: 72 73 65 20 68 64 29 20 28 6c 6f 6f 70 20 74 6c rse hd) (loop tl
1260: 20 28 66 78 2d 20 69 20 6e 29 29 29 20 29 20 29 (fx- i n))) ) )
1270: 20 5d 20 29 20 29 20 29 20 29 20 29 0a 0a 28 64 ] ) ) ) ) )..(d
1280: 65 66 69 6e 65 20 28 6a 6f 69 6e 20 6c 73 74 73 efine (join lsts
1290: 20 2e 20 6c 73 74 29 0a 20 20 28 6c 65 74 20 28 . lst). (let (
12a0: 5b 6c 73 74 20 28 69 66 20 28 70 61 69 72 3f 20 [lst (if (pair?
12b0: 6c 73 74 29 20 28 63 61 72 20 6c 73 74 29 20 27 lst) (car lst) '
12c0: 28 29 29 5d 29 0a 20 20 20 20 28 61 73 73 65 72 ())]). (asser
12d0: 74 20 28 61 6e 64 20 27 6a 6f 69 6e 20 28 6c 69 t (and 'join (li
12e0: 73 74 3f 20 20 6c 73 74 29 29 29 0a 20 20 20 20 st? lst))).
12f0: 28 6c 65 74 20 6c 6f 6f 70 20 28 5b 6c 73 74 73 (let loop ([lsts
1300: 20 6c 73 74 73 5d 29 0a 20 20 20 20 20 20 28 63 lsts]). (c
1310: 6f 6e 64 20 5b 28 6e 75 6c 6c 3f 20 6c 73 74 73 ond [(null? lsts
1320: 29 20 27 28 29 5d 0a 09 20 20 20 20 5b 28 6e 6f ) '()].. [(no
1330: 74 20 28 70 61 69 72 3f 20 6c 73 74 73 29 29 0a t (pair? lsts)).
1340: 09 20 20 20 20 20 28 65 72 72 6f 72 66 20 27 6a . (errorf 'j
1350: 6f 69 6e 20 22 6e 6f 74 20 61 20 70 72 6f 70 65 oin "not a prope
1360: 72 20 6c 69 73 74 20 7e 64 22 20 6c 73 74 73 29 r list ~d" lsts)
1370: 20 5d 0a 09 20 20 20 20 5b 65 6c 73 65 0a 09 20 ].. [else..
1380: 20 20 20 20 28 6c 65 74 20 28 5b 6c 20 28 63 61 (let ([l (ca
1390: 72 20 6c 73 74 73 29 5d 0a 09 09 20 20 20 5b 72 r lsts)]... [r
13a0: 20 28 63 64 72 20 6c 73 74 73 29 5d 20 29 0a 09 (cdr lsts)] )..
13b0: 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c (if (null
13c0: 3f 20 72 29 0a 09 09 20 20 20 6c 0a 09 09 20 20 ? r)... l...
13d0: 20 28 61 70 70 65 6e 64 20 6c 20 6c 73 74 20 28 (append l lst (
13e0: 6c 6f 6f 70 20 72 29 29 20 29 20 29 20 5d 20 29 loop r)) ) ) ] )
13f0: 20 29 20 29 20 29 0a 0a 28 64 65 66 69 6e 65 20 ) ) )..(define
1400: 63 6f 6d 70 72 65 73 73 0a 20 20 28 6c 61 6d 62 compress. (lamb
1410: 64 61 20 28 62 6c 73 74 20 6c 73 74 29 0a 20 20 da (blst lst).
1420: 20 20 28 6c 65 74 20 28 5b 6d 73 67 20 22 62 61 (let ([msg "ba
1430: 64 20 61 72 67 75 6d 65 6e 74 20 74 79 70 65 20 d argument type
1440: 2d 20 6e 6f 74 20 61 20 70 72 6f 70 65 72 20 6c - not a proper l
1450: 69 73 74 22 5d 29 0a 20 20 20 20 20 20 28 61 73 ist"]). (as
1460: 73 65 72 74 20 28 61 6e 64 20 27 63 6f 6d 70 72 sert (and 'compr
1470: 65 73 73 20 28 6c 69 73 74 3f 20 6c 73 74 29 29 ess (list? lst))
1480: 29 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f ). (let loo
1490: 70 20 28 5b 62 6c 73 74 20 62 6c 73 74 5d 20 5b p ([blst blst] [
14a0: 6c 73 74 20 6c 73 74 5d 29 0a 09 28 63 6f 6e 64 lst lst])..(cond
14b0: 20 5b 28 6e 75 6c 6c 3f 20 62 6c 73 74 29 20 27 [(null? blst) '
14c0: 28 29 5d 0a 09 20 20 20 20 20 20 5b 28 6e 6f 74 ()].. [(not
14d0: 20 28 70 61 69 72 3f 20 62 6c 73 74 29 29 0a 09 (pair? blst))..
14e0: 20 20 20 20 20 20 20 28 65 72 72 6f 72 20 27 63 (error 'c
14f0: 6f 6d 70 72 65 73 73 20 6d 73 67 20 27 74 79 70 ompress msg 'typ
1500: 65 2d 65 72 72 6f 72 20 62 6c 73 74 29 20 5d 0a e-error blst) ].
1510: 09 20 20 20 20 20 20 5b 28 6e 6f 74 20 28 70 61 . [(not (pa
1520: 69 72 3f 20 6c 73 74 29 29 0a 09 20 20 20 20 20 ir? lst))..
1530: 20 20 28 65 72 72 6f 72 20 27 63 6f 6d 70 72 65 (error 'compre
1540: 73 73 20 6d 73 67 20 27 74 79 70 65 2d 65 72 72 ss msg 'type-err
1550: 6f 72 20 6c 73 74 29 20 5d 0a 09 20 20 20 20 20 or lst) ]..
1560: 20 5b 28 63 61 72 20 62 6c 73 74 29 0a 09 20 20 [(car blst)..
1570: 20 20 20 20 20 28 63 6f 6e 73 20 28 63 61 72 20 (cons (car
1580: 6c 73 74 29 20 28 6c 6f 6f 70 20 28 63 64 72 20 lst) (loop (cdr
1590: 62 6c 73 74 29 20 28 63 64 72 20 6c 73 74 29 29 blst) (cdr lst))
15a0: 29 5d 0a 09 20 20 20 20 20 20 5b 65 6c 73 65 20 )].. [else
15b0: 28 6c 6f 6f 70 20 28 63 64 72 20 62 6c 73 74 29 (loop (cdr blst)
15c0: 20 28 63 64 72 20 6c 73 74 29 29 5d 20 29 20 29 (cdr lst))] ) )
15d0: 20 29 20 29 20 29 0a 0a 0a 3b 3b 3b 20 41 6c 69 ) ) )...;;; Ali
15e0: 73 74 73 3a 0a 28 64 65 66 69 6e 65 20 61 6c 69 sts:.(define ali
15f0: 73 74 2d 75 70 64 61 74 65 21 0a 20 20 28 63 61 st-update!. (ca
1600: 73 65 2d 6c 61 6d 62 64 61 20 0a 20 20 20 5b 28 se-lambda . [(
1610: 78 20 79 20 6c 73 74 29 0a 20 20 20 20 28 61 6c x y lst). (al
1620: 69 73 74 2d 75 70 64 61 74 65 21 20 78 20 79 20 ist-update! x y
1630: 6c 73 74 20 65 71 76 3f 29 5d 0a 20 20 20 5b 28 lst eqv?)]. [(
1640: 78 20 79 20 6c 73 74 20 63 6d 70 29 0a 20 20 20 x y lst cmp).
1650: 20 28 6c 65 74 2a 20 28 5b 61 71 20 28 63 6f 6e (let* ([aq (con
1660: 64 20 5b 28 65 71 3f 20 65 71 3f 20 63 6d 70 29 d [(eq? eq? cmp)
1670: 20 61 73 73 71 5d 0a 09 09 20 20 20 20 20 5b 28 assq]... [(
1680: 65 71 3f 20 65 71 76 3f 20 63 6d 70 29 20 61 73 eq? eqv? cmp) as
1690: 73 76 5d 0a 09 09 20 20 20 20 20 5b 28 65 71 3f sv]... [(eq?
16a0: 20 65 71 75 61 6c 3f 20 63 6d 70 29 20 61 73 73 equal? cmp) ass
16b0: 6f 63 5d 0a 09 09 20 20 20 20 20 5b 65 6c 73 65 oc]... [else
16c0: 20 0a 09 09 20 20 20 20 20 20 28 6c 61 6d 62 64 ... (lambd
16d0: 61 20 28 78 20 6c 73 74 29 0a 09 09 09 28 6c 65 a (x lst)....(le
16e0: 74 20 6c 6f 6f 70 20 28 5b 6c 73 74 20 6c 73 74 t loop ([lst lst
16f0: 5d 29 0a 09 09 09 20 20 28 61 6e 64 20 28 70 61 ]).... (and (pa
1700: 69 72 3f 20 6c 73 74 29 0a 09 09 09 20 20 20 20 ir? lst)....
1710: 20 20 20 28 6c 65 74 20 28 5b 61 20 28 63 61 72 (let ([a (car
1720: 20 6c 73 74 29 5d 29 0a 09 09 09 20 20 20 20 20 lst)])....
1730: 20 20 28 69 66 20 28 61 6e 64 20 28 70 61 69 72 (if (and (pair
1740: 3f 20 61 29 20 28 63 6d 70 20 28 63 61 72 20 61 ? a) (cmp (car a
1750: 29 20 78 29 29 0a 09 09 09 09 20 20 20 61 0a 09 ) x))..... a..
1760: 09 09 09 20 20 20 28 6c 6f 6f 70 20 28 63 64 72 ... (loop (cdr
1770: 20 6c 73 74 29 29 20 29 20 29 20 29 20 29 20 29 lst)) ) ) ) ) )
1780: 20 5d 20 29 20 5d 20 0a 09 20 20 20 5b 69 74 65 ] ) ] .. [ite
1790: 6d 20 28 61 71 20 78 20 6c 73 74 29 5d 20 29 0a m (aq x lst)] ).
17a0: 20 20 20 20 28 69 66 20 69 74 65 6d 0a 09 28 62 (if item..(b
17b0: 65 67 69 6e 0a 09 20 20 28 73 65 74 2d 63 64 72 egin.. (set-cdr
17c0: 21 20 69 74 65 6d 20 79 29 0a 09 20 20 6c 73 74 ! item y).. lst
17d0: 29 0a 09 28 63 6f 6e 73 20 28 63 6f 6e 73 20 78 )..(cons (cons x
17e0: 20 79 29 20 6c 73 74 29 20 29 20 29 20 5d 29 29 y) lst) ) ) ]))
17f0: 0a 0a 28 64 65 66 69 6e 65 20 61 6c 69 73 74 2d ..(define alist-
1800: 75 70 64 61 74 65 0a 20 20 28 63 61 73 65 2d 6c update. (case-l
1810: 61 6d 62 64 61 20 0a 20 20 20 5b 28 6b 20 76 20 ambda . [(k v
1820: 6c 73 74 29 0a 20 20 20 20 28 61 6c 69 73 74 2d lst). (alist-
1830: 75 70 64 61 74 65 20 6b 20 76 20 6c 73 74 20 65 update k v lst e
1840: 71 76 3f 29 5d 0a 20 20 20 5b 28 6b 20 76 20 6c qv?)]. [(k v l
1850: 73 74 20 63 6d 70 29 0a 20 20 20 20 28 6c 65 74 st cmp). (let
1860: 20 6c 6f 6f 70 20 28 28 6c 73 74 20 6c 73 74 29 loop ((lst lst)
1870: 29 0a 20 20 20 20 20 20 28 63 6f 6e 64 20 28 28 ). (cond ((
1880: 6e 75 6c 6c 3f 20 6c 73 74 29 0a 09 20 20 20 20 null? lst)..
1890: 20 28 6c 69 73 74 20 28 63 6f 6e 73 20 6b 20 76 (list (cons k v
18a0: 29 29 29 0a 09 20 20 20 20 28 28 6e 6f 74 20 28 ))).. ((not (
18b0: 70 61 69 72 3f 20 6c 73 74 29 29 0a 09 20 20 20 pair? lst))..
18c0: 20 20 28 65 72 72 6f 72 20 27 61 6c 69 73 74 2d (error 'alist-
18d0: 75 70 64 61 74 65 20 22 62 61 64 20 61 72 67 75 update "bad argu
18e0: 6d 65 6e 74 20 74 79 70 65 22 20 6c 73 74 29 29 ment type" lst))
18f0: 0a 09 20 20 20 20 28 65 6c 73 65 0a 09 20 20 20 .. (else..
1900: 20 20 28 6c 65 74 20 28 28 61 20 28 63 61 72 20 (let ((a (car
1910: 6c 73 74 29 29 29 0a 09 20 20 20 20 20 20 20 28 lst))).. (
1920: 63 6f 6e 64 20 28 28 6e 6f 74 20 28 70 61 69 72 cond ((not (pair
1930: 3f 20 61 29 29 0a 20 20 20 20 20 20 20 20 20 20 ? a)).
1940: 20 20 20 20 20 20 20 20 20 20 28 65 72 72 6f 72 (error
1950: 20 27 61 6c 69 73 74 2d 75 70 64 61 74 65 20 22 'alist-update "
1960: 62 61 64 20 61 72 67 75 6d 65 6e 74 20 74 79 70 bad argument typ
1970: 65 22 20 61 29 29 0a 20 20 20 20 20 20 20 20 20 e" a)).
1980: 20 20 20 20 20 20 20 20 20 20 28 28 63 6d 70 20 ((cmp
1990: 28 63 61 72 20 61 29 20 6b 29 0a 20 20 20 20 20 (car a) k).
19a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
19b0: 63 6f 6e 73 20 28 63 6f 6e 73 20 6b 20 76 29 20 cons (cons k v)
19c0: 28 63 64 72 20 6c 73 74 29 29 29 0a 20 20 20 20 (cdr lst))).
19d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
19e0: 65 6c 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 else.
19f0: 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 28 (cons (
1a00: 63 6f 6e 73 20 28 63 61 72 20 61 29 20 28 63 64 cons (car a) (cd
1a10: 72 20 61 29 29 0a 20 20 20 20 20 20 20 20 20 20 r a)).
1a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1a30: 28 6c 6f 6f 70 20 28 63 64 72 20 6c 73 74 29 29 (loop (cdr lst))
1a40: 29 29 29 29 29 29 29 5d 29 29 0a 28 64 65 66 69 )))))))])).(defi
1a50: 6e 65 20 61 6c 69 73 74 2d 72 65 66 0a 20 20 28 ne alist-ref. (
1a60: 63 61 73 65 2d 6c 61 6d 62 64 61 20 0a 20 20 20 case-lambda .
1a70: 5b 28 78 20 6c 73 74 29 0a 20 20 20 20 28 61 6c [(x lst). (al
1a80: 69 73 74 2d 72 65 66 20 78 20 6c 73 74 20 65 71 ist-ref x lst eq
1a90: 76 3f 29 5d 0a 20 20 20 5b 28 78 20 6c 73 74 20 v?)]. [(x lst
1aa0: 63 6d 70 29 0a 20 20 20 20 28 61 6c 69 73 74 2d cmp). (alist-
1ab0: 72 65 66 20 78 20 6c 73 74 20 63 6d 70 20 23 66 ref x lst cmp #f
1ac0: 29 5d 0a 20 20 20 5b 28 78 20 6c 73 74 20 63 6d )]. [(x lst cm
1ad0: 70 20 64 65 66 61 75 6c 74 29 0a 20 20 20 20 28 p default). (
1ae0: 6c 65 74 2a 20 28 5b 61 71 20 28 63 6f 6e 64 20 let* ([aq (cond
1af0: 5b 28 65 71 3f 20 65 71 3f 20 63 6d 70 29 20 61 [(eq? eq? cmp) a
1b00: 73 73 71 5d 0a 09 09 20 20 20 20 20 5b 28 65 71 ssq]... [(eq
1b10: 3f 20 65 71 76 3f 20 63 6d 70 29 20 61 73 73 76 ? eqv? cmp) assv
1b20: 5d 0a 09 09 20 20 20 20 20 5b 28 65 71 3f 20 65 ]... [(eq? e
1b30: 71 75 61 6c 3f 20 63 6d 70 29 20 61 73 73 6f 63 qual? cmp) assoc
1b40: 5d 0a 09 09 20 20 20 20 20 5b 65 6c 73 65 20 0a ]... [else .
1b50: 09 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 .. (lambda
1b60: 28 78 20 6c 73 74 29 0a 09 09 09 28 6c 65 74 20 (x lst)....(let
1b70: 6c 6f 6f 70 20 28 5b 6c 73 74 20 6c 73 74 5d 29 loop ([lst lst])
1b80: 0a 09 09 09 20 20 28 61 6e 64 20 28 70 61 69 72 .... (and (pair
1b90: 3f 20 6c 73 74 29 0a 09 09 09 20 20 20 20 20 20 ? lst)....
1ba0: 20 28 6c 65 74 20 28 5b 61 20 28 63 61 72 20 20 (let ([a (car
1bb0: 6c 73 74 20 29 5d 29 0a 09 09 09 09 20 28 69 66 lst )])..... (if
1bc0: 20 28 61 6e 64 20 28 70 61 69 72 3f 20 61 29 20 (and (pair? a)
1bd0: 28 63 6d 70 20 28 63 61 72 20 20 61 20 29 20 78 (cmp (car a ) x
1be0: 29 29 0a 09 09 09 09 20 20 20 20 20 61 0a 09 09 ))..... a...
1bf0: 09 09 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 64 .. (loop (cd
1c00: 72 20 20 6c 73 74 20 29 29 20 29 20 29 20 29 20 r lst )) ) ) )
1c10: 29 20 29 20 5d 20 29 20 5d 20 0a 09 20 5b 69 74 ) ) ] ) ] .. [it
1c20: 65 6d 20 28 61 71 20 78 20 6c 73 74 29 5d 20 29 em (aq x lst)] )
1c30: 0a 20 20 20 20 28 69 66 20 69 74 65 6d 0a 09 28 . (if item..(
1c40: 63 64 72 20 20 69 74 65 6d 20 29 0a 09 64 65 66 cdr item )..def
1c50: 61 75 6c 74 29 20 29 20 5d 29 29 0a 0a 28 64 65 ault) ) ]))..(de
1c60: 66 69 6e 65 20 28 72 61 73 73 6f 63 20 78 20 6c fine (rassoc x l
1c70: 73 74 20 2e 20 74 73 74 29 0a 20 20 28 61 73 73 st . tst). (ass
1c80: 65 72 74 20 28 61 6e 64 20 27 72 61 73 73 6f 63 ert (and 'rassoc
1c90: 20 28 6c 69 73 74 3f 20 6c 73 74 29 29 29 0a 20 (list? lst))).
1ca0: 20 28 6c 65 74 20 28 5b 74 73 74 20 28 69 66 20 (let ([tst (if
1cb0: 28 70 61 69 72 3f 20 74 73 74 29 20 28 63 61 72 (pair? tst) (car
1cc0: 20 74 73 74 29 20 65 71 76 3f 29 5d 29 0a 20 20 tst) eqv?)]).
1cd0: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 5b 6c 20 (let loop ([l
1ce0: 6c 73 74 5d 29 0a 20 20 20 20 20 20 28 61 6e 64 lst]). (and
1cf0: 20 28 70 61 69 72 3f 20 6c 29 0a 09 20 20 20 28 (pair? l).. (
1d00: 6c 65 74 20 28 5b 61 20 28 63 61 72 20 20 6c 20 let ([a (car l
1d10: 29 5d 29 0a 09 20 20 20 20 20 28 61 73 73 65 72 )]).. (asser
1d20: 74 20 28 61 6e 64 20 27 72 61 73 73 6f 63 20 28 t (and 'rassoc (
1d30: 70 61 69 72 3f 20 61 29 29 29 0a 09 20 20 20 20 pair? a)))..
1d40: 20 28 69 66 20 28 74 73 74 20 78 20 28 63 64 72 (if (tst x (cdr
1d50: 20 20 61 20 29 29 0a 09 09 20 61 0a 09 09 20 28 a ))... a... (
1d60: 6c 6f 6f 70 20 28 63 64 72 20 20 6c 20 29 29 20 loop (cdr l ))
1d70: 29 20 29 20 29 20 29 20 29 20 29 0a 0a 0a 0a 3b ) ) ) ) ) )....;
1d80: 20 28 72 65 76 65 72 73 65 2d 73 74 72 69 6e 67 (reverse-string
1d90: 2d 61 70 70 65 6e 64 20 6c 29 20 3d 20 28 61 70 -append l) = (ap
1da0: 70 6c 79 20 73 74 72 69 6e 67 2d 61 70 70 65 6e ply string-appen
1db0: 64 20 28 72 65 76 65 72 73 65 20 6c 29 29 0a 0a d (reverse l))..
1dc0: 28 64 65 66 69 6e 65 20 28 72 65 76 65 72 73 65 (define (reverse
1dd0: 2d 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 6c -string-append l
1de0: 29 0a 20 20 28 64 65 66 69 6e 65 20 28 72 65 76 ). (define (rev
1df0: 2d 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 6c -string-append l
1e00: 20 69 29 0a 20 20 20 20 28 69 66 20 28 70 61 69 i). (if (pai
1e10: 72 3f 20 6c 29 0a 20 20 20 20 20 20 28 6c 65 74 r? l). (let
1e20: 2a 20 28 28 73 74 72 20 28 63 61 72 20 6c 29 29 * ((str (car l))
1e30: 0a 09 20 20 20 20 20 28 6c 65 6e 20 28 73 74 72 .. (len (str
1e40: 69 6e 67 2d 6c 65 6e 67 74 68 20 73 74 72 29 29 ing-length str))
1e50: 0a 09 20 20 20 20 20 28 72 65 73 75 6c 74 20 28 .. (result (
1e60: 72 65 76 2d 73 74 72 69 6e 67 2d 61 70 70 65 6e rev-string-appen
1e70: 64 20 28 63 64 72 20 6c 29 20 28 66 78 2b 20 69 d (cdr l) (fx+ i
1e80: 20 6c 65 6e 29 29 29 29 0a 09 28 6c 65 74 20 6c len))))..(let l
1e90: 6f 6f 70 20 28 28 6a 20 30 29 20 28 6b 20 28 66 oop ((j 0) (k (f
1ea0: 78 2d 20 28 66 78 2d 20 28 73 74 72 69 6e 67 2d x- (fx- (string-
1eb0: 6c 65 6e 67 74 68 20 72 65 73 75 6c 74 29 20 69 length result) i
1ec0: 29 20 6c 65 6e 29 29 29 0a 09 20 20 28 69 66 20 ) len))).. (if
1ed0: 28 66 78 3c 20 6a 20 6c 65 6e 29 0a 09 20 20 20 (fx< j len)..
1ee0: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 (begin.. (
1ef0: 73 74 72 69 6e 67 2d 73 65 74 21 20 72 65 73 75 string-set! resu
1f00: 6c 74 20 6b 20 28 73 74 72 69 6e 67 2d 72 65 66 lt k (string-ref
1f10: 20 73 74 72 20 6a 29 29 0a 09 20 20 20 20 20 20 str j))..
1f20: 28 6c 6f 6f 70 20 28 66 78 2b 20 6a 20 31 29 20 (loop (fx+ j 1)
1f30: 28 66 78 2b 20 6b 20 31 29 29 29 0a 09 20 20 20 (fx+ k 1)))..
1f40: 20 72 65 73 75 6c 74 29 29 29 0a 20 20 20 20 20 result))).
1f50: 20 28 6d 61 6b 65 2d 73 74 72 69 6e 67 20 69 29 (make-string i)
1f60: 29 29 0a 20 20 28 72 65 76 2d 73 74 72 69 6e 67 )). (rev-string
1f70: 2d 61 70 70 65 6e 64 20 6c 20 30 29 29 0a 0a 3b -append l 0))..;
1f80: 3b 3b 20 41 6e 79 74 68 69 6e 67 2d 3e 73 74 72 ;; Anything->str
1f90: 69 6e 67 20 63 6f 6e 76 65 72 73 69 6f 6e 3a 0a ing conversion:.
1fa0: 0a 28 64 65 66 69 6e 65 20 2d 3e 73 74 72 69 6e .(define ->strin
1fb0: 67 20 0a 20 20 28 6c 61 6d 62 64 61 20 28 78 29 g . (lambda (x)
1fc0: 0a 20 20 20 20 28 63 6f 6e 64 20 5b 28 73 74 72 . (cond [(str
1fd0: 69 6e 67 3f 20 78 29 20 78 5d 0a 09 20 20 5b 28 ing? x) x].. [(
1fe0: 73 79 6d 62 6f 6c 3f 20 78 29 20 28 73 79 6d 62 symbol? x) (symb
1ff0: 6f 6c 2d 3e 73 74 72 69 6e 67 20 78 29 5d 0a 09 ol->string x)]..
2000: 20 20 5b 28 63 68 61 72 3f 20 78 29 20 28 73 74 [(char? x) (st
2010: 72 69 6e 67 20 78 29 5d 0a 09 20 20 5b 28 6e 75 ring x)].. [(nu
2020: 6d 62 65 72 3f 20 78 29 20 28 6e 75 6d 62 65 72 mber? x) (number
2030: 2d 3e 73 74 72 69 6e 67 20 78 29 5d 0a 09 20 20 ->string x)]..
2040: 5b 65 6c 73 65 20 0a 09 20 20 20 28 6c 65 74 20 [else .. (let
2050: 28 5b 6f 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 ([o (open-output
2060: 2d 73 74 72 69 6e 67 29 5d 29 0a 09 20 20 20 20 -string)])..
2070: 20 28 64 69 73 70 6c 61 79 20 78 20 6f 29 0a 09 (display x o)..
2080: 20 20 20 20 20 28 67 65 74 2d 6f 75 74 70 75 74 (get-output
2090: 2d 73 74 72 69 6e 67 20 6f 29 20 29 20 5d 20 29 -string o) ) ] )
20a0: 20 29 20 29 0a 0a 28 64 65 66 69 6e 65 20 63 6f ) )..(define co
20b0: 6e 63 0a 20 20 28 6c 61 6d 62 64 61 20 61 72 67 nc. (lambda arg
20c0: 73 0a 20 20 20 20 28 61 70 70 6c 79 20 73 74 72 s. (apply str
20d0: 69 6e 67 2d 61 70 70 65 6e 64 20 28 6d 61 70 20 ing-append (map
20e0: 2d 3e 73 74 72 69 6e 67 20 61 72 67 73 29 29 20 ->string args))
20f0: 29 20 29 0a 0a 0a 0a 3b 3b 3b 20 43 6f 6e 63 61 ) )....;;; Conca
2100: 74 65 6e 61 74 65 20 6c 69 73 74 20 6f 66 20 73 tenate list of s
2110: 74 72 69 6e 67 73 3a 0a 0a 28 64 65 66 69 6e 65 trings:..(define
2120: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
2130: 65 72 73 65 20 73 74 72 73 20 64 73 29 0a 20 20 erse strs ds).
2140: 28 61 73 73 65 72 74 20 28 61 6e 64 20 27 73 74 (assert (and 'st
2150: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
2160: 20 28 6c 69 73 74 3f 20 73 74 72 73 29 29 29 0a (list? strs))).
2170: 20 20 28 61 73 73 65 72 74 20 28 61 6e 64 20 27 (assert (and '
2180: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
2190: 73 65 20 28 73 74 72 69 6e 67 3f 20 64 73 29 29 se (string? ds))
21a0: 29 0a 20 20 28 6c 65 74 20 28 28 64 73 6c 65 6e ). (let ((dslen
21b0: 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 (string-length
21c0: 64 73 29 29 29 0a 20 20 20 20 28 6c 65 74 20 6c ds))). (let l
21d0: 6f 6f 70 31 20 28 28 73 73 20 73 74 72 73 29 20 oop1 ((ss strs)
21e0: 28 6e 20 30 29 29 0a 20 20 20 20 20 20 28 69 66 (n 0)). (if
21f0: 20 28 6e 75 6c 6c 3f 20 73 73 29 20 22 22 0a 09 (null? ss) ""..
2200: 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 (string-append
2210: 20 28 63 61 72 20 73 73 29 0a 09 09 09 20 28 69 (car ss).... (i
2220: 66 20 28 6e 75 6c 6c 3f 20 28 63 64 72 20 73 73 f (null? (cdr ss
2230: 29 29 20 22 22 0a 09 09 09 20 20 20 20 20 28 73 )) "".... (s
2240: 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 64 73 0a tring-append ds.
2250: 09 09 09 09 09 20 20 20 20 28 6c 6f 6f 70 31 20 ..... (loop1
2260: 28 63 64 72 20 73 73 29 20 28 2b 20 6e 20 31 29 (cdr ss) (+ n 1)
2270: 20 29 29 29 29 29 29 29 29 0a 0a 0a 28 64 65 66 ))))))))...(def
2280: 69 6e 65 20 28 73 74 72 69 6e 67 2d 74 72 61 6e ine (string-tran
2290: 73 6c 61 74 65 2a 20 73 74 72 20 73 6d 61 70 29 slate* str smap)
22a0: 0a 20 20 28 69 6d 70 6f 72 74 20 28 6f 6e 6c 79 . (import (only
22b0: 20 28 73 72 66 69 20 73 31 33 20 73 74 72 69 6e (srfi s13 strin
22c0: 67 73 29 20 73 74 72 69 6e 67 3d 29 29 0a 20 20 gs) string=)).
22d0: 28 61 73 73 65 72 74 20 28 61 6e 64 20 27 73 74 (assert (and 'st
22e0: 72 69 6e 67 2d 74 72 61 6e 73 6c 61 74 65 2a 20 ring-translate*
22f0: 28 6c 69 73 74 3f 20 73 6d 61 70 29 29 29 0a 20 (list? smap))).
2300: 20 28 61 73 73 65 72 74 20 28 61 6e 64 20 27 73 (assert (and 's
2310: 74 72 69 6e 67 2d 74 72 61 6e 73 6c 61 74 65 2a tring-translate*
2320: 20 28 73 74 72 69 6e 67 3f 20 73 74 72 29 29 29 (string? str)))
2330: 0a 20 20 28 6c 65 74 20 28 5b 6c 65 6e 20 28 73 . (let ([len (s
2340: 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 73 74 72 tring-length str
2350: 29 5d 29 0a 20 20 20 20 28 64 65 66 69 6e 65 20 )]). (define
2360: 28 63 6f 6c 6c 65 63 74 20 69 20 66 72 6f 6d 20 (collect i from
2370: 74 6f 74 61 6c 20 66 73 29 0a 20 20 20 20 20 20 total fs).
2380: 28 69 66 20 28 66 78 3e 3d 20 69 20 6c 65 6e 29 (if (fx>= i len)
2390: 0a 09 20 20 28 61 70 70 6c 79 20 73 74 72 69 6e .. (apply strin
23a0: 67 2d 61 70 70 65 6e 64 0a 09 09 20 28 72 65 76 g-append... (rev
23b0: 65 72 73 65 0a 09 09 20 20 28 69 66 20 28 66 78 erse... (if (fx
23c0: 3e 20 69 20 66 72 6f 6d 29 20 0a 09 09 20 20 20 > i from) ...
23d0: 20 20 20 28 63 6f 6e 73 20 28 73 75 62 73 74 72 (cons (substr
23e0: 69 6e 67 20 73 74 72 20 66 72 6f 6d 20 69 29 20 ing str from i)
23f0: 66 73 29 0a 09 09 20 20 20 20 20 20 66 73 29 20 fs)... fs)
2400: 29 20 29 0a 09 20 20 28 6c 65 74 20 6c 6f 6f 70 ) ).. (let loop
2410: 20 28 5b 73 6d 61 70 20 73 6d 61 70 5d 29 0a 09 ([smap smap])..
2420: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 73 (if (null? s
2430: 6d 61 70 29 20 0a 09 09 28 63 6f 6c 6c 65 63 74 map) ...(collect
2440: 20 28 66 78 2b 20 69 20 31 29 20 66 72 6f 6d 20 (fx+ i 1) from
2450: 28 66 78 2b 20 74 6f 74 61 6c 20 31 29 20 66 73 (fx+ total 1) fs
2460: 29 0a 09 09 0a 09 09 28 6c 65 74 2a 20 28 5b 70 )......(let* ([p
2470: 20 28 63 61 72 20 73 6d 61 70 29 5d 0a 09 09 20 (car smap)]...
2480: 20 20 20 20 20 20 5b 73 6d 20 28 63 61 72 20 70 [sm (car p
2490: 29 5d 0a 09 09 20 20 20 20 20 20 20 5b 73 6d 6c )]... [sml
24a0: 65 6e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 en (string-lengt
24b0: 68 20 73 6d 29 5d 0a 09 09 20 20 20 20 20 20 20 h sm)]...
24c0: 5b 73 74 20 28 63 64 72 20 70 29 5d 20 29 0a 09 [st (cdr p)] )..
24d0: 09 20 20 28 69 66 20 28 73 74 72 69 6e 67 3d 20 . (if (string=
24e0: 73 74 72 20 73 6d 20 69 20 20 28 6d 69 6e 20 28 str sm i (min (
24f0: 2b 20 69 20 73 6d 6c 65 6e 29 20 6c 65 6e 29 20 + i smlen) len)
2500: 30 20 73 6d 6c 65 6e 29 0a 09 09 20 20 20 20 20 0 smlen)...
2510: 20 28 6c 65 74 20 28 5b 69 32 20 28 66 78 2b 20 (let ([i2 (fx+
2520: 69 20 73 6d 6c 65 6e 29 5d 29 0a 09 09 09 28 77 i smlen)])....(w
2530: 68 65 6e 20 28 66 78 3e 20 69 20 66 72 6f 6d 29 hen (fx> i from)
2540: 0a 09 09 09 20 20 28 73 65 74 21 20 66 73 20 28 .... (set! fs (
2550: 63 6f 6e 73 20 28 73 75 62 73 74 72 69 6e 67 20 cons (substring
2560: 73 74 72 20 66 72 6f 6d 20 69 29 20 66 73 29 29 str from i) fs))
2570: 20 29 0a 09 09 09 28 63 6f 6c 6c 65 63 74 20 0a )....(collect .
2580: 09 09 09 20 69 32 20 69 32 0a 09 09 09 20 28 66 ... i2 i2.... (f
2590: 78 2b 20 74 6f 74 61 6c 20 28 73 74 72 69 6e 67 x+ total (string
25a0: 2d 6c 65 6e 67 74 68 20 73 74 29 29 0a 09 09 09 -length st))....
25b0: 20 28 63 6f 6e 73 20 73 74 20 66 73 29 20 29 20 (cons st fs) )
25c0: 29 20 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 ) ... (loop
25d0: 20 28 63 64 72 20 73 6d 61 70 29 29 20 29 20 29 (cdr smap)) ) )
25e0: 20 29 20 29 20 29 20 29 0a 20 20 20 20 28 63 6f ) ) ) ). (co
25f0: 6c 6c 65 63 74 20 30 20 30 20 30 20 27 28 29 29 llect 0 0 0 '())
2600: 20 29 20 29 0a 0a 3b 3b 3b 20 43 68 6f 70 20 73 ) )..;;; Chop s
2610: 74 72 69 6e 67 20 69 6e 74 6f 20 73 75 62 73 74 tring into subst
2620: 72 69 6e 67 73 3a 0a 0a 28 64 65 66 69 6e 65 20 rings:..(define
2630: 28 73 74 72 69 6e 67 2d 63 68 6f 70 20 73 74 72 (string-chop str
2640: 20 6c 65 6e 29 0a 20 20 28 61 73 73 65 72 74 20 len). (assert
2650: 28 61 6e 64 20 27 73 74 72 69 6e 67 2d 63 68 6f (and 'string-cho
2660: 70 20 28 65 78 61 63 74 3f 20 6c 65 6e 29 29 29 p (exact? len)))
2670: 0a 20 20 28 61 73 73 65 72 74 20 28 61 6e 64 20 . (assert (and
2680: 27 73 74 72 69 6e 67 2d 63 68 6f 70 20 28 73 74 'string-chop (st
2690: 72 69 6e 67 3f 20 73 74 72 29 29 29 0a 20 20 28 ring? str))). (
26a0: 6c 65 74 20 28 5b 74 6f 74 61 6c 20 28 73 74 72 let ([total (str
26b0: 69 6e 67 2d 6c 65 6e 67 74 68 20 73 74 72 29 5d ing-length str)]
26c0: 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 ). (let loop
26d0: 28 5b 74 6f 74 61 6c 20 74 6f 74 61 6c 5d 20 5b ([total total] [
26e0: 70 6f 73 20 30 5d 29 0a 20 20 20 20 20 20 28 63 pos 0]). (c
26f0: 6f 6e 64 20 5b 28 66 78 3c 3d 20 74 6f 74 61 6c ond [(fx<= total
2700: 20 30 29 20 27 28 29 5d 0a 09 20 20 20 20 5b 28 0) '()].. [(
2710: 66 78 3c 3d 20 74 6f 74 61 6c 20 6c 65 6e 29 20 fx<= total len)
2720: 28 6c 69 73 74 20 28 73 75 62 73 74 72 69 6e 67 (list (substring
2730: 20 73 74 72 20 70 6f 73 20 28 66 78 2b 20 70 6f str pos (fx+ po
2740: 73 20 74 6f 74 61 6c 29 29 29 5d 0a 09 20 20 20 s total)))]..
2750: 20 5b 65 6c 73 65 20 28 63 6f 6e 73 20 28 73 75 [else (cons (su
2760: 62 73 74 72 69 6e 67 20 73 74 72 20 70 6f 73 20 bstring str pos
2770: 28 66 78 2b 20 70 6f 73 20 6c 65 6e 29 29 20 28 (fx+ pos len)) (
2780: 6c 6f 6f 70 20 28 66 78 2d 20 74 6f 74 61 6c 20 loop (fx- total
2790: 6c 65 6e 29 20 28 66 78 2b 20 70 6f 73 20 6c 65 len) (fx+ pos le
27a0: 6e 29 29 29 5d 20 29 20 29 20 29 20 29 0a 0a 0a n)))] ) ) ) )...
27b0: 0a 3b 3b 3b 20 44 65 66 69 6e 65 73 3a 20 73 6f .;;; Defines: so
27c0: 72 74 65 64 3f 2c 20 6d 65 72 67 65 2c 20 6d 65 rted?, merge, me
27d0: 72 67 65 21 2c 20 73 6f 72 74 2c 20 73 6f 72 74 rge!, sort, sort
27e0: 21 0a 3b 3b 3b 20 41 75 74 68 6f 72 20 3a 20 52 !.;;; Author : R
27f0: 69 63 68 61 72 64 20 41 2e 20 4f 27 4b 65 65 66 ichard A. O'Keef
2800: 65 20 28 62 61 73 65 64 20 6f 6e 20 50 72 6f 6c e (based on Prol
2810: 6f 67 20 63 6f 64 65 20 62 79 20 44 2e 48 2e 44 og code by D.H.D
2820: 2e 57 61 72 72 65 6e 29 0a 3b 3b 3b 0a 3b 3b 3b .Warren).;;;.;;;
2830: 20 54 68 69 73 20 63 6f 64 65 20 69 73 20 69 6e This code is in
2840: 20 74 68 65 20 70 75 62 6c 69 63 20 64 6f 6d 61 the public doma
2850: 69 6e 2e 0a 0a 3b 3b 3b 20 55 70 64 61 74 65 64 in...;;; Updated
2860: 3a 20 31 31 20 4a 75 6e 65 20 31 39 39 31 0a 3b : 11 June 1991.;
2870: 3b 3b 20 4d 6f 64 69 66 69 65 64 20 66 6f 72 20 ;; Modified for
2880: 73 63 68 65 6d 65 20 6c 69 62 72 61 72 79 3a 20 scheme library:
2890: 41 75 62 72 65 79 20 4a 61 66 66 65 72 20 31 39 Aubrey Jaffer 19
28a0: 20 53 65 70 74 2e 20 31 39 39 31 0a 3b 3b 3b 20 Sept. 1991.;;;
28b0: 55 70 64 61 74 65 64 3a 20 31 39 20 4a 75 6e 65 Updated: 19 June
28c0: 20 31 39 39 35 0a 0a 3b 3b 3b 20 28 73 6f 72 74 1995..;;; (sort
28d0: 65 64 3f 20 73 65 71 75 65 6e 63 65 20 6c 65 73 ed? sequence les
28e0: 73 3f 29 0a 3b 3b 3b 20 69 73 20 74 72 75 65 20 s?).;;; is true
28f0: 77 68 65 6e 20 73 65 71 75 65 6e 63 65 20 69 73 when sequence is
2900: 20 61 20 6c 69 73 74 20 28 78 30 20 78 31 20 2e a list (x0 x1 .
2910: 2e 2e 20 78 6d 29 20 6f 72 20 61 20 76 65 63 74 .. xm) or a vect
2920: 6f 72 20 23 28 78 30 20 2e 2e 2e 20 78 6d 29 0a or #(x0 ... xm).
2930: 3b 3b 3b 20 73 75 63 68 20 74 68 61 74 20 66 6f ;;; such that fo
2940: 72 20 61 6c 6c 20 31 20 3c 3d 20 69 20 3c 3d 20 r all 1 <= i <=
2950: 6d 2c 0a 3b 3b 3b 09 28 6e 6f 74 20 28 6c 65 73 m,.;;;.(not (les
2960: 73 3f 20 28 6c 69 73 74 2d 72 65 66 20 6c 69 73 s? (list-ref lis
2970: 74 20 69 29 20 28 6c 69 73 74 2d 72 65 66 20 6c t i) (list-ref l
2980: 69 73 74 20 28 2d 20 69 20 31 29 29 29 29 2e 0a ist (- i 1))))..
2990: 0a 3b 20 4d 6f 64 69 66 69 65 64 20 62 79 20 66 .; Modified by f
29a0: 6c 77 20 66 6f 72 20 75 73 65 20 77 69 74 68 20 lw for use with
29b0: 43 48 49 43 4b 45 4e 3a 0a 3b 0a 0a 0a 28 64 65 CHICKEN:.;...(de
29c0: 66 69 6e 65 20 28 73 6f 72 74 65 64 3f 20 73 65 fine (sorted? se
29d0: 71 20 6c 65 73 73 3f 29 0a 20 20 20 20 28 63 6f q less?). (co
29e0: 6e 64 0a 09 28 28 6e 75 6c 6c 3f 20 73 65 71 29 nd..((null? seq)
29f0: 0a 09 20 20 20 20 23 74 29 0a 09 28 28 76 65 63 .. #t)..((vec
2a00: 74 6f 72 3f 20 73 65 71 29 0a 09 20 20 20 20 28 tor? seq).. (
2a10: 6c 65 74 20 28 28 6e 20 28 76 65 63 74 6f 72 2d let ((n (vector-
2a20: 6c 65 6e 67 74 68 20 73 65 71 29 29 29 0a 09 09 length seq)))...
2a30: 28 69 66 20 28 3c 3d 20 6e 20 31 29 0a 09 09 20 (if (<= n 1)...
2a40: 20 20 20 23 74 0a 09 09 20 20 20 20 28 64 6f 20 #t... (do
2a50: 28 28 69 20 31 20 28 2b 20 69 20 31 29 29 29 0a ((i 1 (+ i 1))).
2a60: 09 09 09 28 28 6f 72 20 28 3d 20 69 20 6e 29 0a ...((or (= i n).
2a70: 09 09 09 20 20 20 20 20 28 6c 65 73 73 3f 20 28 ... (less? (
2a80: 76 65 63 74 6f 72 2d 72 65 66 20 73 65 71 20 69 vector-ref seq i
2a90: 29 0a 09 09 09 09 20 20 20 20 28 76 65 63 74 6f )..... (vecto
2aa0: 72 2d 72 65 66 20 73 65 71 20 28 2d 20 69 20 31 r-ref seq (- i 1
2ab0: 29 29 29 29 0a 09 09 09 20 20 20 20 28 3d 20 69 )))).... (= i
2ac0: 20 6e 29 29 20 29 29 20 29 29 0a 09 28 65 6c 73 n)) )) ))..(els
2ad0: 65 0a 09 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 e.. (let loop
2ae0: 20 28 28 6c 61 73 74 20 28 63 61 72 20 73 65 71 ((last (car seq
2af0: 29 29 20 28 6e 65 78 74 20 28 63 64 72 20 73 65 )) (next (cdr se
2b00: 71 29 29 29 0a 09 09 28 6f 72 20 28 6e 75 6c 6c q)))...(or (null
2b10: 3f 20 6e 65 78 74 29 0a 09 09 20 20 20 20 28 61 ? next)... (a
2b20: 6e 64 20 28 6e 6f 74 20 28 6c 65 73 73 3f 20 28 nd (not (less? (
2b30: 63 61 72 20 6e 65 78 74 29 20 6c 61 73 74 29 29 car next) last))
2b40: 0a 09 09 09 20 28 6c 6f 6f 70 20 28 63 61 72 20 .... (loop (car
2b50: 6e 65 78 74 29 20 28 63 64 72 20 6e 65 78 74 29 next) (cdr next)
2b60: 29 20 29 29 20 29 29 20 29 29 0a 0a 0a 3b 3b 3b ) )) )) ))...;;;
2b70: 20 54 48 45 53 45 20 41 52 45 20 41 4c 52 45 41 THESE ARE ALREA
2b80: 44 59 20 49 4e 20 43 48 45 5a 20 53 43 48 45 4d DY IN CHEZ SCHEM
2b90: 45 0a 0a 3b 3b 20 3b 3b 3b 20 28 6d 65 72 67 65 E..;; ;;; (merge
2ba0: 20 61 20 62 20 6c 65 73 73 3f 29 0a 3b 3b 20 3b a b less?).;; ;
2bb0: 3b 3b 20 74 61 6b 65 73 20 74 77 6f 20 6c 69 73 ;; takes two lis
2bc0: 74 73 20 61 20 61 6e 64 20 62 20 73 75 63 68 20 ts a and b such
2bd0: 74 68 61 74 20 28 73 6f 72 74 65 64 3f 20 61 20 that (sorted? a
2be0: 6c 65 73 73 3f 29 20 61 6e 64 20 28 73 6f 72 74 less?) and (sort
2bf0: 65 64 3f 20 62 20 6c 65 73 73 3f 29 0a 3b 3b 20 ed? b less?).;;
2c00: 3b 3b 3b 20 61 6e 64 20 72 65 74 75 72 6e 73 20 ;;; and returns
2c10: 61 20 6e 65 77 20 6c 69 73 74 20 69 6e 20 77 68 a new list in wh
2c20: 69 63 68 20 74 68 65 20 65 6c 65 6d 65 6e 74 73 ich the elements
2c30: 20 6f 66 20 61 20 61 6e 64 20 62 20 68 61 76 65 of a and b have
2c40: 20 62 65 65 6e 20 73 74 61 62 6c 79 0a 3b 3b 20 been stably.;;
2c50: 3b 3b 3b 20 69 6e 74 65 72 6c 65 61 76 65 64 20 ;;; interleaved
2c60: 73 6f 20 74 68 61 74 20 28 73 6f 72 74 65 64 3f so that (sorted?
2c70: 20 28 6d 65 72 67 65 20 61 20 62 20 6c 65 73 73 (merge a b less
2c80: 3f 29 20 6c 65 73 73 3f 29 2e 0a 3b 3b 20 3b 3b ?) less?)..;; ;;
2c90: 3b 20 4e 6f 74 65 3a 20 20 74 68 69 73 20 64 6f ; Note: this do
2ca0: 65 73 20 5f 6e 6f 74 5f 20 61 63 63 65 70 74 20 es _not_ accept
2cb0: 76 65 63 74 6f 72 73 2e 20 20 53 65 65 20 62 65 vectors. See be
2cc0: 6c 6f 77 2e 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 low...;; (define
2cd0: 20 28 6d 65 72 67 65 20 61 20 62 20 6c 65 73 73 (merge a b less
2ce0: 3f 29 0a 3b 3b 20 20 20 20 20 28 63 6f 6e 64 0a ?).;; (cond.
2cf0: 3b 3b 20 09 28 28 6e 75 6c 6c 3f 20 61 29 20 62 ;; .((null? a) b
2d00: 29 0a 3b 3b 20 09 28 28 6e 75 6c 6c 3f 20 62 29 ).;; .((null? b)
2d10: 20 61 29 0a 3b 3b 20 09 28 65 6c 73 65 20 28 6c a).;; .(else (l
2d20: 65 74 20 6c 6f 6f 70 20 28 28 78 20 28 63 61 72 et loop ((x (car
2d30: 20 61 29 29 20 28 61 20 28 63 64 72 20 61 29 29 a)) (a (cdr a))
2d40: 20 28 79 20 28 63 61 72 20 62 29 29 20 28 62 20 (y (car b)) (b
2d50: 28 63 64 72 20 62 29 29 29 0a 3b 3b 20 09 20 20 (cdr b))).;; .
2d60: 20 20 3b 3b 20 54 68 65 20 6c 6f 6f 70 20 68 61 ;; The loop ha
2d70: 6e 64 6c 65 73 20 74 68 65 20 6d 65 72 67 69 6e ndles the mergin
2d80: 67 20 6f 66 20 6e 6f 6e 2d 65 6d 70 74 79 20 6c g of non-empty l
2d90: 69 73 74 73 2e 09 20 49 74 20 68 61 73 0a 3b 3b ists.. It has.;;
2da0: 20 09 20 20 20 20 3b 3b 20 62 65 65 6e 20 77 72 . ;; been wr
2db0: 69 74 74 65 6e 20 74 68 69 73 20 77 61 79 20 74 itten this way t
2dc0: 6f 20 73 61 76 65 20 74 65 73 74 69 6e 67 20 61 o save testing a
2dd0: 6e 64 20 63 61 72 2f 63 64 72 69 6e 67 2e 0a 3b nd car/cdring..;
2de0: 3b 20 09 20 20 20 20 28 69 66 20 28 6c 65 73 73 ; . (if (less
2df0: 3f 20 79 20 78 29 0a 3b 3b 20 09 09 28 69 66 20 ? y x).;; ..(if
2e00: 28 6e 75 6c 6c 3f 20 62 29 0a 3b 3b 20 09 09 20 (null? b).;; ..
2e10: 20 20 20 28 63 6f 6e 73 20 79 20 28 63 6f 6e 73 (cons y (cons
2e20: 20 78 20 61 29 29 0a 3b 3b 20 09 09 20 20 20 20 x a)).;; ..
2e30: 28 63 6f 6e 73 20 79 20 28 6c 6f 6f 70 20 78 20 (cons y (loop x
2e40: 61 20 28 63 61 72 20 62 29 20 28 63 64 72 20 62 a (car b) (cdr b
2e50: 29 29 20 29 29 0a 3b 3b 20 09 09 3b 3b 20 78 20 )) )).;; ..;; x
2e60: 3c 3d 20 79 0a 3b 3b 20 09 09 28 69 66 20 28 6e <= y.;; ..(if (n
2e70: 75 6c 6c 3f 20 61 29 0a 3b 3b 20 09 09 20 20 20 ull? a).;; ..
2e80: 20 28 63 6f 6e 73 20 78 20 28 63 6f 6e 73 20 79 (cons x (cons y
2e90: 20 62 29 29 0a 3b 3b 20 09 09 20 20 20 20 28 63 b)).;; .. (c
2ea0: 6f 6e 73 20 78 20 28 6c 6f 6f 70 20 28 63 61 72 ons x (loop (car
2eb0: 20 61 29 20 28 63 64 72 20 61 29 20 79 20 62 29 a) (cdr a) y b)
2ec0: 29 20 29 29 20 29 29 20 29 29 0a 0a 0a 3b 3b 20 ) )) )) ))...;;
2ed0: 3b 3b 3b 20 28 6d 65 72 67 65 21 20 61 20 62 20 ;;; (merge! a b
2ee0: 6c 65 73 73 3f 29 0a 3b 3b 20 3b 3b 3b 20 74 61 less?).;; ;;; ta
2ef0: 6b 65 73 20 74 77 6f 20 73 6f 72 74 65 64 20 6c kes two sorted l
2f00: 69 73 74 73 20 61 20 61 6e 64 20 62 20 61 6e 64 ists a and b and
2f10: 20 73 6d 61 73 68 65 73 20 74 68 65 69 72 20 63 smashes their c
2f20: 64 72 20 66 69 65 6c 64 73 20 74 6f 20 66 6f 72 dr fields to for
2f30: 6d 20 61 0a 3b 3b 20 3b 3b 3b 20 73 69 6e 67 6c m a.;; ;;; singl
2f40: 65 20 73 6f 72 74 65 64 20 6c 69 73 74 20 69 6e e sorted list in
2f50: 63 6c 75 64 69 6e 67 20 74 68 65 20 65 6c 65 6d cluding the elem
2f60: 65 6e 74 73 20 6f 66 20 62 6f 74 68 2e 0a 3b 3b ents of both..;;
2f70: 20 3b 3b 3b 20 4e 6f 74 65 3a 20 20 74 68 69 73 ;;; Note: this
2f80: 20 64 6f 65 73 20 5f 6e 6f 74 5f 20 61 63 63 65 does _not_ acce
2f90: 70 74 20 76 65 63 74 6f 72 73 2e 0a 0a 3b 3b 20 pt vectors...;;
2fa0: 28 64 65 66 69 6e 65 20 28 6d 65 72 67 65 21 20 (define (merge!
2fb0: 61 20 62 20 6c 65 73 73 3f 29 0a 3b 3b 20 20 20 a b less?).;;
2fc0: 20 20 28 64 65 66 69 6e 65 20 28 6c 6f 6f 70 20 (define (loop
2fd0: 72 20 61 20 62 29 0a 3b 3b 20 09 28 69 66 20 28 r a b).;; .(if (
2fe0: 6c 65 73 73 3f 20 28 63 61 72 20 62 29 20 28 63 less? (car b) (c
2ff0: 61 72 20 61 29 29 0a 3b 3b 20 09 20 20 20 20 28 ar a)).;; . (
3000: 62 65 67 69 6e 0a 3b 3b 20 09 09 28 73 65 74 2d begin.;; ..(set-
3010: 63 64 72 21 20 72 20 62 29 0a 3b 3b 20 09 09 28 cdr! r b).;; ..(
3020: 69 66 20 28 6e 75 6c 6c 3f 20 28 63 64 72 20 62 if (null? (cdr b
3030: 29 29 0a 3b 3b 20 09 09 20 20 20 20 28 73 65 74 )).;; .. (set
3040: 2d 63 64 72 21 20 62 20 61 29 0a 3b 3b 20 09 09 -cdr! b a).;; ..
3050: 20 20 20 20 28 6c 6f 6f 70 20 62 20 61 20 28 63 (loop b a (c
3060: 64 72 20 62 29 29 20 29 29 0a 3b 3b 20 09 20 20 dr b)) )).;; .
3070: 20 20 3b 3b 20 28 63 61 72 20 61 29 20 3c 3d 20 ;; (car a) <=
3080: 28 63 61 72 20 62 29 0a 3b 3b 20 09 20 20 20 20 (car b).;; .
3090: 28 62 65 67 69 6e 0a 3b 3b 20 09 09 28 73 65 74 (begin.;; ..(set
30a0: 2d 63 64 72 21 20 72 20 61 29 0a 3b 3b 20 09 09 -cdr! r a).;; ..
30b0: 28 69 66 20 28 6e 75 6c 6c 3f 20 28 63 64 72 20 (if (null? (cdr
30c0: 61 29 29 0a 3b 3b 20 09 09 20 20 20 20 28 73 65 a)).;; .. (se
30d0: 74 2d 63 64 72 21 20 61 20 62 29 0a 3b 3b 20 09 t-cdr! a b).;; .
30e0: 09 20 20 20 20 28 6c 6f 6f 70 20 61 20 28 63 64 . (loop a (cd
30f0: 72 20 61 29 20 62 29 29 20 29 29 20 29 0a 3b 3b r a) b)) )) ).;;
3100: 20 20 20 20 20 28 63 6f 6e 64 0a 3b 3b 20 09 28 (cond.;; .(
3110: 28 6e 75 6c 6c 3f 20 61 29 20 62 29 0a 3b 3b 20 (null? a) b).;;
3120: 09 28 28 6e 75 6c 6c 3f 20 62 29 20 61 29 0a 3b .((null? b) a).;
3130: 3b 20 09 28 28 6c 65 73 73 3f 20 28 63 61 72 20 ; .((less? (car
3140: 62 29 20 28 63 61 72 20 61 29 29 0a 3b 3b 20 09 b) (car a)).;; .
3150: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 28 (if (null? (
3160: 63 64 72 20 62 29 29 0a 3b 3b 20 09 09 28 73 65 cdr b)).;; ..(se
3170: 74 2d 63 64 72 21 20 62 20 61 29 0a 3b 3b 20 09 t-cdr! b a).;; .
3180: 09 28 6c 6f 6f 70 20 62 20 61 20 28 63 64 72 20 .(loop b a (cdr
3190: 62 29 29 29 0a 3b 3b 20 09 20 20 20 20 62 29 0a b))).;; . b).
31a0: 3b 3b 20 09 28 65 6c 73 65 20 3b 20 28 63 61 72 ;; .(else ; (car
31b0: 20 61 29 20 3c 3d 20 28 63 61 72 20 62 29 0a 3b a) <= (car b).;
31c0: 3b 20 09 20 20 20 20 28 69 66 20 28 6e 75 6c 6c ; . (if (null
31d0: 3f 20 28 63 64 72 20 61 29 29 0a 3b 3b 20 09 09 ? (cdr a)).;; ..
31e0: 28 73 65 74 2d 63 64 72 21 20 61 20 62 29 0a 3b (set-cdr! a b).;
31f0: 3b 20 09 09 28 6c 6f 6f 70 20 61 20 28 63 64 72 ; ..(loop a (cdr
3200: 20 61 29 20 62 29 29 0a 3b 3b 20 09 20 20 20 20 a) b)).;; .
3210: 61 29 29 29 0a 0a 0a 3b 3b 20 3b 3b 3b 20 28 73 a)))...;; ;;; (s
3220: 6f 72 74 21 20 73 65 71 75 65 6e 63 65 20 6c 65 ort! sequence le
3230: 73 73 3f 29 0a 3b 3b 20 3b 3b 3b 20 73 6f 72 74 ss?).;; ;;; sort
3240: 73 20 74 68 65 20 6c 69 73 74 20 6f 72 20 76 65 s the list or ve
3250: 63 74 6f 72 20 73 65 71 75 65 6e 63 65 20 64 65 ctor sequence de
3260: 73 74 72 75 63 74 69 76 65 6c 79 2e 20 20 49 74 structively. It
3270: 20 75 73 65 73 20 61 20 76 65 72 73 69 6f 6e 0a uses a version.
3280: 3b 3b 20 3b 3b 3b 20 6f 66 20 6d 65 72 67 65 2d ;; ;;; of merge-
3290: 73 6f 72 74 20 69 6e 76 65 6e 74 65 64 2c 20 74 sort invented, t
32a0: 6f 20 74 68 65 20 62 65 73 74 20 6f 66 20 6d 79 o the best of my
32b0: 20 6b 6e 6f 77 6c 65 64 67 65 2c 20 62 79 20 44 knowledge, by D
32c0: 61 76 69 64 20 48 2e 20 44 2e 0a 3b 3b 20 3b 3b avid H. D..;; ;;
32d0: 3b 20 57 61 72 72 65 6e 2c 20 61 6e 64 20 66 69 ; Warren, and fi
32e0: 72 73 74 20 75 73 65 64 20 69 6e 20 74 68 65 20 rst used in the
32f0: 44 45 43 2d 31 30 20 50 72 6f 6c 6f 67 20 73 79 DEC-10 Prolog sy
3300: 73 74 65 6d 2e 09 20 52 2e 20 41 2e 20 4f 27 4b stem.. R. A. O'K
3310: 65 65 66 65 0a 3b 3b 20 3b 3b 3b 20 61 64 61 70 eefe.;; ;;; adap
3320: 74 65 64 20 69 74 20 74 6f 20 77 6f 72 6b 20 64 ted it to work d
3330: 65 73 74 72 75 63 74 69 76 65 6c 79 20 69 6e 20 estructively in
3340: 53 63 68 65 6d 65 2e 0a 0a 3b 3b 20 28 64 65 66 Scheme...;; (def
3350: 69 6e 65 20 28 73 6f 72 74 21 20 73 65 71 20 6c ine (sort! seq l
3360: 65 73 73 3f 29 0a 3b 3b 20 20 20 20 20 28 64 65 ess?).;; (de
3370: 66 69 6e 65 20 28 73 74 65 70 20 6e 29 0a 3b 3b fine (step n).;;
3380: 20 09 28 63 6f 6e 64 0a 3b 3b 20 09 20 20 20 20 .(cond.;; .
3390: 28 28 3e 20 6e 20 32 29 0a 3b 3b 20 09 09 28 6c ((> n 2).;; ..(l
33a0: 65 74 2a 20 28 28 6a 20 28 71 75 6f 74 69 65 6e et* ((j (quotien
33b0: 74 20 6e 20 32 29 29 0a 3b 3b 20 09 09 20 20 20 t n 2)).;; ..
33c0: 20 20 20 20 28 61 20 28 73 74 65 70 20 6a 29 29 (a (step j))
33d0: 0a 3b 3b 20 09 09 20 20 20 20 20 20 20 28 6b 20 .;; .. (k
33e0: 28 2d 20 6e 20 6a 29 29 0a 3b 3b 20 09 09 20 20 (- n j)).;; ..
33f0: 20 20 20 20 20 28 62 20 28 73 74 65 70 20 6b 29 (b (step k)
3400: 29 29 0a 3b 3b 20 09 09 20 20 20 20 28 6d 65 72 )).;; .. (mer
3410: 67 65 21 20 61 20 62 20 6c 65 73 73 3f 29 29 29 ge! a b less?)))
3420: 0a 3b 3b 20 09 20 20 20 20 28 28 3d 20 6e 20 32 .;; . ((= n 2
3430: 29 0a 3b 3b 20 09 09 28 6c 65 74 20 28 28 78 20 ).;; ..(let ((x
3440: 28 63 61 72 20 73 65 71 29 29 0a 3b 3b 20 09 09 (car seq)).;; ..
3450: 20 20 20 20 20 20 28 79 20 28 63 61 64 72 20 73 (y (cadr s
3460: 65 71 29 29 0a 3b 3b 20 09 09 20 20 20 20 20 20 eq)).;; ..
3470: 28 70 20 73 65 71 29 29 0a 3b 3b 20 09 09 20 20 (p seq)).;; ..
3480: 20 20 28 73 65 74 21 20 73 65 71 20 28 63 64 64 (set! seq (cdd
3490: 72 20 73 65 71 29 29 0a 3b 3b 20 09 09 20 20 20 r seq)).;; ..
34a0: 20 28 69 66 20 28 6c 65 73 73 3f 20 79 20 78 29 (if (less? y x)
34b0: 20 28 62 65 67 69 6e 0a 3b 3b 20 09 09 09 28 73 (begin.;; ...(s
34c0: 65 74 2d 63 61 72 21 20 70 20 79 29 0a 3b 3b 20 et-car! p y).;;
34d0: 09 09 09 28 73 65 74 2d 63 61 72 21 20 28 63 64 ...(set-car! (cd
34e0: 72 20 70 29 20 78 29 29 29 0a 3b 3b 20 09 09 20 r p) x))).;; ..
34f0: 20 20 20 28 73 65 74 2d 63 64 72 21 20 28 63 64 (set-cdr! (cd
3500: 72 20 70 29 20 27 28 29 29 0a 3b 3b 20 09 09 20 r p) '()).;; ..
3510: 20 20 20 70 29 29 0a 3b 3b 20 09 20 20 20 20 28 p)).;; . (
3520: 28 3d 20 6e 20 31 29 0a 3b 3b 20 09 09 28 6c 65 (= n 1).;; ..(le
3530: 74 20 28 28 70 20 73 65 71 29 29 0a 3b 3b 20 09 t ((p seq)).;; .
3540: 09 20 20 20 20 28 73 65 74 21 20 73 65 71 20 28 . (set! seq (
3550: 63 64 72 20 73 65 71 29 29 0a 3b 3b 20 09 09 20 cdr seq)).;; ..
3560: 20 20 20 28 73 65 74 2d 63 64 72 21 20 70 20 27 (set-cdr! p '
3570: 28 29 29 0a 3b 3b 20 09 09 20 20 20 20 70 29 29 ()).;; .. p))
3580: 0a 3b 3b 20 09 20 20 20 20 28 65 6c 73 65 0a 3b .;; . (else.;
3590: 3b 20 09 09 27 28 29 29 20 29 29 0a 3b 3b 20 20 ; ..'()) )).;;
35a0: 20 20 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 (if (vector?
35b0: 73 65 71 29 0a 3b 3b 20 09 28 6c 65 74 20 28 28 seq).;; .(let ((
35c0: 6e 20 28 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 n (vector-length
35d0: 20 73 65 71 29 29 0a 3b 3b 20 09 20 20 20 20 20 seq)).;; .
35e0: 20 28 76 65 63 20 73 65 71 29 29 0a 3b 3b 20 09 (vec seq)).;; .
35f0: 20 20 28 73 65 74 21 20 73 65 71 20 28 76 65 63 (set! seq (vec
3600: 74 6f 72 2d 3e 6c 69 73 74 20 73 65 71 29 29 0a tor->list seq)).
3610: 3b 3b 20 09 20 20 28 64 6f 20 28 28 70 20 28 73 ;; . (do ((p (s
3620: 74 65 70 20 6e 29 20 28 63 64 72 20 70 29 29 0a tep n) (cdr p)).
3630: 3b 3b 20 09 20 20 20 20 20 20 20 28 69 20 30 20 ;; . (i 0
3640: 28 2b 20 69 20 31 29 29 29 0a 3b 3b 20 09 20 20 (+ i 1))).;; .
3650: 20 20 20 20 28 28 6e 75 6c 6c 3f 20 70 29 20 76 ((null? p) v
3660: 65 63 29 0a 3b 3b 20 09 20 20 20 20 28 76 65 63 ec).;; . (vec
3670: 74 6f 72 2d 73 65 74 21 20 76 65 63 20 69 20 28 tor-set! vec i (
3680: 63 61 72 20 70 29 29 20 29 29 0a 3b 3b 20 09 3b car p)) )).;; .;
3690: 3b 20 6f 74 68 65 72 77 69 73 65 2c 20 61 73 73 ; otherwise, ass
36a0: 75 6d 65 20 69 74 20 69 73 20 61 20 6c 69 73 74 ume it is a list
36b0: 0a 3b 3b 20 09 28 73 74 65 70 20 28 6c 65 6e 67 .;; .(step (leng
36c0: 74 68 20 73 65 71 29 29 20 29 29 0a 0a 3b 3b 20 th seq)) ))..;;
36d0: 3b 3b 3b 20 28 73 6f 72 74 20 73 65 71 75 65 6e ;;; (sort sequen
36e0: 63 65 20 6c 65 73 73 3f 29 0a 3b 3b 20 3b 3b 3b ce less?).;; ;;;
36f0: 20 73 6f 72 74 73 20 61 20 76 65 63 74 6f 72 20 sorts a vector
3700: 6f 72 20 6c 69 73 74 20 6e 6f 6e 2d 64 65 73 74 or list non-dest
3710: 72 75 63 74 69 76 65 6c 79 2e 20 20 49 74 20 64 ructively. It d
3720: 6f 65 73 20 74 68 69 73 20 62 79 20 73 6f 72 74 oes this by sort
3730: 69 6e 67 20 61 0a 3b 3b 20 3b 3b 3b 20 63 6f 70 ing a.;; ;;; cop
3740: 79 20 6f 66 20 74 68 65 20 73 65 71 75 65 6e 63 y of the sequenc
3750: 65 2e 20 20 4d 79 20 75 6e 64 65 72 73 74 61 6e e. My understan
3760: 64 69 6e 67 20 69 73 20 74 68 61 74 20 74 68 65 ding is that the
3770: 20 53 74 61 6e 64 61 72 64 20 73 61 79 73 0a 3b Standard says.;
3780: 3b 20 3b 3b 3b 20 74 68 61 74 20 74 68 65 20 72 ; ;;; that the r
3790: 65 73 75 6c 74 20 6f 66 20 61 70 70 65 6e 64 20 esult of append
37a0: 69 73 20 61 6c 77 61 79 73 20 22 6e 65 77 6c 79 is always "newly
37b0: 20 61 6c 6c 6f 63 61 74 65 64 22 20 65 78 63 65 allocated" exce
37c0: 70 74 20 66 6f 72 0a 3b 3b 20 3b 3b 3b 20 73 68 pt for.;; ;;; sh
37d0: 61 72 69 6e 67 20 73 74 72 75 63 74 75 72 65 20 aring structure
37e0: 77 69 74 68 20 22 74 68 65 20 6c 61 73 74 20 61 with "the last a
37f0: 72 67 75 6d 65 6e 74 22 2c 20 73 6f 20 28 61 70 rgument", so (ap
3800: 70 65 6e 64 20 78 20 27 28 29 29 20 6f 75 67 68 pend x '()) ough
3810: 74 0a 3b 3b 20 3b 3b 3b 20 74 6f 20 62 65 20 61 t.;; ;;; to be a
3820: 20 73 74 61 6e 64 61 72 64 20 77 61 79 20 6f 66 standard way of
3830: 20 63 6f 70 79 69 6e 67 20 61 20 6c 69 73 74 20 copying a list
3840: 78 2e 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 x...;; (define (
3850: 73 6f 72 74 20 73 65 71 20 6c 65 73 73 3f 29 0a sort seq less?).
3860: 3b 3b 20 20 20 20 20 28 69 66 20 28 76 65 63 74 ;; (if (vect
3870: 6f 72 3f 20 73 65 71 29 0a 3b 3b 20 09 28 6c 69 or? seq).;; .(li
3880: 73 74 2d 3e 76 65 63 74 6f 72 20 28 73 6f 72 74 st->vector (sort
3890: 21 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 ! (vector->list
38a0: 73 65 71 29 20 6c 65 73 73 3f 29 29 0a 3b 3b 20 seq) less?)).;;
38b0: 09 28 73 6f 72 74 21 20 28 61 70 70 65 6e 64 20 .(sort! (append
38c0: 73 65 71 20 27 28 29 29 20 6c 65 73 73 3f 29 29 seq '()) less?))
38d0: 29 0a 0a 0a 3b 3b 20 3b 3b 3b 20 54 6f 70 6f 6c )...;; ;;; Topol
38e0: 6f 67 69 63 61 6c 20 73 6f 72 74 20 77 69 74 68 ogical sort with
38f0: 20 63 79 63 6c 65 20 64 65 74 65 63 74 69 6f 6e cycle detection
3900: 3a 0a 3b 3b 20 3b 3b 0a 3b 3b 20 3b 3b 20 41 20 :.;; ;;.;; ;; A
3910: 66 75 6e 63 74 69 6f 6e 61 6c 20 69 6d 70 6c 65 functional imple
3920: 6d 65 6e 74 61 74 69 6f 6e 20 6f 66 20 74 68 65 mentation of the
3930: 20 61 6c 67 6f 72 69 74 68 6d 20 64 65 73 63 72 algorithm descr
3940: 69 62 65 64 20 69 6e 20 43 6f 72 6d 65 6e 2c 0a ibed in Cormen,.
3950: 3b 3b 20 3b 3b 20 65 74 20 61 6c 2e 20 28 32 30 ;; ;; et al. (20
3960: 30 39 29 2c 20 49 6e 74 72 6f 64 75 63 74 69 6f 09), Introductio
3970: 6e 20 74 6f 20 41 6c 67 6f 72 69 74 68 6d 73 20 n to Algorithms
3980: 28 33 72 64 20 65 64 2e 29 2c 20 70 70 2e 20 36 (3rd ed.), pp. 6
3990: 31 32 2d 36 31 35 2e 0a 0a 3b 3b 20 28 64 65 66 12-615...;; (def
39a0: 69 6e 65 20 28 74 6f 70 6f 6c 6f 67 69 63 61 6c ine (topological
39b0: 2d 73 6f 72 74 20 64 61 67 20 70 72 65 64 29 0a -sort dag pred).
39c0: 3b 3b 20 20 20 28 64 65 66 69 6e 65 20 28 76 69 ;; (define (vi
39d0: 73 69 74 20 64 61 67 20 6e 6f 64 65 20 65 64 67 sit dag node edg
39e0: 65 73 20 70 61 74 68 20 73 74 61 74 65 29 0a 3b es path state).;
39f0: 3b 20 20 20 20 20 28 63 61 73 65 20 28 61 6c 69 ; (case (ali
3a00: 73 74 2d 72 65 66 20 6e 6f 64 65 20 28 63 61 72 st-ref node (car
3a10: 20 73 74 61 74 65 29 20 70 72 65 64 29 0a 3b 3b state) pred).;;
3a20: 20 20 20 20 20 20 20 28 28 67 72 65 79 29 0a 3b ((grey).;
3a30: 3b 20 20 20 20 20 20 20 20 28 65 72 72 6f 72 66 ; (errorf
3a40: 20 27 74 6f 70 6f 6c 6f 67 69 63 61 6c 2d 73 6f 'topological-so
3a50: 72 74 20 22 63 79 63 6c 65 20 64 65 74 65 63 74 rt "cycle detect
3a60: 65 64 22 0a 3b 3b 20 09 20 20 20 20 20 20 20 2c ed".;; . ,
3a70: 28 6c 69 73 74 20 28 63 6f 6e 73 20 6e 6f 64 65 (list (cons node
3a80: 20 28 72 65 76 65 72 73 65 20 70 61 74 68 29 29 (reverse path))
3a90: 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 28 28 62 ))).;; ((b
3aa0: 6c 61 63 6b 29 0a 3b 3b 20 20 20 20 20 20 20 20 lack).;;
3ab0: 73 74 61 74 65 29 0a 3b 3b 20 20 20 20 20 20 20 state).;;
3ac0: 28 65 6c 73 65 0a 3b 3b 20 20 20 20 20 20 20 20 (else.;;
3ad0: 28 6c 65 74 20 77 61 6c 6b 20 28 28 65 64 67 65 (let walk ((edge
3ae0: 73 20 28 6f 72 20 65 64 67 65 73 20 28 61 6c 69 s (or edges (ali
3af0: 73 74 2d 72 65 66 20 6e 6f 64 65 20 64 61 67 20 st-ref node dag
3b00: 70 72 65 64 20 27 28 29 29 29 29 0a 3b 3b 20 20 pred '()))).;;
3b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3b20: 20 28 73 74 61 74 65 20 28 63 6f 6e 73 20 28 63 (state (cons (c
3b30: 6f 6e 73 20 28 63 6f 6e 73 20 6e 6f 64 65 20 27 ons (cons node '
3b40: 67 72 65 79 29 20 28 63 61 72 20 73 74 61 74 65 grey) (car state
3b50: 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 )).;;
3b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3b70: 20 20 20 20 20 28 63 64 72 20 73 74 61 74 65 29 (cdr state)
3b80: 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 ))).;;
3b90: 28 69 66 20 28 6e 75 6c 6c 3f 20 65 64 67 65 73 (if (null? edges
3ba0: 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ).;;
3bb0: 20 20 28 63 6f 6e 73 20 28 61 6c 69 73 74 2d 75 (cons (alist-u
3bc0: 70 64 61 74 65 21 20 6e 6f 64 65 20 27 62 6c 61 pdate! node 'bla
3bd0: 63 6b 20 28 63 61 72 20 73 74 61 74 65 29 20 70 ck (car state) p
3be0: 72 65 64 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 red).;;
3bf0: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 (cons
3c00: 20 6e 6f 64 65 20 28 63 64 72 20 73 74 61 74 65 node (cdr state
3c10: 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 ))).;;
3c20: 20 20 20 20 28 6c 65 74 20 28 28 65 64 67 65 20 (let ((edge
3c30: 28 63 61 72 20 65 64 67 65 73 29 29 29 0a 3b 3b (car edges))).;;
3c40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3c50: 28 77 61 6c 6b 20 28 63 64 72 20 65 64 67 65 73 (walk (cdr edges
3c60: 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ).;;
3c70: 20 20 20 20 20 20 20 20 20 20 28 76 69 73 69 74 (visit
3c80: 20 64 61 67 0a 3b 3b 20 20 20 20 20 20 20 20 20 dag.;;
3c90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3ca0: 20 20 20 20 65 64 67 65 0a 3b 3b 20 20 20 20 20 edge.;;
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 23 66 0a 3b 3b 20 20 20 #f.;;
3cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3ce0: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 (cons
3cf0: 65 64 67 65 20 70 61 74 68 29 0a 3b 3b 20 20 20 edge path).;;
3d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3d10: 20 20 20 20 20 20 20 20 20 20 73 74 61 74 65 29 state)
3d20: 29 29 29 29 29 29 29 0a 3b 3b 20 20 20 28 6c 65 ))))))).;; (le
3d30: 74 20 6c 6f 6f 70 20 28 28 64 61 67 20 64 61 67 t loop ((dag dag
3d40: 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ).;;
3d50: 20 20 28 73 74 61 74 65 20 28 63 6f 6e 73 20 28 (state (cons (
3d60: 6c 69 73 74 29 20 28 6c 69 73 74 29 29 29 29 0a list) (list)))).
3d70: 3b 3b 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c ;; (if (null
3d80: 3f 20 64 61 67 29 0a 3b 3b 20 20 20 20 20 20 20 ? dag).;;
3d90: 20 20 28 63 64 72 20 73 74 61 74 65 29 0a 3b 3b (cdr state).;;
3da0: 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 (loop (
3db0: 63 64 72 20 64 61 67 29 0a 3b 3b 20 20 20 20 20 cdr dag).;;
3dc0: 20 20 20 20 20 20 20 20 20 20 28 76 69 73 69 74 (visit
3dd0: 20 64 61 67 0a 3b 3b 20 20 20 20 20 20 20 20 20 dag.;;
3de0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 (ca
3df0: 61 72 20 64 61 67 29 0a 3b 3b 20 20 20 20 20 20 ar dag).;;
3e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3e10: 28 63 64 61 72 20 64 61 67 29 0a 3b 3b 20 20 20 (cdar dag).;;
3e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3e30: 20 20 20 27 28 29 0a 3b 3b 20 20 20 20 20 20 20 '().;;
3e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 73 s
3e50: 74 61 74 65 29 29 29 29 29 0a 0a 0a 3b 3b 3b 20 tate)))))...;;;
3e60: 42 69 6e 61 72 79 20 73 65 61 72 63 68 3a 0a 0a Binary search:..
3e70: 28 64 65 66 69 6e 65 20 62 69 6e 61 72 79 2d 73 (define binary-s
3e80: 65 61 72 63 68 0a 20 20 28 6c 61 6d 62 64 61 20 earch. (lambda
3e90: 28 76 65 63 20 70 72 6f 63 29 0a 20 20 20 20 28 (vec proc). (
3ea0: 69 66 20 28 70 61 69 72 3f 20 76 65 63 29 0a 09 if (pair? vec)..
3eb0: 28 73 65 74 21 20 76 65 63 20 28 6c 69 73 74 2d (set! vec (list-
3ec0: 3e 76 65 63 74 6f 72 20 76 65 63 29 29 0a 09 28 >vector vec))..(
3ed0: 61 73 73 65 72 74 20 28 61 6e 64 20 27 62 69 6e assert (and 'bin
3ee0: 61 72 79 2d 73 65 61 72 63 68 20 28 76 65 63 74 ary-search (vect
3ef0: 6f 72 3f 20 20 76 65 63 29 29 29 29 0a 20 20 20 or? vec)))).
3f00: 20 28 6c 65 74 20 28 5b 6c 65 6e 20 28 76 65 63 (let ([len (vec
3f10: 74 6f 72 2d 6c 65 6e 67 74 68 20 76 65 63 29 5d tor-length vec)]
3f20: 29 0a 20 20 20 20 20 20 28 61 6e 64 20 28 66 78 ). (and (fx
3f30: 3e 20 6c 65 6e 20 30 29 0a 09 20 20 20 28 6c 65 > len 0).. (le
3f40: 74 20 6c 6f 6f 70 20 28 5b 70 73 20 30 5d 0a 09 t loop ([ps 0]..
3f50: 09 20 20 20 20 20 20 5b 70 65 20 6c 65 6e 5d 20 . [pe len]
3f60: 29 0a 09 20 20 20 20 20 28 6c 65 74 20 28 5b 70 ).. (let ([p
3f70: 20 28 66 78 2b 20 70 73 20 28 62 69 74 77 69 73 (fx+ ps (bitwis
3f80: 65 2d 61 72 69 74 68 6d 65 74 69 63 2d 73 68 69 e-arithmetic-shi
3f90: 66 74 2d 72 69 67 68 74 20 28 66 78 2d 20 70 65 ft-right (fx- pe
3fa0: 20 70 73 29 20 31 29 29 5d 29 0a 09 20 20 20 20 ps) 1))])..
3fb0: 20 20 20 28 6c 65 74 2a 20 28 5b 78 20 28 76 65 (let* ([x (ve
3fc0: 63 74 6f 72 2d 72 65 66 20 76 65 63 20 70 29 5d ctor-ref vec p)]
3fd0: 0a 09 09 20 20 20 20 20 20 5b 72 20 28 70 72 6f ... [r (pro
3fe0: 63 20 78 29 5d 20 29 0a 09 09 20 28 63 6f 6e 64 c x)] )... (cond
3ff0: 20 5b 28 66 78 3d 20 72 20 30 29 20 70 5d 0a 09 [(fx= r 0) p]..
4000: 09 20 20 20 20 20 20 20 5b 28 66 78 3c 20 72 20 . [(fx< r
4010: 30 29 20 28 61 6e 64 20 28 6e 6f 74 20 28 66 78 0) (and (not (fx
4020: 3d 20 70 65 20 70 29 29 20 28 6c 6f 6f 70 20 70 = pe p)) (loop p
4030: 73 20 70 29 29 5d 0a 09 09 20 20 20 20 20 20 20 s p))]...
4040: 5b 65 6c 73 65 20 28 61 6e 64 20 28 6e 6f 74 20 [else (and (not
4050: 28 66 78 3d 20 70 73 20 70 29 29 20 28 6c 6f 6f (fx= ps p)) (loo
4060: 70 20 70 20 70 65 29 29 5d 20 29 20 29 20 29 20 p p pe))] ) ) )
4070: 29 20 29 20 29 20 29 20 29 0a 0a 0a 23 21 65 6f ) ) ) ) )...#!eo
4080: 66 0a 3b 3b 20 54 4f 44 4f 20 46 49 58 20 54 48 f.;; TODO FIX TH
4090: 45 20 53 54 55 46 46 20 42 45 4c 4f 57 0a 0a 3b E STUFF BELOW..;
40a0: 3b 3b 20 53 65 61 72 63 68 20 6f 6e 65 20 73 74 ;; Search one st
40b0: 72 69 6e 67 20 69 6e 73 69 64 65 20 61 6e 6f 74 ring inside anot
40c0: 68 65 72 3a 0a 0a 28 6c 65 74 20 28 29 0a 20 20 her:..(let ().
40d0: 28 64 65 66 69 6e 65 20 28 74 72 61 76 65 72 73 (define (travers
40e0: 65 20 77 68 69 63 68 20 77 68 65 72 65 20 73 74 e which where st
40f0: 61 72 74 20 74 65 73 74 20 6c 6f 63 29 0a 20 20 art test loc).
4100: 20 20 28 61 73 73 65 72 74 20 28 73 74 72 69 6e (assert (strin
4110: 67 3f 20 77 68 69 63 68 29 29 0a 20 20 20 20 28 g? which)). (
4120: 61 73 73 65 72 74 20 28 73 74 72 69 6e 67 3f 20 assert (string?
4130: 77 68 65 72 65 29 29 0a 20 20 20 20 28 6c 65 74 where)). (let
4140: 20 28 5b 77 68 65 72 65 6c 65 6e 20 28 73 74 72 ([wherelen (str
4150: 69 6e 67 2d 6c 65 6e 67 74 68 20 77 68 65 72 65 ing-length where
4160: 29 5d 0a 09 20 20 5b 77 68 69 63 68 6c 65 6e 20 )].. [whichlen
4170: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 77 (string-length w
4180: 68 69 63 68 29 5d 20 29 0a 20 20 20 20 20 20 28 hich)] ). (
4190: 61 73 73 65 72 74 20 28 65 78 61 63 74 3f 20 73 assert (exact? s
41a0: 74 61 72 74 20 29 29 0a 20 20 20 20 20 20 28 6c tart )). (l
41b0: 65 74 20 6c 6f 6f 70 20 28 5b 69 73 74 61 72 74 et loop ([istart
41c0: 20 73 74 61 72 74 5d 20 5b 69 65 6e 64 20 77 68 start] [iend wh
41d0: 69 63 68 6c 65 6e 5d 29 0a 09 28 63 6f 6e 64 20 ichlen])..(cond
41e0: 5b 28 66 78 3e 20 69 65 6e 64 20 77 68 65 72 65 [(fx> iend where
41f0: 6c 65 6e 29 20 23 66 5d 0a 09 20 20 20 20 20 20 len) #f]..
4200: 5b 28 74 65 73 74 20 69 73 74 61 72 74 20 77 68 [(test istart wh
4210: 69 63 68 6c 65 6e 29 20 69 73 74 61 72 74 5d 0a ichlen) istart].
4220: 09 20 20 20 20 20 20 5b 65 6c 73 65 20 0a 09 20 . [else ..
4230: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 66 78 2b (loop (fx+
4240: 20 69 73 74 61 72 74 20 31 29 0a 09 09 20 20 20 istart 1)...
4250: 20 20 28 66 78 2b 20 69 65 6e 64 20 31 29 20 29 (fx+ iend 1) )
4260: 20 5d 20 29 20 29 20 29 20 29 0a 20 20 28 73 65 ] ) ) ) ). (se
4270: 74 21 20 23 23 73 79 73 23 73 75 62 73 74 72 69 t! ##sys#substri
4280: 6e 67 2d 69 6e 64 65 78 20 0a 20 20 20 20 28 6c ng-index . (l
4290: 61 6d 62 64 61 20 28 77 68 69 63 68 20 77 68 65 ambda (which whe
42a0: 72 65 20 73 74 61 72 74 29 0a 20 20 20 20 20 20 re start).
42b0: 28 74 72 61 76 65 72 73 65 20 0a 20 20 20 20 20 (traverse .
42c0: 20 20 77 68 69 63 68 20 77 68 65 72 65 20 73 74 which where st
42d0: 61 72 74 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 art. (lamb
42e0: 64 61 20 28 69 20 6c 29 20 28 23 23 63 6f 72 65 da (i l) (##core
42f0: 23 69 6e 6c 69 6e 65 20 22 43 5f 73 75 62 73 74 #inline "C_subst
4300: 72 69 6e 67 5f 63 6f 6d 70 61 72 65 22 20 77 68 ring_compare" wh
4310: 69 63 68 20 77 68 65 72 65 20 30 20 69 20 6c 29 ich where 0 i l)
4320: 29 0a 20 20 20 20 20 20 20 27 73 75 62 73 74 72 ). 'substr
4330: 69 6e 67 2d 69 6e 64 65 78 29 20 29 20 29 0a 20 ing-index) ) ).
4340: 20 28 73 65 74 21 20 23 23 73 79 73 23 73 75 62 (set! ##sys#sub
4350: 73 74 72 69 6e 67 2d 69 6e 64 65 78 2d 63 69 20 string-index-ci
4360: 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 77 68 . (lambda (wh
4370: 69 63 68 20 77 68 65 72 65 20 73 74 61 72 74 29 ich where start)
4380: 0a 20 20 20 20 20 20 28 74 72 61 76 65 72 73 65 . (traverse
4390: 0a 20 20 20 20 20 20 20 77 68 69 63 68 20 77 68 . which wh
43a0: 65 72 65 20 73 74 61 72 74 0a 20 20 20 20 20 20 ere start.
43b0: 20 28 6c 61 6d 62 64 61 20 28 69 20 6c 29 20 28 (lambda (i l) (
43c0: 23 23 63 6f 72 65 23 69 6e 6c 69 6e 65 20 22 43 ##core#inline "C
43d0: 5f 73 75 62 73 74 72 69 6e 67 5f 63 6f 6d 70 61 _substring_compa
43e0: 72 65 5f 63 61 73 65 5f 69 6e 73 65 6e 73 69 74 re_case_insensit
43f0: 69 76 65 22 20 77 68 69 63 68 20 77 68 65 72 65 ive" which where
4400: 20 30 20 69 20 6c 29 29 20 0a 20 20 20 20 20 20 0 i l)) .
4410: 20 27 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 'substring-inde
4420: 78 2d 63 69 29 20 29 20 29 20 29 0a 0a 28 64 65 x-ci) ) ) )..(de
4430: 66 69 6e 65 20 28 73 75 62 73 74 72 69 6e 67 2d fine (substring-
4440: 69 6e 64 65 78 20 77 68 69 63 68 20 77 68 65 72 index which wher
4450: 65 20 23 21 6f 70 74 69 6f 6e 61 6c 20 28 73 74 e #!optional (st
4460: 61 72 74 20 30 29 29 0a 20 20 28 23 23 73 79 73 art 0)). (##sys
4470: 23 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 #substring-index
4480: 20 77 68 69 63 68 20 77 68 65 72 65 20 73 74 61 which where sta
4490: 72 74 29 20 29 0a 0a 28 64 65 66 69 6e 65 20 28 rt) )..(define (
44a0: 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 2d substring-index-
44b0: 63 69 20 77 68 69 63 68 20 77 68 65 72 65 20 23 ci which where #
44c0: 21 6f 70 74 69 6f 6e 61 6c 20 28 73 74 61 72 74 !optional (start
44d0: 20 30 29 29 0a 20 20 28 23 23 73 79 73 23 73 75 0)). (##sys#su
44e0: 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 2d 63 69 bstring-index-ci
44f0: 20 77 68 69 63 68 20 77 68 65 72 65 20 73 74 61 which where sta
4500: 72 74 29 20 29 0a 0a 0a 3b 3b 3b 20 33 2d 57 61 rt) )...;;; 3-Wa
4510: 79 20 73 74 72 69 6e 67 20 63 6f 6d 70 61 72 69 y string compari
4520: 73 6f 6e 3a 0a 0a 28 64 65 66 69 6e 65 20 28 73 son:..(define (s
4530: 74 72 69 6e 67 2d 63 6f 6d 70 61 72 65 33 20 73 tring-compare3 s
4540: 31 20 73 32 29 0a 20 20 28 23 23 73 79 73 23 63 1 s2). (##sys#c
4550: 68 65 63 6b 2d 73 74 72 69 6e 67 20 73 31 20 27 heck-string s1 '
4560: 73 74 72 69 6e 67 2d 63 6f 6d 70 61 72 65 33 29 string-compare3)
4570: 0a 20 20 28 23 23 73 79 73 23 63 68 65 63 6b 2d . (##sys#check-
4580: 73 74 72 69 6e 67 20 73 32 20 27 73 74 72 69 6e string s2 'strin
4590: 67 2d 63 6f 6d 70 61 72 65 33 29 0a 20 20 28 6c g-compare3). (l
45a0: 65 74 20 28 28 6c 65 6e 31 20 28 23 23 73 79 73 et ((len1 (##sys
45b0: 23 73 69 7a 65 20 73 31 29 29 0a 09 28 6c 65 6e #size s1))..(len
45c0: 32 20 28 23 23 73 79 73 23 73 69 7a 65 20 73 32 2 (##sys#size s2
45d0: 29 29 20 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 )) ). (let* (
45e0: 28 6c 65 6e 2d 64 69 66 66 20 28 66 78 2d 20 6c (len-diff (fx- l
45f0: 65 6e 31 20 6c 65 6e 32 29 29 20 0a 09 20 20 20 en1 len2)) ..
4600: 28 63 6d 70 20 28 23 23 63 6f 72 65 23 69 6e 6c (cmp (##core#inl
4610: 69 6e 65 20 22 43 5f 73 74 72 69 6e 67 5f 63 6f ine "C_string_co
4620: 6d 70 61 72 65 22 20 73 31 20 73 32 20 28 69 66 mpare" s1 s2 (if
4630: 20 28 66 78 3c 20 6c 65 6e 2d 64 69 66 66 20 30 (fx< len-diff 0
4640: 29 20 6c 65 6e 31 20 6c 65 6e 32 29 29 29 29 0a ) len1 len2)))).
4650: 20 20 20 20 20 20 28 69 66 20 28 66 78 3d 20 63 (if (fx= c
4660: 6d 70 20 30 29 20 0a 09 20 20 6c 65 6e 2d 64 69 mp 0) .. len-di
4670: 66 66 20 0a 09 20 20 63 6d 70 29 29 29 29 0a 0a ff .. cmp))))..
4680: 28 64 65 66 69 6e 65 20 28 73 74 72 69 6e 67 2d (define (string-
4690: 63 6f 6d 70 61 72 65 33 2d 63 69 20 73 31 20 73 compare3-ci s1 s
46a0: 32 29 0a 20 20 28 23 23 73 79 73 23 63 68 65 63 2). (##sys#chec
46b0: 6b 2d 73 74 72 69 6e 67 20 73 31 20 27 73 74 72 k-string s1 'str
46c0: 69 6e 67 2d 63 6f 6d 70 61 72 65 33 2d 63 69 29 ing-compare3-ci)
46d0: 0a 20 20 28 23 23 73 79 73 23 63 68 65 63 6b 2d . (##sys#check-
46e0: 73 74 72 69 6e 67 20 73 32 20 27 73 74 72 69 6e string s2 'strin
46f0: 67 2d 63 6f 6d 70 61 72 65 33 2d 63 69 29 0a 20 g-compare3-ci).
4700: 20 28 6c 65 74 20 28 28 6c 65 6e 31 20 28 23 23 (let ((len1 (##
4710: 73 79 73 23 73 69 7a 65 20 73 31 29 29 0a 09 28 sys#size s1))..(
4720: 6c 65 6e 32 20 28 23 23 73 79 73 23 73 69 7a 65 len2 (##sys#size
4730: 20 73 32 29 29 20 29 0a 20 20 20 20 28 6c 65 74 s2)) ). (let
4740: 2a 20 28 28 6c 65 6e 2d 64 69 66 66 20 28 66 78 * ((len-diff (fx
4750: 2d 20 6c 65 6e 31 20 6c 65 6e 32 29 29 20 0a 09 - len1 len2)) ..
4760: 20 20 20 28 63 6d 70 20 28 23 23 63 6f 72 65 23 (cmp (##core#
4770: 69 6e 6c 69 6e 65 20 22 43 5f 73 74 72 69 6e 67 inline "C_string
4780: 5f 63 6f 6d 70 61 72 65 5f 63 61 73 65 5f 69 6e _compare_case_in
4790: 73 65 6e 73 69 74 69 76 65 22 20 73 31 20 73 32 sensitive" s1 s2
47a0: 20 28 69 66 20 28 66 78 3c 20 6c 65 6e 2d 64 69 (if (fx< len-di
47b0: 66 66 20 30 29 20 6c 65 6e 31 20 6c 65 6e 32 29 ff 0) len1 len2)
47c0: 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 66 ))). (if (f
47d0: 78 3d 20 63 6d 70 20 30 29 20 0a 09 20 20 6c 65 x= cmp 0) .. le
47e0: 6e 2d 64 69 66 66 20 0a 09 20 20 63 6d 70 29 29 n-diff .. cmp))
47f0: 29 29 0a 0a 0a 3b 3b 3b 20 53 75 62 73 74 72 69 ))...;;; Substri
4800: 6e 67 20 63 6f 6d 70 61 72 69 73 6f 6e 3a 0a 0a ng comparison:..
4810: 28 64 65 66 69 6e 65 20 28 23 23 73 79 73 23 73 (define (##sys#s
4820: 75 62 73 74 72 69 6e 67 3d 3f 20 73 31 20 73 32 ubstring=? s1 s2
4830: 20 73 74 61 72 74 31 20 73 74 61 72 74 32 20 6e start1 start2 n
4840: 29 0a 20 20 28 23 23 73 79 73 23 63 68 65 63 6b ). (##sys#check
4850: 2d 73 74 72 69 6e 67 20 73 31 20 27 73 75 62 73 -string s1 'subs
4860: 74 72 69 6e 67 3d 3f 29 0a 20 20 28 23 23 73 79 tring=?). (##sy
4870: 73 23 63 68 65 63 6b 2d 73 74 72 69 6e 67 20 73 s#check-string s
4880: 32 20 27 73 75 62 73 74 72 69 6e 67 3d 3f 29 0a 2 'substring=?).
4890: 20 20 28 6c 65 74 20 28 28 6c 65 6e 20 28 6f 72 (let ((len (or
48a0: 20 6e 0a 09 09 20 28 66 78 6d 69 6e 20 28 66 78 n... (fxmin (fx
48b0: 2d 20 28 23 23 73 79 73 23 73 69 7a 65 20 73 31 - (##sys#size s1
48c0: 29 20 73 74 61 72 74 31 29 0a 09 09 09 28 66 78 ) start1)....(fx
48d0: 2d 20 28 23 23 73 79 73 23 73 69 7a 65 20 73 32 - (##sys#size s2
48e0: 29 20 73 74 61 72 74 32 29 20 29 20 29 20 29 20 ) start2) ) ) )
48f0: 29 0a 20 20 20 20 28 23 23 73 79 73 23 63 68 65 ). (##sys#che
4900: 63 6b 2d 65 78 61 63 74 20 73 74 61 72 74 31 20 ck-exact start1
4910: 27 73 75 62 73 74 72 69 6e 67 3d 3f 29 0a 20 20 'substring=?).
4920: 20 20 28 23 23 73 79 73 23 63 68 65 63 6b 2d 65 (##sys#check-e
4930: 78 61 63 74 20 73 74 61 72 74 32 20 27 73 75 62 xact start2 'sub
4940: 73 74 72 69 6e 67 3d 3f 29 0a 20 20 20 20 28 23 string=?). (#
4950: 23 63 6f 72 65 23 69 6e 6c 69 6e 65 20 22 43 5f #core#inline "C_
4960: 73 75 62 73 74 72 69 6e 67 5f 63 6f 6d 70 61 72 substring_compar
4970: 65 22 20 73 31 20 73 32 20 73 74 61 72 74 31 20 e" s1 s2 start1
4980: 73 74 61 72 74 32 20 6c 65 6e 29 20 29 20 29 0a start2 len) ) ).
4990: 0a 28 64 65 66 69 6e 65 20 28 73 75 62 73 74 72 .(define (substr
49a0: 69 6e 67 3d 3f 20 73 31 20 73 32 20 23 21 6f 70 ing=? s1 s2 #!op
49b0: 74 69 6f 6e 61 6c 20 28 73 74 61 72 74 31 20 30 tional (start1 0
49c0: 29 20 28 73 74 61 72 74 32 20 30 29 20 6c 65 6e ) (start2 0) len
49d0: 29 0a 20 20 28 23 23 73 79 73 23 73 75 62 73 74 ). (##sys#subst
49e0: 72 69 6e 67 3d 3f 20 73 31 20 73 32 20 73 74 61 ring=? s1 s2 sta
49f0: 72 74 31 20 73 74 61 72 74 32 20 6c 65 6e 29 20 rt1 start2 len)
4a00: 29 0a 0a 28 64 65 66 69 6e 65 20 28 23 23 73 79 )..(define (##sy
4a10: 73 23 73 75 62 73 74 72 69 6e 67 2d 63 69 3d 3f s#substring-ci=?
4a20: 20 73 31 20 73 32 20 73 74 61 72 74 31 20 73 74 s1 s2 start1 st
4a30: 61 72 74 32 20 6e 29 0a 20 20 28 23 23 73 79 73 art2 n). (##sys
4a40: 23 63 68 65 63 6b 2d 73 74 72 69 6e 67 20 73 31 #check-string s1
4a50: 20 27 73 75 62 73 74 72 69 6e 67 2d 63 69 3d 3f 'substring-ci=?
4a60: 29 0a 20 20 28 23 23 73 79 73 23 63 68 65 63 6b ). (##sys#check
4a70: 2d 73 74 72 69 6e 67 20 73 32 20 27 73 75 62 73 -string s2 'subs
4a80: 74 72 69 6e 67 2d 63 69 3d 3f 29 0a 20 20 28 6c tring-ci=?). (l
4a90: 65 74 20 28 28 6c 65 6e 20 28 6f 72 20 6e 0a 09 et ((len (or n..
4aa0: 09 20 28 66 78 6d 69 6e 20 28 66 78 2d 20 28 23 . (fxmin (fx- (#
4ab0: 23 73 79 73 23 73 69 7a 65 20 73 31 29 20 73 74 #sys#size s1) st
4ac0: 61 72 74 31 29 0a 09 09 09 28 66 78 2d 20 28 23 art1)....(fx- (#
4ad0: 23 73 79 73 23 73 69 7a 65 20 73 32 29 20 73 74 #sys#size s2) st
4ae0: 61 72 74 32 29 20 29 20 29 20 29 20 29 0a 20 20 art2) ) ) ) ).
4af0: 20 20 28 23 23 73 79 73 23 63 68 65 63 6b 2d 65 (##sys#check-e
4b00: 78 61 63 74 20 73 74 61 72 74 31 20 27 73 75 62 xact start1 'sub
4b10: 73 74 72 69 6e 67 2d 63 69 3d 3f 29 0a 20 20 20 string-ci=?).
4b20: 20 28 23 23 73 79 73 23 63 68 65 63 6b 2d 65 78 (##sys#check-ex
4b30: 61 63 74 20 73 74 61 72 74 32 20 27 73 75 62 73 act start2 'subs
4b40: 74 72 69 6e 67 2d 63 69 3d 3f 29 0a 20 20 20 20 tring-ci=?).
4b50: 28 23 23 63 6f 72 65 23 69 6e 6c 69 6e 65 20 22 (##core#inline "
4b60: 43 5f 73 75 62 73 74 72 69 6e 67 5f 63 6f 6d 70 C_substring_comp
4b70: 61 72 65 5f 63 61 73 65 5f 69 6e 73 65 6e 73 69 are_case_insensi
4b80: 74 69 76 65 22 0a 09 09 20 20 20 73 31 20 73 32 tive"... s1 s2
4b90: 20 73 74 61 72 74 31 20 73 74 61 72 74 32 20 6c start1 start2 l
4ba0: 65 6e 29 20 29 20 29 0a 0a 28 64 65 66 69 6e 65 en) ) )..(define
4bb0: 20 28 73 75 62 73 74 72 69 6e 67 2d 63 69 3d 3f (substring-ci=?
4bc0: 20 73 31 20 73 32 20 23 21 6f 70 74 69 6f 6e 61 s1 s2 #!optiona
4bd0: 6c 20 28 73 74 61 72 74 31 20 30 29 20 28 73 74 l (start1 0) (st
4be0: 61 72 74 32 20 30 29 20 6c 65 6e 29 0a 20 20 28 art2 0) len). (
4bf0: 23 23 73 79 73 23 73 75 62 73 74 72 69 6e 67 2d ##sys#substring-
4c00: 63 69 3d 3f 20 73 31 20 73 32 20 73 74 61 72 74 ci=? s1 s2 start
4c10: 31 20 73 74 61 72 74 32 20 6c 65 6e 29 20 29 0a 1 start2 len) ).
4c20: 0a 0a 3b 3b 3b 20 53 70 6c 69 74 20 73 74 72 69 ..;;; Split stri
4c30: 6e 67 20 69 6e 74 6f 20 73 75 62 73 74 72 69 6e ng into substrin
4c40: 67 73 3a 0a 0a 28 64 65 66 69 6e 65 20 73 74 72 gs:..(define str
4c50: 69 6e 67 2d 73 70 6c 69 74 0a 20 20 28 6c 61 6d ing-split. (lam
4c60: 62 64 61 20 28 73 74 72 20 2e 20 64 65 6c 73 74 bda (str . delst
4c70: 72 2d 61 6e 64 2d 66 6c 61 67 29 0a 20 20 20 20 r-and-flag).
4c80: 28 23 23 73 79 73 23 63 68 65 63 6b 2d 73 74 72 (##sys#check-str
4c90: 69 6e 67 20 73 74 72 20 27 73 74 72 69 6e 67 2d ing str 'string-
4ca0: 73 70 6c 69 74 29 0a 20 20 20 20 28 6c 65 74 2a split). (let*
4cb0: 20 28 5b 64 65 6c 20 28 69 66 20 28 6e 75 6c 6c ([del (if (null
4cc0: 3f 20 64 65 6c 73 74 72 2d 61 6e 64 2d 66 6c 61 ? delstr-and-fla
4cd0: 67 29 20 22 5c 74 5c 6e 20 22 20 28 63 61 72 20 g) "\t\n " (car
4ce0: 64 65 6c 73 74 72 2d 61 6e 64 2d 66 6c 61 67 29 delstr-and-flag)
4cf0: 29 5d 0a 09 20 20 20 5b 66 6c 61 67 20 28 69 66 )].. [flag (if
4d00: 20 28 66 78 3d 20 28 6c 65 6e 67 74 68 20 64 65 (fx= (length de
4d10: 6c 73 74 72 2d 61 6e 64 2d 66 6c 61 67 29 20 32 lstr-and-flag) 2
4d20: 29 20 28 63 61 64 72 20 64 65 6c 73 74 72 2d 61 ) (cadr delstr-a
4d30: 6e 64 2d 66 6c 61 67 29 20 23 66 29 5d 0a 09 20 nd-flag) #f)]..
4d40: 20 20 5b 73 74 72 6c 65 6e 20 28 23 23 73 79 73 [strlen (##sys
4d50: 23 73 69 7a 65 20 73 74 72 29 5d 20 29 0a 20 20 #size str)] ).
4d60: 20 20 20 20 28 23 23 73 79 73 23 63 68 65 63 6b (##sys#check
4d70: 2d 73 74 72 69 6e 67 20 64 65 6c 20 27 73 74 72 -string del 'str
4d80: 69 6e 67 2d 73 70 6c 69 74 29 0a 20 20 20 20 20 ing-split).
4d90: 20 28 6c 65 74 20 28 5b 64 65 6c 6c 65 6e 20 28 (let ([dellen (
4da0: 23 23 73 79 73 23 73 69 7a 65 20 64 65 6c 29 5d ##sys#size del)]
4db0: 20 0a 09 20 20 20 20 5b 66 69 72 73 74 20 23 66 .. [first #f
4dc0: 5d 20 29 0a 09 28 64 65 66 69 6e 65 20 28 61 64 ] )..(define (ad
4dd0: 64 20 66 72 6f 6d 20 74 6f 20 6c 61 73 74 29 0a d from to last).
4de0: 09 20 20 28 6c 65 74 20 28 5b 6e 6f 64 65 20 28 . (let ([node (
4df0: 63 6f 6e 73 20 28 23 23 73 79 73 23 73 75 62 73 cons (##sys#subs
4e00: 74 72 69 6e 67 20 73 74 72 20 66 72 6f 6d 20 74 tring str from t
4e10: 6f 29 20 27 28 29 29 5d 29 0a 09 20 20 20 20 28 o) '())]).. (
4e20: 69 66 20 66 69 72 73 74 0a 09 09 28 23 23 73 79 if first...(##sy
4e30: 73 23 73 65 74 73 6c 6f 74 20 6c 61 73 74 20 31 s#setslot last 1
4e40: 20 6e 6f 64 65 29 0a 09 09 28 73 65 74 21 20 66 node)...(set! f
4e50: 69 72 73 74 20 6e 6f 64 65 29 20 29 20 0a 09 20 irst node) ) ..
4e60: 20 20 20 6e 6f 64 65 29 20 29 0a 09 28 6c 65 74 node) )..(let
4e70: 20 6c 6f 6f 70 20 28 5b 69 20 30 5d 20 5b 6c 61 loop ([i 0] [la
4e80: 73 74 20 23 66 5d 20 5b 66 72 6f 6d 20 30 5d 29 st #f] [from 0])
4e90: 0a 09 20 20 28 63 6f 6e 64 20 5b 28 66 78 3e 3d .. (cond [(fx>=
4ea0: 20 69 20 73 74 72 6c 65 6e 29 0a 09 09 20 28 77 i strlen)... (w
4eb0: 68 65 6e 20 28 6f 72 20 28 66 78 3e 20 69 20 66 hen (or (fx> i f
4ec0: 72 6f 6d 29 20 66 6c 61 67 29 20 28 61 64 64 20 rom) flag) (add
4ed0: 66 72 6f 6d 20 69 20 6c 61 73 74 29 29 0a 09 09 from i last))...
4ee0: 20 28 6f 72 20 66 69 72 73 74 20 27 28 29 29 20 (or first '())
4ef0: 5d 0a 09 09 5b 65 6c 73 65 0a 09 09 20 28 6c 65 ]...[else... (le
4f00: 74 20 28 5b 63 20 28 23 23 63 6f 72 65 23 69 6e t ([c (##core#in
4f10: 6c 69 6e 65 20 22 43 5f 73 75 62 63 68 61 72 22 line "C_subchar"
4f20: 20 73 74 72 20 69 29 5d 29 0a 09 09 20 20 20 28 str i)])... (
4f30: 6c 65 74 20 73 63 61 6e 20 28 5b 6a 20 30 5d 29 let scan ([j 0])
4f40: 0a 09 09 20 20 20 20 20 28 63 6f 6e 64 20 5b 28 ... (cond [(
4f50: 66 78 3e 3d 20 6a 20 64 65 6c 6c 65 6e 29 20 28 fx>= j dellen) (
4f60: 6c 6f 6f 70 20 28 66 78 2b 20 69 20 31 29 20 6c loop (fx+ i 1) l
4f70: 61 73 74 20 66 72 6f 6d 29 5d 0a 09 09 09 20 20 ast from)]....
4f80: 20 5b 28 65 71 3f 20 63 20 28 23 23 63 6f 72 65 [(eq? c (##core
4f90: 23 69 6e 6c 69 6e 65 20 22 43 5f 73 75 62 63 68 #inline "C_subch
4fa0: 61 72 22 20 64 65 6c 20 6a 29 29 0a 09 09 09 20 ar" del j))....
4fb0: 20 20 20 28 6c 65 74 20 28 5b 69 32 20 28 66 78 (let ([i2 (fx
4fc0: 2b 20 69 20 31 29 5d 29 0a 09 09 09 20 20 20 20 + i 1)])....
4fd0: 20 20 28 69 66 20 28 6f 72 20 28 66 78 3e 20 69 (if (or (fx> i
4fe0: 20 66 72 6f 6d 29 20 66 6c 61 67 29 0a 09 09 09 from) flag)....
4ff0: 09 20 20 28 6c 6f 6f 70 20 69 32 20 28 61 64 64 . (loop i2 (add
5000: 20 66 72 6f 6d 20 69 20 6c 61 73 74 29 20 69 32 from i last) i2
5010: 29 0a 09 09 09 09 20 20 28 6c 6f 6f 70 20 69 32 )..... (loop i2
5020: 20 6c 61 73 74 20 69 32 29 20 29 20 29 20 5d 0a last i2) ) ) ].
5030: 09 09 09 20 20 20 5b 65 6c 73 65 20 28 73 63 61 ... [else (sca
5040: 6e 20 28 66 78 2b 20 6a 20 31 29 29 5d 20 29 20 n (fx+ j 1))] )
5050: 29 20 29 20 5d 20 29 20 29 20 29 20 29 20 29 20 ) ) ] ) ) ) ) )
5060: 29 0a 0a 0a 0a 3b 3b 3b 20 54 72 61 6e 73 6c 61 )....;;; Transla
5070: 74 65 20 65 6c 65 6d 65 6e 74 73 20 6f 66 20 61 te elements of a
5080: 20 73 74 72 69 6e 67 3a 0a 0a 28 64 65 66 69 6e string:..(defin
5090: 65 20 73 74 72 69 6e 67 2d 74 72 61 6e 73 6c 61 e string-transla
50a0: 74 65 20 0a 20 20 28 6c 61 6d 62 64 61 20 28 73 te . (lambda (s
50b0: 74 72 20 66 72 6f 6d 20 2e 20 74 6f 29 0a 0a 20 tr from . to)..
50c0: 20 20 20 28 64 65 66 69 6e 65 20 28 69 6e 73 74 (define (inst
50d0: 72 69 6e 67 20 73 29 0a 20 20 20 20 20 20 28 6c ring s). (l
50e0: 65 74 20 28 5b 6c 65 6e 20 28 23 23 73 79 73 23 et ([len (##sys#
50f0: 73 69 7a 65 20 73 29 5d 29 0a 09 28 6c 61 6d 62 size s)])..(lamb
5100: 64 61 20 28 63 29 0a 09 20 20 28 6c 65 74 20 6c da (c).. (let l
5110: 6f 6f 70 20 28 5b 69 20 30 5d 29 0a 09 20 20 20 oop ([i 0])..
5120: 20 28 63 6f 6e 64 20 5b 28 66 78 3e 3d 20 69 20 (cond [(fx>= i
5130: 6c 65 6e 29 20 23 66 5d 0a 09 09 20 20 5b 28 65 len) #f]... [(e
5140: 71 3f 20 63 20 28 23 23 63 6f 72 65 23 69 6e 6c q? c (##core#inl
5150: 69 6e 65 20 22 43 5f 73 75 62 63 68 61 72 22 20 ine "C_subchar"
5160: 73 20 69 29 29 20 69 5d 0a 09 09 20 20 5b 65 6c s i)) i]... [el
5170: 73 65 20 28 6c 6f 6f 70 20 28 66 78 2b 20 69 20 se (loop (fx+ i
5180: 31 29 29 5d 20 29 20 29 20 29 20 29 20 29 0a 0a 1))] ) ) ) ) )..
5190: 20 20 20 20 28 6c 65 74 2a 20 28 5b 66 72 6f 6d (let* ([from
51a0: 0a 09 20 20 20 20 28 63 6f 6e 64 20 5b 28 63 68 .. (cond [(ch
51b0: 61 72 3f 20 66 72 6f 6d 29 20 28 6c 61 6d 62 64 ar? from) (lambd
51c0: 61 20 28 63 29 20 28 65 71 3f 20 63 20 66 72 6f a (c) (eq? c fro
51d0: 6d 29 29 5d 0a 09 09 20 20 5b 28 70 61 69 72 3f m))]... [(pair?
51e0: 20 66 72 6f 6d 29 20 28 69 6e 73 74 72 69 6e 67 from) (instring
51f0: 20 28 6c 69 73 74 2d 3e 73 74 72 69 6e 67 20 66 (list->string f
5200: 72 6f 6d 29 29 5d 0a 09 09 20 20 5b 65 6c 73 65 rom))]... [else
5210: 0a 09 09 20 20 20 28 23 23 73 79 73 23 63 68 65 ... (##sys#che
5220: 63 6b 2d 73 74 72 69 6e 67 20 66 72 6f 6d 20 27 ck-string from '
5230: 73 74 72 69 6e 67 2d 74 72 61 6e 73 6c 61 74 65 string-translate
5240: 29 0a 09 09 20 20 20 28 69 6e 73 74 72 69 6e 67 )... (instring
5250: 20 66 72 6f 6d 29 20 5d 20 29 20 5d 0a 09 20 20 from) ] ) ]..
5260: 20 5b 74 6f 0a 09 20 20 20 20 28 61 6e 64 20 28 [to.. (and (
5270: 70 61 69 72 3f 20 74 6f 29 0a 09 09 20 28 6c 65 pair? to)... (le
5280: 74 20 28 5b 74 78 20 28 63 61 72 20 20 74 6f 20 t ([tx (car to
5290: 29 5d 29 0a 09 09 20 20 20 28 63 6f 6e 64 20 5b )])... (cond [
52a0: 28 63 68 61 72 3f 20 74 78 29 20 74 78 5d 0a 09 (char? tx) tx]..
52b0: 09 09 20 5b 28 70 61 69 72 3f 20 74 78 29 20 28 .. [(pair? tx) (
52c0: 6c 69 73 74 2d 3e 73 74 72 69 6e 67 20 74 78 29 list->string tx)
52d0: 5d 0a 09 09 09 20 5b 65 6c 73 65 0a 09 09 09 20 ].... [else....
52e0: 20 28 23 23 73 79 73 23 63 68 65 63 6b 2d 73 74 (##sys#check-st
52f0: 72 69 6e 67 20 74 78 20 27 73 74 72 69 6e 67 2d ring tx 'string-
5300: 74 72 61 6e 73 6c 61 74 65 29 0a 09 09 09 20 20 translate)....
5310: 74 78 5d 20 29 20 29 20 29 20 5d 20 0a 09 20 20 tx] ) ) ) ] ..
5320: 20 5b 74 6c 65 6e 20 28 61 6e 64 20 28 73 74 72 [tlen (and (str
5330: 69 6e 67 3f 20 74 6f 29 20 28 23 23 73 79 73 23 ing? to) (##sys#
5340: 73 69 7a 65 20 74 6f 29 29 5d 20 29 0a 20 20 20 size to))] ).
5350: 20 20 20 28 23 23 73 79 73 23 63 68 65 63 6b 2d (##sys#check-
5360: 73 74 72 69 6e 67 20 73 74 72 20 27 73 74 72 69 string str 'stri
5370: 6e 67 2d 74 72 61 6e 73 6c 61 74 65 29 0a 20 20 ng-translate).
5380: 20 20 20 20 28 6c 65 74 2a 20 28 5b 73 6c 65 6e (let* ([slen
5390: 20 28 23 23 73 79 73 23 73 69 7a 65 20 73 74 72 (##sys#size str
53a0: 29 5d 0a 09 20 20 20 20 20 5b 73 74 72 32 20 28 )].. [str2 (
53b0: 6d 61 6b 65 2d 73 74 72 69 6e 67 20 73 6c 65 6e make-string slen
53c0: 29 5d 20 29 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 )] )..(let loop
53d0: 28 5b 69 20 30 5d 20 5b 6a 20 30 5d 29 0a 09 20 ([i 0] [j 0])..
53e0: 20 28 69 66 20 28 66 78 3e 3d 20 69 20 73 6c 65 (if (fx>= i sle
53f0: 6e 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 66 n).. (if (f
5400: 78 3c 20 6a 20 69 29 0a 09 09 20 20 28 23 23 73 x< j i)... (##s
5410: 79 73 23 73 75 62 73 74 72 69 6e 67 20 73 74 72 ys#substring str
5420: 32 20 30 20 6a 29 0a 09 09 20 20 73 74 72 32 29 2 0 j)... str2)
5430: 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 5b .. (let* ([
5440: 63 69 20 28 23 23 63 6f 72 65 23 69 6e 6c 69 6e ci (##core#inlin
5450: 65 20 22 43 5f 73 75 62 63 68 61 72 22 20 73 74 e "C_subchar" st
5460: 72 20 69 29 5d 0a 09 09 20 20 20 20 20 5b 66 6f r i)]... [fo
5470: 75 6e 64 20 28 66 72 6f 6d 20 63 69 29 5d 20 29 und (from ci)] )
5480: 0a 09 09 28 63 6f 6e 64 20 5b 28 6e 6f 74 20 66 ...(cond [(not f
5490: 6f 75 6e 64 29 0a 09 09 20 20 20 20 20 20 20 28 ound)... (
54a0: 23 23 63 6f 72 65 23 69 6e 6c 69 6e 65 20 22 43 ##core#inline "C
54b0: 5f 73 65 74 73 75 62 63 68 61 72 22 20 73 74 72 _setsubchar" str
54c0: 32 20 6a 20 63 69 29 0a 09 09 20 20 20 20 20 20 2 j ci)...
54d0: 20 28 6c 6f 6f 70 20 28 66 78 2b 20 69 20 31 29 (loop (fx+ i 1)
54e0: 20 28 66 78 2b 20 6a 20 31 29 29 20 5d 0a 09 09 (fx+ j 1)) ]...
54f0: 20 20 20 20 20 20 5b 28 6e 6f 74 20 74 6f 29 20 [(not to)
5500: 28 6c 6f 6f 70 20 28 66 78 2b 20 69 20 31 29 20 (loop (fx+ i 1)
5510: 6a 29 5d 0a 09 09 20 20 20 20 20 20 5b 28 63 68 j)]... [(ch
5520: 61 72 3f 20 74 6f 29 0a 09 09 20 20 20 20 20 20 ar? to)...
5530: 20 28 23 23 63 6f 72 65 23 69 6e 6c 69 6e 65 20 (##core#inline
5540: 22 43 5f 73 65 74 73 75 62 63 68 61 72 22 20 73 "C_setsubchar" s
5550: 74 72 32 20 6a 20 74 6f 29 0a 09 09 20 20 20 20 tr2 j to)...
5560: 20 20 20 28 6c 6f 6f 70 20 28 66 78 2b 20 69 20 (loop (fx+ i
5570: 31 29 20 28 66 78 2b 20 6a 20 31 29 29 20 5d 0a 1) (fx+ j 1)) ].
5580: 09 09 20 20 20 20 20 20 5b 28 66 78 3e 3d 20 66 .. [(fx>= f
5590: 6f 75 6e 64 20 74 6c 65 6e 29 0a 09 09 20 20 20 ound tlen)...
55a0: 20 20 20 20 28 23 23 73 79 73 23 65 72 72 6f 72 (##sys#error
55b0: 20 27 73 74 72 69 6e 67 2d 74 72 61 6e 73 6c 61 'string-transla
55c0: 74 65 20 22 69 6e 76 61 6c 69 64 20 74 72 61 6e te "invalid tran
55d0: 73 6c 61 74 69 6f 6e 20 64 65 73 74 69 6e 61 74 slation destinat
55e0: 69 6f 6e 22 20 69 20 74 6f 29 20 5d 0a 09 09 20 ion" i to) ]...
55f0: 20 20 20 20 20 5b 65 6c 73 65 20 0a 09 09 20 20 [else ...
5600: 20 20 20 20 20 28 23 23 63 6f 72 65 23 69 6e 6c (##core#inl
5610: 69 6e 65 20 22 43 5f 73 65 74 73 75 62 63 68 61 ine "C_setsubcha
5620: 72 22 20 73 74 72 32 20 6a 20 28 23 23 63 6f 72 r" str2 j (##cor
5630: 65 23 69 6e 6c 69 6e 65 20 22 43 5f 73 75 62 63 e#inline "C_subc
5640: 68 61 72 22 20 74 6f 20 66 6f 75 6e 64 29 29 0a har" to found)).
5650: 09 09 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 .. (loop (
5660: 66 78 2b 20 69 20 31 29 20 28 66 78 2b 20 6a 20 fx+ i 1) (fx+ j
5670: 31 29 29 20 5d 20 29 20 29 20 29 20 29 20 29 20 1)) ] ) ) ) ) )
5680: 29 20 29 20 29 0a 0a 0a 0a 3b 3b 3b 20 52 65 6d ) ) )....;;; Rem
5690: 6f 76 65 20 73 75 66 66 69 78 0a 0a 3b 3b 20 28 ove suffix..;; (
56a0: 64 65 66 69 6e 65 20 28 73 74 72 69 6e 67 2d 63 define (string-c
56b0: 68 6f 6d 70 20 73 74 72 20 23 21 6f 70 74 69 6f homp str #!optio
56c0: 6e 61 6c 20 28 73 75 66 66 69 78 20 22 5c 6e 22 nal (suffix "\n"
56d0: 29 29 0a 3b 3b 20 20 20 28 61 73 73 65 72 74 20 )).;; (assert
56e0: 28 61 6e 64 20 27 73 74 72 69 6e 67 2d 63 68 6f (and 'string-cho
56f0: 6d 70 20 28 73 74 72 69 6e 67 3f 20 20 73 74 72 mp (string? str
5700: 29 29 29 0a 3b 3b 20 20 20 28 61 73 73 65 72 74 ))).;; (assert
5710: 20 28 61 6e 64 20 27 73 74 72 69 6e 67 2d 63 68 (and 'string-ch
5720: 6f 6d 70 20 73 75 66 66 69 78 29 29 0a 3b 3b 20 omp suffix)).;;
5730: 20 20 28 6c 65 74 2a 20 28 28 6c 65 6e 20 28 73 (let* ((len (s
5740: 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 73 74 72 tring-length str
5750: 29 29 0a 3b 3b 20 09 20 28 73 6c 65 6e 20 28 73 )).;; . (slen (s
5760: 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 73 75 66 tring-length suf
5770: 66 69 78 29 29 20 0a 3b 3b 20 09 20 28 64 69 66 fix)) .;; . (dif
5780: 66 20 28 66 78 2d 20 6c 65 6e 20 73 6c 65 6e 29 f (fx- len slen)
5790: 29 20 29 0a 3b 3b 20 20 20 20 20 28 69 66 20 28 ) ).;; (if (
57a0: 61 6e 64 20 28 66 78 3e 3d 20 6c 65 6e 20 73 6c and (fx>= len sl
57b0: 65 6e 29 0a 3b 3b 20 09 20 20 20 20 20 28 23 23 en).;; . (##
57c0: 63 6f 72 65 23 69 6e 6c 69 6e 65 20 22 43 5f 73 core#inline "C_s
57d0: 75 62 73 74 72 69 6e 67 5f 63 6f 6d 70 61 72 65 ubstring_compare
57e0: 22 20 73 74 72 20 73 75 66 66 69 78 20 64 69 66 " str suffix dif
57f0: 66 20 30 20 73 6c 65 6e 29 20 29 0a 3b 3b 20 09 f 0 slen) ).;; .
5800: 28 73 75 62 73 74 72 69 6e 67 20 73 74 72 20 30 (substring str 0
5810: 20 64 69 66 66 29 0a 3b 3b 20 09 73 74 72 29 20 diff).;; .str)
5820: 29 20 29 0a 0a 0a 0a 3b 20 28 71 75 65 75 65 2d ) )....; (queue-
5830: 70 75 73 68 2d 62 61 63 6b 21 20 71 75 65 75 65 push-back! queue
5840: 20 69 74 65 6d 29 0a 3b 20 50 75 73 68 65 73 20 item).; Pushes
5850: 61 6e 20 69 74 65 6d 20 69 6e 74 6f 20 74 68 65 an item into the
5860: 20 66 69 72 73 74 20 70 6f 73 69 74 69 6f 6e 20 first position
5870: 6f 66 20 61 20 71 75 65 75 65 2e 0a 0a 28 64 65 of a queue...(de
5880: 66 69 6e 65 20 28 71 75 65 75 65 2d 70 75 73 68 fine (queue-push
5890: 2d 62 61 63 6b 21 20 71 20 69 74 65 6d 29 09 3b -back! q item).;
58a0: 20 74 68 72 65 61 64 2d 73 61 66 65 0a 20 20 28 thread-safe. (
58b0: 23 23 73 79 73 23 63 68 65 63 6b 2d 73 74 72 75 ##sys#check-stru
58c0: 63 74 75 72 65 20 71 20 27 71 75 65 75 65 20 27 cture q 'queue '
58d0: 71 75 65 75 65 2d 70 75 73 68 2d 62 61 63 6b 21 queue-push-back!
58e0: 29 0a 20 20 28 6c 65 74 20 28 28 6e 65 77 6c 69 ). (let ((newli
58f0: 73 74 20 28 63 6f 6e 73 20 69 74 65 6d 20 28 23 st (cons item (#
5900: 23 73 79 73 23 73 6c 6f 74 20 71 20 31 29 29 29 #sys#slot q 1)))
5910: 29 0a 20 20 20 20 28 23 23 73 79 73 23 73 65 74 ). (##sys#set
5920: 73 6c 6f 74 20 71 20 31 20 6e 65 77 6c 69 73 74 slot q 1 newlist
5930: 29 0a 20 20 20 20 28 69 66 20 28 65 71 3f 20 27 ). (if (eq? '
5940: 28 29 20 28 23 23 73 79 73 23 73 6c 6f 74 20 71 () (##sys#slot q
5950: 20 32 29 29 0a 09 28 23 23 73 79 73 23 73 65 74 2))..(##sys#set
5960: 73 6c 6f 74 20 71 20 32 20 6e 65 77 6c 69 73 74 slot q 2 newlist
5970: 29 29 0a 20 20 20 20 28 23 23 73 79 73 23 73 65 )). (##sys#se
5980: 74 69 73 6c 6f 74 20 71 20 33 20 28 66 78 2b 20 tislot q 3 (fx+
5990: 28 23 23 73 79 73 23 73 6c 6f 74 20 71 20 33 29 (##sys#slot q 3)
59a0: 20 31 29 29 29 29 0a 0a 3b 20 28 71 75 65 75 65 1))))..; (queue
59b0: 2d 70 75 73 68 2d 62 61 63 6b 2d 6c 69 73 74 21 -push-back-list!
59c0: 20 71 75 65 75 65 20 69 74 65 6d 2d 6c 69 73 74 queue item-list
59d0: 29 0a 3b 20 50 75 73 68 65 73 20 74 68 65 20 69 ).; Pushes the i
59e0: 74 65 6d 73 20 69 6e 20 69 74 65 6d 2d 6c 69 73 tems in item-lis
59f0: 74 20 62 61 63 6b 20 6f 6e 74 6f 20 74 68 65 20 t back onto the
5a00: 71 75 65 75 65 2c 0a 3b 20 73 6f 20 74 68 61 74 queue,.; so that
5a10: 20 28 63 61 72 20 69 74 65 6d 2d 6c 69 73 74 29 (car item-list)
5a20: 20 62 65 63 6f 6d 65 73 20 74 68 65 20 6e 65 78 becomes the nex
5a30: 74 20 72 65 6d 6f 76 61 62 6c 65 20 69 74 65 6d t removable item
5a40: 2e 0a 0a 28 64 65 66 69 6e 65 20 28 6c 61 73 74 ...(define (last
5a50: 2d 70 61 69 72 20 6c 73 74 30 29 0a 20 20 28 64 -pair lst0). (d
5a60: 6f 20 28 28 6c 73 74 20 6c 73 74 30 20 28 63 64 o ((lst lst0 (cd
5a70: 72 20 6c 73 74 29 29 29 0a 20 20 20 20 20 20 28 r lst))). (
5a80: 28 65 71 3f 20 28 63 64 72 20 6c 73 74 29 20 27 (eq? (cdr lst) '
5a90: 28 29 29 20 6c 73 74 29 29 29 0a 0a 28 64 65 66 ()) lst)))..(def
5aa0: 69 6e 65 20 28 71 75 65 75 65 2d 70 75 73 68 2d ine (queue-push-
5ab0: 62 61 63 6b 2d 6c 69 73 74 21 20 71 20 69 74 65 back-list! q ite
5ac0: 6d 6c 69 73 74 29 0a 20 20 28 23 23 73 79 73 23 mlist). (##sys#
5ad0: 63 68 65 63 6b 2d 73 74 72 75 63 74 75 72 65 20 check-structure
5ae0: 71 20 27 71 75 65 75 65 20 27 71 75 65 75 65 2d q 'queue 'queue-
5af0: 70 75 73 68 2d 62 61 63 6b 2d 6c 69 73 74 21 29 push-back-list!)
5b00: 0a 20 20 28 23 23 73 79 73 23 63 68 65 63 6b 2d . (##sys#check-
5b10: 6c 69 73 74 20 69 74 65 6d 6c 69 73 74 20 27 71 list itemlist 'q
5b20: 75 65 75 65 2d 70 75 73 68 2d 62 61 63 6b 2d 6c ueue-push-back-l
5b30: 69 73 74 21 29 0a 20 20 28 6c 65 74 2a 20 28 28 ist!). (let* ((
5b40: 6e 65 77 6c 69 73 74 20 28 61 70 70 65 6e 64 20 newlist (append
5b50: 69 74 65 6d 6c 69 73 74 20 28 23 23 73 79 73 23 itemlist (##sys#
5b60: 73 6c 6f 74 20 71 20 31 29 29 29 0a 09 20 28 6e slot q 1))).. (n
5b70: 65 77 74 61 69 6c 20 28 69 66 20 28 65 71 3f 20 ewtail (if (eq?
5b80: 6e 65 77 6c 69 73 74 20 27 28 29 29 0a 09 09 20 newlist '())...
5b90: 20 20 20 20 20 20 27 28 29 0a 09 09 20 20 20 20 '()...
5ba0: 20 20 20 28 6c 61 73 74 2d 70 61 69 72 20 6e 65 (last-pair ne
5bb0: 77 6c 69 73 74 29 29 29 29 0a 20 20 20 20 28 23 wlist)))). (#
5bc0: 23 73 79 73 23 73 65 74 73 6c 6f 74 20 71 20 31 #sys#setslot q 1
5bd0: 20 6e 65 77 6c 69 73 74 29 0a 20 20 20 20 28 23 newlist). (#
5be0: 23 73 79 73 23 73 65 74 73 6c 6f 74 20 71 20 32 #sys#setslot q 2
5bf0: 20 6e 65 77 74 61 69 6c 29 0a 20 20 20 20 28 23 newtail). (#
5c00: 23 73 79 73 23 73 65 74 69 73 6c 6f 74 20 71 20 #sys#setislot q
5c10: 33 20 28 66 78 2b 20 28 23 23 73 79 73 23 73 6c 3 (fx+ (##sys#sl
5c20: 6f 74 20 71 20 33 29 20 28 23 23 63 6f 72 65 23 ot q 3) (##core#
5c30: 69 6e 6c 69 6e 65 20 22 43 5f 69 5f 6c 65 6e 67 inline "C_i_leng
5c40: 74 68 22 20 69 74 65 6d 6c 69 73 74 29 29 29 29 th" itemlist))))
5c50: 29 0a ).