Artifact
8cb016101bf31d0f0047c1d8dfdcf7c206ad2254:
- File
fmt/fmt.scm
— part of check-in
[80c8c83034]
at
2016-07-07 18:11:39
on branch trunk
— initial import
(user:
ovenpasta@pizzahack.eu
size: 44238)
0000: 3b 3b 3b 3b 20 66 6d 74 2e 73 63 6d 20 2d 2d 20 ;;;; fmt.scm --
0010: 65 78 74 65 6e 73 69 62 6c 65 20 66 6f 72 6d 61 extensible forma
0020: 74 74 69 6e 67 20 6c 69 62 72 61 72 79 0a 3b 3b tting library.;;
0030: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 28 63 .;; Copyright (c
0040: 29 20 32 30 30 36 2d 32 30 30 39 20 41 6c 65 78 ) 2006-2009 Alex
0050: 20 53 68 69 6e 6e 2e 20 20 41 6c 6c 20 72 69 67 Shinn. All rig
0060: 68 74 73 20 72 65 73 65 72 76 65 64 2e 0a 3b 3b hts reserved..;;
0070: 20 42 53 44 2d 73 74 79 6c 65 20 6c 69 63 65 6e BSD-style licen
0080: 73 65 3a 20 68 74 74 70 3a 2f 2f 73 79 6e 74 68 se: http://synth
0090: 63 6f 64 65 2e 63 6f 6d 2f 6c 69 63 65 6e 73 65 code.com/license
00a0: 2e 74 78 74 0a 0a 3b 3b 20 28 72 65 71 75 69 72 .txt..;; (requir
00b0: 65 2d 65 78 74 65 6e 73 69 6f 6e 20 28 73 72 66 e-extension (srf
00c0: 69 20 31 20 36 20 31 33 20 32 33 20 36 39 29 29 i 1 6 13 23 69))
00d0: 0a 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ..;;;;;;;;;;;;;;
00e0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
00f0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
0100: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
0110: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 3b 20 73 ;;;;;;;;;;.;;; s
0120: 74 72 69 6e 67 20 75 74 69 6c 69 74 69 65 73 0a tring utilities.
0130: 0a 28 64 65 66 69 6e 65 20 28 77 72 69 74 65 2d .(define (write-
0140: 74 6f 2d 73 74 72 69 6e 67 20 78 29 0a 20 20 28 to-string x). (
0150: 63 61 6c 6c 2d 77 69 74 68 2d 6f 75 74 70 75 74 call-with-output
0160: 2d 73 74 72 69 6e 67 20 28 6c 61 6d 62 64 61 20 -string (lambda
0170: 28 70 29 20 28 77 72 69 74 65 20 78 20 70 29 29 (p) (write x p))
0180: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 69 73 ))..(define (dis
0190: 70 6c 61 79 2d 74 6f 2d 73 74 72 69 6e 67 20 78 play-to-string x
01a0: 29 0a 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f ). (if (string?
01b0: 20 78 29 0a 20 20 20 20 20 20 78 0a 20 20 20 20 x). x.
01c0: 20 20 28 63 61 6c 6c 2d 77 69 74 68 2d 6f 75 74 (call-with-out
01d0: 70 75 74 2d 73 74 72 69 6e 67 20 28 6c 61 6d 62 put-string (lamb
01e0: 64 61 20 28 70 29 20 28 64 69 73 70 6c 61 79 20 da (p) (display
01f0: 78 20 70 29 29 29 29 29 0a 0a 28 64 65 66 69 6e x p)))))..(defin
0200: 65 20 6e 6c 2d 73 74 72 0a 20 20 28 63 61 6c 6c e nl-str. (call
0210: 2d 77 69 74 68 2d 6f 75 74 70 75 74 2d 73 74 72 -with-output-str
0220: 69 6e 67 20 6e 65 77 6c 69 6e 65 29 29 0a 0a 28 ing newline))..(
0230: 64 65 66 69 6e 65 20 28 6d 61 6b 65 2d 73 70 61 define (make-spa
0240: 63 65 20 6e 29 20 28 6d 61 6b 65 2d 73 74 72 69 ce n) (make-stri
0250: 6e 67 20 6e 20 23 5c 73 70 61 63 65 29 29 0a 28 ng n #\space)).(
0260: 64 65 66 69 6e 65 20 28 6d 61 6b 65 2d 6e 6c 2d define (make-nl-
0270: 73 70 61 63 65 20 6e 29 20 28 73 74 72 69 6e 67 space n) (string
0280: 2d 61 70 70 65 6e 64 20 6e 6c 2d 73 74 72 20 28 -append nl-str (
0290: 6d 61 6b 65 2d 73 74 72 69 6e 67 20 6e 20 23 5c make-string n #\
02a0: 73 70 61 63 65 29 29 29 0a 0a 3b 3b 3b 3b 3b 3b space)))..;;;;;;
02b0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
02c0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
02d0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
02e0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
02f0: 3b 3b 0a 3b 3b 3b 20 6c 69 73 74 20 75 74 69 6c ;;.;;; list util
0300: 69 74 69 65 73 0a 0a 28 64 65 66 69 6e 65 20 28 ities..(define (
0310: 74 61 6b 65 2a 20 6c 73 20 6e 29 20 20 20 3b 20 take* ls n) ;
0320: 68 61 6e 64 6c 65 73 20 64 6f 74 74 65 64 20 6c handles dotted l
0330: 69 73 74 73 20 61 6e 64 20 6e 20 3e 20 6c 65 6e ists and n > len
0340: 67 74 68 0a 20 20 28 63 6f 6e 64 20 28 28 7a 65 gth. (cond ((ze
0350: 72 6f 3f 20 6e 29 20 27 28 29 29 0a 20 20 20 20 ro? n) '()).
0360: 20 20 20 20 28 28 70 61 69 72 3f 20 6c 73 29 20 ((pair? ls)
0370: 28 63 6f 6e 73 20 28 63 61 72 20 6c 73 29 20 28 (cons (car ls) (
0380: 74 61 6b 65 2a 20 28 63 64 72 20 6c 73 29 20 28 take* (cdr ls) (
0390: 2d 20 6e 20 31 29 29 29 29 0a 20 20 20 20 20 20 - n 1)))).
03a0: 20 20 28 65 6c 73 65 20 27 28 29 29 29 29 0a 0a (else '())))..
03b0: 28 64 65 66 69 6e 65 20 28 64 72 6f 70 2a 20 6c (define (drop* l
03c0: 73 20 6e 29 20 20 20 3b 20 6d 61 79 20 72 65 74 s n) ; may ret
03d0: 75 72 6e 20 74 68 65 20 64 6f 74 0a 20 20 28 63 urn the dot. (c
03e0: 6f 6e 64 20 28 28 7a 65 72 6f 3f 20 6e 29 20 6c ond ((zero? n) l
03f0: 73 29 0a 20 20 20 20 20 20 20 20 28 28 70 61 69 s). ((pai
0400: 72 3f 20 6c 73 29 20 28 64 72 6f 70 2a 20 28 63 r? ls) (drop* (c
0410: 64 72 20 6c 73 29 20 28 2d 20 6e 20 31 29 29 29 dr ls) (- n 1)))
0420: 0a 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 6c . (else l
0430: 73 29 29 29 0a 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b s)))..;;;;;;;;;;
0440: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
0450: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
0460: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
0470: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b ;;;;;;;;;;;;;;.;
0480: 3b 3b 20 66 6f 72 6d 61 74 20 73 74 61 74 65 20 ;; format state
0490: 72 65 70 72 65 73 65 6e 74 61 74 69 6f 6e 0a 0a representation..
04a0: 3b 3b 20 55 73 65 20 61 20 66 6c 65 78 69 62 6c ;; Use a flexibl
04b0: 65 20 72 65 70 72 65 73 65 6e 74 61 74 69 6f 6e e representation
04c0: 20 6f 70 74 69 6d 69 7a 65 64 20 66 6f 72 20 63 optimized for c
04d0: 6f 6d 6d 6f 6e 20 63 61 73 65 73 20 2d 0a 3b 3b ommon cases -.;;
04e0: 20 66 72 65 71 75 65 6e 74 6c 79 20 61 63 63 65 frequently acce
04f0: 73 73 65 64 20 76 61 6c 75 65 73 20 61 72 65 20 ssed values are
0500: 69 6e 20 66 69 78 65 64 20 76 65 63 74 6f 72 20 in fixed vector
0510: 73 6c 6f 74 73 2c 20 77 69 74 68 20 61 0a 3b 3b slots, with a.;;
0520: 20 60 70 72 6f 70 65 72 74 69 65 73 27 20 73 6c `properties' sl
0530: 6f 74 20 68 6f 6c 64 69 6e 67 20 61 6e 20 61 6c ot holding an al
0540: 69 73 74 20 66 6f 72 20 61 6c 6c 20 6f 74 68 65 ist for all othe
0550: 72 20 76 61 6c 75 65 73 2e 0a 0a 28 64 65 66 69 r values...(defi
0560: 6e 65 20 2a 64 65 66 61 75 6c 74 2d 66 6d 74 2d ne *default-fmt-
0570: 73 74 61 74 65 2a 0a 20 20 28 76 65 63 74 6f 72 state*. (vector
0580: 20 30 20 30 20 31 30 20 27 28 29 20 23 5c 73 70 0 0 10 '() #\sp
0590: 61 63 65 20 23 66 20 37 38 20 23 66 20 23 66 20 ace #f 78 #f #f
05a0: 23 66 20 23 66 20 23 66 20 23 66 29 29 0a 0a 28 #f #f #f #f))..(
05b0: 64 65 66 69 6e 65 20 66 6d 74 2d 73 74 61 74 65 define fmt-state
05c0: 3f 20 76 65 63 74 6f 72 3f 29 0a 0a 28 64 65 66 ? vector?)..(def
05d0: 69 6e 65 20 28 6e 65 77 2d 66 6d 74 2d 73 74 61 ine (new-fmt-sta
05e0: 74 65 20 2e 20 6f 29 0a 20 20 28 6c 65 74 20 28 te . o). (let (
05f0: 28 73 74 20 28 69 66 20 28 70 61 69 72 3f 20 6f (st (if (pair? o
0600: 29 20 28 63 61 72 20 6f 29 20 28 63 75 72 72 65 ) (car o) (curre
0610: 6e 74 2d 6f 75 74 70 75 74 2d 70 6f 72 74 29 29 nt-output-port))
0620: 29 29 0a 20 20 20 20 28 69 66 20 28 76 65 63 74 )). (if (vect
0630: 6f 72 3f 20 73 74 29 0a 20 20 20 20 20 20 20 20 or? st).
0640: 73 74 0a 20 20 20 20 20 20 20 20 28 66 6d 74 2d st. (fmt-
0650: 73 65 74 2d 77 72 69 74 65 72 21 0a 20 20 20 20 set-writer!.
0660: 20 20 20 20 20 28 66 6d 74 2d 73 65 74 2d 70 6f (fmt-set-po
0670: 72 74 21 20 28 63 6f 70 79 2d 66 6d 74 2d 73 74 rt! (copy-fmt-st
0680: 61 74 65 20 2a 64 65 66 61 75 6c 74 2d 66 6d 74 ate *default-fmt
0690: 2d 73 74 61 74 65 2a 29 20 73 74 29 0a 20 20 20 -state*) st).
06a0: 20 20 20 20 20 20 66 6d 74 2d 77 72 69 74 65 29 fmt-write)
06b0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f )))..(define (co
06c0: 70 79 2d 66 6d 74 2d 73 74 61 74 65 20 73 74 29 py-fmt-state st)
06d0: 0a 20 20 28 6c 65 74 2a 20 28 28 6c 65 6e 20 28 . (let* ((len (
06e0: 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 73 74 vector-length st
06f0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 72 65 73 )). (res
0700: 20 28 6d 61 6b 65 2d 76 65 63 74 6f 72 20 6c 65 (make-vector le
0710: 6e 29 29 29 0a 20 20 20 20 28 64 6f 20 28 28 69 n))). (do ((i
0720: 20 30 20 28 2b 20 69 20 31 29 29 29 0a 20 20 20 0 (+ i 1))).
0730: 20 20 20 20 20 28 28 3d 20 69 20 6c 65 6e 29 29 ((= i len))
0740: 0a 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 . (vector-s
0750: 65 74 21 20 72 65 73 20 69 20 28 76 65 63 74 6f et! res i (vecto
0760: 72 2d 72 65 66 20 73 74 20 69 29 29 29 0a 20 20 r-ref st i))).
0770: 20 20 28 66 6d 74 2d 73 65 74 2d 70 72 6f 70 65 (fmt-set-prope
0780: 72 74 69 65 73 21 20 72 65 73 20 28 6d 61 70 20 rties! res (map
0790: 28 6c 61 6d 62 64 61 20 28 78 29 20 28 63 6f 6e (lambda (x) (con
07a0: 73 20 28 63 61 72 20 78 29 20 28 63 64 72 20 78 s (car x) (cdr x
07b0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
07c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
07d0: 20 20 20 20 20 20 28 66 6d 74 2d 70 72 6f 70 65 (fmt-prope
07e0: 72 74 69 65 73 20 72 65 73 29 29 29 0a 20 20 20 rties res))).
07f0: 20 72 65 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 res))..(define
0800: 28 66 6d 74 2d 72 6f 77 20 73 74 29 20 28 76 65 (fmt-row st) (ve
0810: 63 74 6f 72 2d 72 65 66 20 73 74 20 30 29 29 0a ctor-ref st 0)).
0820: 28 64 65 66 69 6e 65 20 28 66 6d 74 2d 63 6f 6c (define (fmt-col
0830: 20 73 74 29 20 28 76 65 63 74 6f 72 2d 72 65 66 st) (vector-ref
0840: 20 73 74 20 31 29 29 0a 28 64 65 66 69 6e 65 20 st 1)).(define
0850: 28 66 6d 74 2d 72 61 64 69 78 20 73 74 29 20 28 (fmt-radix st) (
0860: 76 65 63 74 6f 72 2d 72 65 66 20 73 74 20 32 29 vector-ref st 2)
0870: 29 0a 28 64 65 66 69 6e 65 20 28 66 6d 74 2d 70 ).(define (fmt-p
0880: 72 6f 70 65 72 74 69 65 73 20 73 74 29 20 28 76 roperties st) (v
0890: 65 63 74 6f 72 2d 72 65 66 20 73 74 20 33 29 29 ector-ref st 3))
08a0: 0a 28 64 65 66 69 6e 65 20 28 66 6d 74 2d 70 61 .(define (fmt-pa
08b0: 64 2d 63 68 61 72 20 73 74 29 20 28 76 65 63 74 d-char st) (vect
08c0: 6f 72 2d 72 65 66 20 73 74 20 34 29 29 0a 28 64 or-ref st 4)).(d
08d0: 65 66 69 6e 65 20 28 66 6d 74 2d 70 72 65 63 69 efine (fmt-preci
08e0: 73 69 6f 6e 20 73 74 29 20 28 76 65 63 74 6f 72 sion st) (vector
08f0: 2d 72 65 66 20 73 74 20 35 29 29 0a 28 64 65 66 -ref st 5)).(def
0900: 69 6e 65 20 28 66 6d 74 2d 77 69 64 74 68 20 73 ine (fmt-width s
0910: 74 29 20 28 76 65 63 74 6f 72 2d 72 65 66 20 73 t) (vector-ref s
0920: 74 20 36 29 29 0a 28 64 65 66 69 6e 65 20 28 66 t 6)).(define (f
0930: 6d 74 2d 77 72 69 74 65 72 20 73 74 29 20 28 76 mt-writer st) (v
0940: 65 63 74 6f 72 2d 72 65 66 20 73 74 20 37 29 29 ector-ref st 7))
0950: 0a 28 64 65 66 69 6e 65 20 28 66 6d 74 2d 70 6f .(define (fmt-po
0960: 72 74 20 73 74 29 20 28 76 65 63 74 6f 72 2d 72 rt st) (vector-r
0970: 65 66 20 73 74 20 38 29 29 0a 28 64 65 66 69 6e ef st 8)).(defin
0980: 65 20 28 66 6d 74 2d 64 65 63 69 6d 61 6c 2d 73 e (fmt-decimal-s
0990: 65 70 20 73 74 29 20 28 76 65 63 74 6f 72 2d 72 ep st) (vector-r
09a0: 65 66 20 73 74 20 39 29 29 0a 28 64 65 66 69 6e ef st 9)).(defin
09b0: 65 20 28 66 6d 74 2d 64 65 63 69 6d 61 6c 2d 61 e (fmt-decimal-a
09c0: 6c 69 67 6e 20 73 74 29 20 28 76 65 63 74 6f 72 lign st) (vector
09d0: 2d 72 65 66 20 73 74 20 31 30 29 29 0a 28 64 65 -ref st 10)).(de
09e0: 66 69 6e 65 20 28 66 6d 74 2d 73 74 72 69 6e 67 fine (fmt-string
09f0: 2d 77 69 64 74 68 20 73 74 29 20 28 76 65 63 74 -width st) (vect
0a00: 6f 72 2d 72 65 66 20 73 74 20 31 31 29 29 0a 28 or-ref st 11)).(
0a10: 64 65 66 69 6e 65 20 28 66 6d 74 2d 65 6c 6c 69 define (fmt-elli
0a20: 70 73 65 73 20 73 74 29 20 28 76 65 63 74 6f 72 pses st) (vector
0a30: 2d 72 65 66 20 73 74 20 31 32 29 29 0a 0a 28 64 -ref st 12))..(d
0a40: 65 66 69 6e 65 20 28 66 6d 74 2d 73 65 74 2d 72 efine (fmt-set-r
0a50: 6f 77 21 20 73 74 20 78 29 20 28 76 65 63 74 6f ow! st x) (vecto
0a60: 72 2d 73 65 74 21 20 73 74 20 30 20 78 29 20 73 r-set! st 0 x) s
0a70: 74 29 0a 28 64 65 66 69 6e 65 20 28 66 6d 74 2d t).(define (fmt-
0a80: 73 65 74 2d 63 6f 6c 21 20 73 74 20 78 29 20 28 set-col! st x) (
0a90: 76 65 63 74 6f 72 2d 73 65 74 21 20 73 74 20 31 vector-set! st 1
0aa0: 20 78 29 20 73 74 29 0a 28 64 65 66 69 6e 65 20 x) st).(define
0ab0: 28 66 6d 74 2d 73 65 74 2d 72 61 64 69 78 21 20 (fmt-set-radix!
0ac0: 73 74 20 78 29 20 28 76 65 63 74 6f 72 2d 73 65 st x) (vector-se
0ad0: 74 21 20 73 74 20 32 20 78 29 20 73 74 29 0a 28 t! st 2 x) st).(
0ae0: 64 65 66 69 6e 65 20 28 66 6d 74 2d 73 65 74 2d define (fmt-set-
0af0: 70 72 6f 70 65 72 74 69 65 73 21 20 73 74 20 78 properties! st x
0b00: 29 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 73 ) (vector-set! s
0b10: 74 20 33 20 78 29 20 73 74 29 0a 28 64 65 66 69 t 3 x) st).(defi
0b20: 6e 65 20 28 66 6d 74 2d 73 65 74 2d 70 61 64 2d ne (fmt-set-pad-
0b30: 63 68 61 72 21 20 73 74 20 78 29 20 28 76 65 63 char! st x) (vec
0b40: 74 6f 72 2d 73 65 74 21 20 73 74 20 34 20 78 29 tor-set! st 4 x)
0b50: 20 73 74 29 0a 28 64 65 66 69 6e 65 20 28 66 6d st).(define (fm
0b60: 74 2d 73 65 74 2d 70 72 65 63 69 73 69 6f 6e 21 t-set-precision!
0b70: 20 73 74 20 78 29 20 28 76 65 63 74 6f 72 2d 73 st x) (vector-s
0b80: 65 74 21 20 73 74 20 35 20 78 29 20 73 74 29 0a et! st 5 x) st).
0b90: 28 64 65 66 69 6e 65 20 28 66 6d 74 2d 73 65 74 (define (fmt-set
0ba0: 2d 77 69 64 74 68 21 20 73 74 20 78 29 20 28 76 -width! st x) (v
0bb0: 65 63 74 6f 72 2d 73 65 74 21 20 73 74 20 36 20 ector-set! st 6
0bc0: 78 29 20 73 74 29 0a 28 64 65 66 69 6e 65 20 28 x) st).(define (
0bd0: 66 6d 74 2d 73 65 74 2d 77 72 69 74 65 72 21 20 fmt-set-writer!
0be0: 73 74 20 78 29 20 28 76 65 63 74 6f 72 2d 73 65 st x) (vector-se
0bf0: 74 21 20 73 74 20 37 20 78 29 20 73 74 29 0a 28 t! st 7 x) st).(
0c00: 64 65 66 69 6e 65 20 28 66 6d 74 2d 73 65 74 2d define (fmt-set-
0c10: 70 6f 72 74 21 20 73 74 20 78 29 20 28 76 65 63 port! st x) (vec
0c20: 74 6f 72 2d 73 65 74 21 20 73 74 20 38 20 78 29 tor-set! st 8 x)
0c30: 20 73 74 29 0a 28 64 65 66 69 6e 65 20 28 66 6d st).(define (fm
0c40: 74 2d 73 65 74 2d 64 65 63 69 6d 61 6c 2d 73 65 t-set-decimal-se
0c50: 70 21 20 73 74 20 78 29 20 28 76 65 63 74 6f 72 p! st x) (vector
0c60: 2d 73 65 74 21 20 73 74 20 39 20 78 29 20 73 74 -set! st 9 x) st
0c70: 29 0a 28 64 65 66 69 6e 65 20 28 66 6d 74 2d 73 ).(define (fmt-s
0c80: 65 74 2d 64 65 63 69 6d 61 6c 2d 61 6c 69 67 6e et-decimal-align
0c90: 21 20 73 74 20 78 29 20 28 76 65 63 74 6f 72 2d ! st x) (vector-
0ca0: 73 65 74 21 20 73 74 20 31 30 20 78 29 20 73 74 set! st 10 x) st
0cb0: 29 0a 28 64 65 66 69 6e 65 20 28 66 6d 74 2d 73 ).(define (fmt-s
0cc0: 65 74 2d 73 74 72 69 6e 67 2d 77 69 64 74 68 21 et-string-width!
0cd0: 20 73 74 20 78 29 20 28 76 65 63 74 6f 72 2d 73 st x) (vector-s
0ce0: 65 74 21 20 73 74 20 31 31 20 78 29 20 73 74 29 et! st 11 x) st)
0cf0: 0a 28 64 65 66 69 6e 65 20 28 66 6d 74 2d 73 65 .(define (fmt-se
0d00: 74 2d 65 6c 6c 69 70 73 65 73 21 20 73 74 20 78 t-ellipses! st x
0d10: 29 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 73 ) (vector-set! s
0d20: 74 20 31 32 20 78 29 20 73 74 29 0a 0a 28 64 65 t 12 x) st)..(de
0d30: 66 69 6e 65 20 28 66 6d 74 2d 72 65 66 20 73 74 fine (fmt-ref st
0d40: 20 6b 65 79 20 2e 20 6f 29 0a 20 20 28 63 61 73 key . o). (cas
0d50: 65 20 6b 65 79 0a 20 20 20 20 28 28 72 6f 77 29 e key. ((row)
0d60: 20 28 66 6d 74 2d 72 6f 77 20 73 74 29 29 0a 20 (fmt-row st)).
0d70: 20 20 20 28 28 63 6f 6c 29 20 28 66 6d 74 2d 63 ((col) (fmt-c
0d80: 6f 6c 20 73 74 29 29 0a 20 20 20 20 28 28 72 61 ol st)). ((ra
0d90: 64 69 78 29 20 28 66 6d 74 2d 72 61 64 69 78 20 dix) (fmt-radix
0da0: 73 74 29 29 0a 20 20 20 20 28 28 70 72 6f 70 65 st)). ((prope
0db0: 72 74 69 65 73 29 20 28 66 6d 74 2d 70 72 6f 70 rties) (fmt-prop
0dc0: 65 72 74 69 65 73 20 73 74 29 29 0a 20 20 20 20 erties st)).
0dd0: 28 28 77 72 69 74 65 72 29 20 28 66 6d 74 2d 77 ((writer) (fmt-w
0de0: 72 69 74 65 72 20 73 74 29 29 0a 20 20 20 20 28 riter st)). (
0df0: 28 70 6f 72 74 29 20 28 66 6d 74 2d 70 6f 72 74 (port) (fmt-port
0e00: 20 73 74 29 29 0a 20 20 20 20 28 28 70 72 65 63 st)). ((prec
0e10: 69 73 69 6f 6e 29 20 28 66 6d 74 2d 70 72 65 63 ision) (fmt-prec
0e20: 69 73 69 6f 6e 20 73 74 29 29 0a 20 20 20 20 28 ision st)). (
0e30: 28 70 61 64 2d 63 68 61 72 29 20 28 66 6d 74 2d (pad-char) (fmt-
0e40: 70 61 64 2d 63 68 61 72 20 73 74 29 29 0a 20 20 pad-char st)).
0e50: 20 20 28 28 77 69 64 74 68 29 20 28 66 6d 74 2d ((width) (fmt-
0e60: 77 69 64 74 68 20 73 74 29 29 0a 20 20 20 20 28 width st)). (
0e70: 28 64 65 63 69 6d 61 6c 2d 73 65 70 29 20 28 66 (decimal-sep) (f
0e80: 6d 74 2d 64 65 63 69 6d 61 6c 2d 73 65 70 20 73 mt-decimal-sep s
0e90: 74 29 29 0a 20 20 20 20 28 28 64 65 63 69 6d 61 t)). ((decima
0ea0: 6c 2d 61 6c 69 67 6e 29 20 28 66 6d 74 2d 64 65 l-align) (fmt-de
0eb0: 63 69 6d 61 6c 2d 61 6c 69 67 6e 20 73 74 29 29 cimal-align st))
0ec0: 0a 20 20 20 20 28 28 73 74 72 69 6e 67 2d 77 69 . ((string-wi
0ed0: 64 74 68 29 20 28 66 6d 74 2d 73 74 72 69 6e 67 dth) (fmt-string
0ee0: 2d 77 69 64 74 68 20 73 74 29 29 0a 20 20 20 20 -width st)).
0ef0: 28 28 65 6c 6c 69 70 73 65 73 29 20 28 66 6d 74 ((ellipses) (fmt
0f00: 2d 65 6c 6c 69 70 73 65 73 20 73 74 29 29 0a 20 -ellipses st)).
0f10: 20 20 20 28 65 6c 73 65 20 28 63 6f 6e 64 20 28 (else (cond (
0f20: 28 61 73 73 71 20 6b 65 79 20 28 66 6d 74 2d 70 (assq key (fmt-p
0f30: 72 6f 70 65 72 74 69 65 73 20 73 74 29 29 20 3d roperties st)) =
0f40: 3e 20 63 64 72 29 0a 20 20 20 20 20 20 20 20 20 > cdr).
0f50: 20 20 20 20 20 20 20 28 28 70 61 69 72 3f 20 6f ((pair? o
0f60: 29 20 28 63 61 72 20 6f 29 29 0a 20 20 20 20 20 ) (car o)).
0f70: 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 (else
0f80: 20 23 66 29 29 29 29 29 0a 0a 28 64 65 66 69 6e #f)))))..(defin
0f90: 65 20 28 66 6d 74 2d 73 65 74 2d 70 72 6f 70 65 e (fmt-set-prope
0fa0: 72 74 79 21 20 73 74 20 6b 65 79 20 76 61 6c 29 rty! st key val)
0fb0: 0a 20 20 28 63 6f 6e 64 20 28 28 61 73 73 71 20 . (cond ((assq
0fc0: 6b 65 79 20 28 66 6d 74 2d 70 72 6f 70 65 72 74 key (fmt-propert
0fd0: 69 65 73 20 73 74 29 29 0a 20 20 20 20 20 20 20 ies st)).
0fe0: 20 20 3d 3e 20 28 6c 61 6d 62 64 61 20 28 63 65 => (lambda (ce
0ff0: 6c 6c 29 20 28 73 65 74 2d 63 64 72 21 20 63 65 ll) (set-cdr! ce
1000: 6c 6c 20 76 61 6c 29 20 73 74 29 29 0a 20 20 20 ll val) st)).
1010: 20 20 20 20 20 28 65 6c 73 65 20 28 66 6d 74 2d (else (fmt-
1020: 73 65 74 2d 70 72 6f 70 65 72 74 69 65 73 21 0a set-properties!.
1030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 73 s
1040: 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t.
1050: 20 28 63 6f 6e 73 20 28 63 6f 6e 73 20 6b 65 79 (cons (cons key
1060: 20 76 61 6c 29 20 28 66 6d 74 2d 70 72 6f 70 65 val) (fmt-prope
1070: 72 74 69 65 73 20 73 74 29 29 29 29 29 29 0a 0a rties st))))))..
1080: 28 64 65 66 69 6e 65 20 28 66 6d 74 2d 73 65 74 (define (fmt-set
1090: 21 20 73 74 20 6b 65 79 20 76 61 6c 29 0a 20 20 ! st key val).
10a0: 28 63 61 73 65 20 6b 65 79 0a 20 20 20 20 28 28 (case key. ((
10b0: 72 6f 77 29 20 28 66 6d 74 2d 73 65 74 2d 72 6f row) (fmt-set-ro
10c0: 77 21 20 73 74 20 76 61 6c 29 29 0a 20 20 20 20 w! st val)).
10d0: 28 28 63 6f 6c 29 20 28 66 6d 74 2d 73 65 74 2d ((col) (fmt-set-
10e0: 63 6f 6c 21 20 73 74 20 76 61 6c 29 29 0a 20 20 col! st val)).
10f0: 20 20 28 28 72 61 64 69 78 29 20 28 66 6d 74 2d ((radix) (fmt-
1100: 73 65 74 2d 72 61 64 69 78 21 20 73 74 20 76 61 set-radix! st va
1110: 6c 29 29 0a 20 20 20 20 28 28 70 72 6f 70 65 72 l)). ((proper
1120: 74 69 65 73 29 20 28 66 6d 74 2d 73 65 74 2d 70 ties) (fmt-set-p
1130: 72 6f 70 65 72 74 69 65 73 21 20 73 74 20 76 61 roperties! st va
1140: 6c 29 29 0a 20 20 20 20 28 28 70 61 64 2d 63 68 l)). ((pad-ch
1150: 61 72 29 20 28 66 6d 74 2d 73 65 74 2d 70 61 64 ar) (fmt-set-pad
1160: 2d 63 68 61 72 21 20 73 74 20 76 61 6c 29 29 0a -char! st val)).
1170: 20 20 20 20 28 28 70 72 65 63 69 73 69 6f 6e 29 ((precision)
1180: 20 28 66 6d 74 2d 73 65 74 2d 70 72 65 63 69 73 (fmt-set-precis
1190: 69 6f 6e 21 20 73 74 20 76 61 6c 29 29 0a 20 20 ion! st val)).
11a0: 20 20 28 28 77 72 69 74 65 72 29 20 28 66 6d 74 ((writer) (fmt
11b0: 2d 73 65 74 2d 77 72 69 74 65 72 21 20 73 74 20 -set-writer! st
11c0: 76 61 6c 29 29 0a 20 20 20 20 28 28 70 6f 72 74 val)). ((port
11d0: 29 20 28 66 6d 74 2d 73 65 74 2d 70 6f 72 74 21 ) (fmt-set-port!
11e0: 20 73 74 20 76 61 6c 29 29 0a 20 20 20 20 28 28 st val)). ((
11f0: 77 69 64 74 68 29 20 28 66 6d 74 2d 73 65 74 2d width) (fmt-set-
1200: 77 69 64 74 68 21 20 73 74 20 76 61 6c 29 29 0a width! st val)).
1210: 20 20 20 20 28 28 64 65 63 69 6d 61 6c 2d 73 65 ((decimal-se
1220: 70 29 20 28 66 6d 74 2d 73 65 74 2d 64 65 63 69 p) (fmt-set-deci
1230: 6d 61 6c 2d 73 65 70 21 20 73 74 20 76 61 6c 29 mal-sep! st val)
1240: 29 0a 20 20 20 20 28 28 64 65 63 69 6d 61 6c 2d ). ((decimal-
1250: 61 6c 69 67 6e 29 20 28 66 6d 74 2d 73 65 74 2d align) (fmt-set-
1260: 64 65 63 69 6d 61 6c 2d 61 6c 69 67 6e 21 20 73 decimal-align! s
1270: 74 20 76 61 6c 29 29 0a 20 20 20 20 28 28 73 74 t val)). ((st
1280: 72 69 6e 67 2d 77 69 64 74 68 29 20 28 66 6d 74 ring-width) (fmt
1290: 2d 73 65 74 2d 73 74 72 69 6e 67 2d 77 69 64 74 -set-string-widt
12a0: 68 21 20 73 74 20 76 61 6c 29 29 0a 20 20 20 20 h! st val)).
12b0: 28 28 65 6c 6c 69 70 73 65 73 29 20 28 66 6d 74 ((ellipses) (fmt
12c0: 2d 73 65 74 2d 65 6c 6c 69 70 73 65 73 21 20 73 -set-ellipses! s
12d0: 74 20 76 61 6c 29 29 0a 20 20 20 20 28 65 6c 73 t val)). (els
12e0: 65 20 28 66 6d 74 2d 73 65 74 2d 70 72 6f 70 65 e (fmt-set-prope
12f0: 72 74 79 21 20 73 74 20 6b 65 79 20 76 61 6c 29 rty! st key val)
1300: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 66 6d )))..(define (fm
1310: 74 2d 61 64 64 2d 70 72 6f 70 65 72 74 69 65 73 t-add-properties
1320: 21 20 73 74 20 61 6c 69 73 74 29 0a 20 20 28 66 ! st alist). (f
1330: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
1340: 28 78 29 20 28 66 6d 74 2d 73 65 74 21 20 73 74 (x) (fmt-set! st
1350: 20 28 63 61 72 20 78 29 20 28 63 64 72 20 78 29 (car x) (cdr x)
1360: 29 29 20 61 6c 69 73 74 29 0a 20 20 73 74 29 0a )) alist). st).
1370: 0a 28 64 65 66 69 6e 65 20 28 66 6d 74 2d 6c 65 .(define (fmt-le
1380: 74 20 6b 65 79 20 76 61 6c 20 2e 20 6c 73 29 0a t key val . ls).
1390: 20 20 28 6c 61 6d 62 64 61 20 28 73 74 29 0a 20 (lambda (st).
13a0: 20 20 20 28 6c 65 74 20 28 28 6f 72 69 67 2d 76 (let ((orig-v
13b0: 61 6c 20 28 66 6d 74 2d 72 65 66 20 73 74 20 6b al (fmt-ref st k
13c0: 65 79 29 29 29 0a 20 20 20 20 20 20 28 66 6d 74 ey))). (fmt
13d0: 2d 73 65 74 21 20 28 28 61 70 70 6c 79 2d 63 61 -set! ((apply-ca
13e0: 74 20 6c 73 29 20 28 66 6d 74 2d 73 65 74 21 20 t ls) (fmt-set!
13f0: 73 74 20 6b 65 79 20 76 61 6c 29 29 20 6b 65 79 st key val)) key
1400: 20 6f 72 69 67 2d 76 61 6c 29 29 29 29 0a 0a 28 orig-val))))..(
1410: 64 65 66 69 6e 65 20 28 66 6d 74 2d 62 69 6e 64 define (fmt-bind
1420: 20 6b 65 79 20 76 61 6c 20 2e 20 6c 73 29 0a 20 key val . ls).
1430: 20 28 6c 61 6d 62 64 61 20 28 73 74 29 20 28 28 (lambda (st) ((
1440: 61 70 70 6c 79 2d 63 61 74 20 6c 73 29 20 28 66 apply-cat ls) (f
1450: 6d 74 2d 73 65 74 21 20 73 74 20 6b 65 79 20 76 mt-set! st key v
1460: 61 6c 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 al))))..(define
1470: 28 66 69 78 20 70 72 65 63 20 2e 20 6c 73 29 20 (fix prec . ls)
1480: 28 66 6d 74 2d 6c 65 74 20 27 70 72 65 63 69 73 (fmt-let 'precis
1490: 69 6f 6e 20 70 72 65 63 20 28 61 70 70 6c 79 2d ion prec (apply-
14a0: 63 61 74 20 6c 73 29 29 29 0a 28 64 65 66 69 6e cat ls))).(defin
14b0: 65 20 28 72 61 64 69 78 20 72 61 64 20 2e 20 6c e (radix rad . l
14c0: 73 29 20 28 66 6d 74 2d 6c 65 74 20 27 72 61 64 s) (fmt-let 'rad
14d0: 69 78 20 72 61 64 20 28 61 70 70 6c 79 2d 63 61 ix rad (apply-ca
14e0: 74 20 6c 73 29 29 29 0a 28 64 65 66 69 6e 65 20 t ls))).(define
14f0: 28 70 61 64 2d 63 68 61 72 20 63 68 20 2e 20 6c (pad-char ch . l
1500: 73 29 20 28 66 6d 74 2d 6c 65 74 20 27 70 61 64 s) (fmt-let 'pad
1510: 2d 63 68 61 72 20 63 68 20 28 61 70 70 6c 79 2d -char ch (apply-
1520: 63 61 74 20 6c 73 29 29 29 0a 28 64 65 66 69 6e cat ls))).(defin
1530: 65 20 28 63 6f 6d 6d 61 2d 63 68 61 72 20 63 68 e (comma-char ch
1540: 20 2e 20 6c 73 29 20 28 66 6d 74 2d 6c 65 74 20 . ls) (fmt-let
1550: 27 63 6f 6d 6d 61 2d 63 68 61 72 20 63 68 20 28 'comma-char ch (
1560: 61 70 70 6c 79 2d 63 61 74 20 6c 73 29 29 29 0a apply-cat ls))).
1570: 28 64 65 66 69 6e 65 20 28 64 65 63 69 6d 61 6c (define (decimal
1580: 2d 63 68 61 72 20 63 68 20 2e 20 6c 73 29 20 28 -char ch . ls) (
1590: 66 6d 74 2d 6c 65 74 20 27 64 65 63 69 6d 61 6c fmt-let 'decimal
15a0: 2d 73 65 70 20 63 68 20 28 61 70 70 6c 79 2d 63 -sep ch (apply-c
15b0: 61 74 20 6c 73 29 29 29 0a 28 64 65 66 69 6e 65 at ls))).(define
15c0: 20 28 64 65 63 69 6d 61 6c 2d 61 6c 69 67 6e 20 (decimal-align
15d0: 6e 20 2e 20 6c 73 29 20 28 66 6d 74 2d 6c 65 74 n . ls) (fmt-let
15e0: 20 27 64 65 63 69 6d 61 6c 2d 61 6c 69 67 6e 20 'decimal-align
15f0: 6e 20 28 61 70 70 6c 79 2d 63 61 74 20 6c 73 29 n (apply-cat ls)
1600: 29 29 0a 28 64 65 66 69 6e 65 20 28 77 69 74 68 )).(define (with
1610: 2d 77 69 64 74 68 20 77 20 2e 20 6c 73 29 20 28 -width w . ls) (
1620: 66 6d 74 2d 6c 65 74 20 27 77 69 64 74 68 20 77 fmt-let 'width w
1630: 20 28 61 70 70 6c 79 2d 63 61 74 20 6c 73 29 29 (apply-cat ls))
1640: 29 0a 28 64 65 66 69 6e 65 20 28 65 6c 6c 69 70 ).(define (ellip
1650: 73 65 73 20 65 6c 6c 20 2e 20 6c 73 29 20 28 66 ses ell . ls) (f
1660: 6d 74 2d 6c 65 74 20 27 65 6c 6c 69 70 73 65 73 mt-let 'ellipses
1670: 20 65 6c 6c 20 28 61 70 70 6c 79 2d 63 61 74 20 ell (apply-cat
1680: 6c 73 29 29 29 0a 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b ls)))..;;;;;;;;;
1690: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
16a0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
16b0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
16c0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a ;;;;;;;;;;;;;;;.
16d0: 3b 3b 3b 20 74 68 65 20 62 61 73 69 63 20 69 6e ;;; the basic in
16e0: 74 65 72 66 61 63 65 0a 0a 28 64 65 66 69 6e 65 terface..(define
16f0: 20 28 66 6d 74 2d 73 74 61 72 74 20 73 74 20 69 (fmt-start st i
1700: 6e 69 74 69 61 6c 69 7a 65 72 20 70 72 6f 63 29 nitializer proc)
1710: 0a 20 20 28 63 6f 6e 64 0a 20 20 20 20 28 28 6f . (cond. ((o
1720: 72 20 28 6f 75 74 70 75 74 2d 70 6f 72 74 3f 20 r (output-port?
1730: 73 74 29 20 28 66 6d 74 2d 73 74 61 74 65 3f 20 st) (fmt-state?
1740: 73 74 29 29 0a 20 20 20 20 20 28 70 72 6f 63 20 st)). (proc
1750: 28 69 6e 69 74 69 61 6c 69 7a 65 72 20 73 74 29 (initializer st)
1760: 29 0a 20 20 20 20 20 28 69 66 20 23 66 20 23 66 ). (if #f #f
1770: 29 29 0a 20 20 20 20 28 28 65 71 3f 20 23 74 20 )). ((eq? #t
1780: 73 74 29 0a 20 20 20 20 20 28 70 72 6f 63 20 28 st). (proc (
1790: 69 6e 69 74 69 61 6c 69 7a 65 72 20 28 63 75 72 initializer (cur
17a0: 72 65 6e 74 2d 6f 75 74 70 75 74 2d 70 6f 72 74 rent-output-port
17b0: 29 29 29 0a 20 20 20 20 20 28 69 66 20 23 66 20 ))). (if #f
17c0: 23 66 29 29 0a 20 20 20 20 28 28 65 71 3f 20 23 #f)). ((eq? #
17d0: 66 20 73 74 29 0a 20 20 20 20 20 28 67 65 74 2d f st). (get-
17e0: 6f 75 74 70 75 74 2d 73 74 72 69 6e 67 0a 20 20 output-string.
17f0: 20 20 20 20 28 66 6d 74 2d 70 6f 72 74 20 28 70 (fmt-port (p
1800: 72 6f 63 20 28 69 6e 69 74 69 61 6c 69 7a 65 72 roc (initializer
1810: 20 28 6f 70 65 6e 2d 6f 75 74 70 75 74 2d 73 74 (open-output-st
1820: 72 69 6e 67 29 29 29 29 29 29 0a 20 20 20 20 28 ring)))))). (
1830: 65 6c 73 65 20 28 65 72 72 6f 72 20 22 75 6e 6b else (error "unk
1840: 6e 6f 77 6e 20 66 6f 72 6d 61 74 20 6f 75 74 70 nown format outp
1850: 75 74 22 20 73 74 29 29 29 29 0a 0a 28 64 65 66 ut" st))))..(def
1860: 69 6e 65 20 28 66 6d 74 20 73 74 20 2e 20 61 72 ine (fmt st . ar
1870: 67 73 29 0a 20 20 28 66 6d 74 2d 73 74 61 72 74 gs). (fmt-start
1880: 20 73 74 20 6e 65 77 2d 66 6d 74 2d 73 74 61 74 st new-fmt-stat
1890: 65 20 28 61 70 70 6c 79 2d 63 61 74 20 61 72 67 e (apply-cat arg
18a0: 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 66 s)))..(define (f
18b0: 6d 74 2d 75 70 64 61 74 65 20 73 74 72 20 73 74 mt-update str st
18c0: 29 0a 20 20 28 6c 65 74 20 28 28 6c 65 6e 20 28 ). (let ((len (
18d0: 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 73 74 string-length st
18e0: 72 29 29 0a 20 20 20 20 20 20 20 20 28 6e 6c 69 r)). (nli
18f0: 20 28 73 74 72 69 6e 67 2d 69 6e 64 65 78 2d 72 (string-index-r
1900: 69 67 68 74 20 73 74 72 20 23 5c 6e 65 77 6c 69 ight str #\newli
1910: 6e 65 29 29 0a 20 20 20 20 20 20 20 20 28 73 74 ne)). (st
1920: 72 2d 77 69 64 74 68 20 28 66 6d 74 2d 73 74 72 r-width (fmt-str
1930: 69 6e 67 2d 77 69 64 74 68 20 73 74 29 29 29 0a ing-width st))).
1940: 20 20 20 20 28 69 66 20 6e 6c 69 0a 20 20 20 20 (if nli.
1950: 20 20 20 20 28 6c 65 74 20 28 28 72 6f 77 20 28 (let ((row (
1960: 2b 20 28 66 6d 74 2d 72 6f 77 20 73 74 29 20 31 + (fmt-row st) 1
1970: 20 28 73 74 72 69 6e 67 2d 63 6f 75 6e 74 20 73 (string-count s
1980: 74 72 20 23 5c 6e 65 77 6c 69 6e 65 20 30 20 6e tr #\newline 0 n
1990: 6c 69 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 li)))).
19a0: 20 28 66 6d 74 2d 73 65 74 2d 72 6f 77 21 0a 20 (fmt-set-row!.
19b0: 20 20 20 20 20 20 20 20 20 20 28 66 6d 74 2d 73 (fmt-s
19c0: 65 74 2d 63 6f 6c 21 20 73 74 20 28 69 66 20 73 et-col! st (if s
19d0: 74 72 2d 77 69 64 74 68 0a 20 20 20 20 20 20 20 tr-width.
19e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
19f0: 20 20 20 20 20 20 20 20 20 28 73 74 72 2d 77 69 (str-wi
1a00: 64 74 68 20 73 74 72 20 28 2b 20 6e 6c 69 20 31 dth str (+ nli 1
1a10: 29 20 6c 65 6e 29 0a 20 20 20 20 20 20 20 20 20 ) len).
1a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1a30: 20 20 20 20 20 20 20 28 2d 20 6c 65 6e 20 28 2b (- len (+
1a40: 20 6e 6c 69 20 31 29 29 29 29 0a 20 20 20 20 20 nli 1)))).
1a50: 20 20 20 20 20 20 72 6f 77 29 29 0a 20 20 20 20 row)).
1a60: 20 20 20 20 28 66 6d 74 2d 73 65 74 2d 63 6f 6c (fmt-set-col
1a70: 21 20 73 74 20 28 2b 20 28 66 6d 74 2d 63 6f 6c ! st (+ (fmt-col
1a80: 20 73 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 st).
1a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1aa0: 20 28 69 66 20 73 74 72 2d 77 69 64 74 68 0a 20 (if str-width.
1ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
1ad0: 73 74 72 2d 77 69 64 74 68 20 73 74 72 20 30 20 str-width str 0
1ae0: 6c 65 6e 29 0a 20 20 20 20 20 20 20 20 20 20 20 len).
1af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1b00: 20 20 20 20 20 6c 65 6e 29 29 29 29 29 29 0a 0a len))))))..
1b10: 28 64 65 66 69 6e 65 20 28 66 6d 74 2d 77 72 69 (define (fmt-wri
1b20: 74 65 20 73 74 72 20 73 74 29 0a 20 20 28 64 69 te str st). (di
1b30: 73 70 6c 61 79 20 73 74 72 20 28 66 6d 74 2d 70 splay str (fmt-p
1b40: 6f 72 74 20 73 74 29 29 0a 20 20 28 66 6d 74 2d ort st)). (fmt-
1b50: 75 70 64 61 74 65 20 73 74 72 20 73 74 29 29 0a update str st)).
1b60: 0a 28 64 65 66 69 6e 65 20 28 61 70 70 6c 79 2d .(define (apply-
1b70: 63 61 74 20 70 72 6f 63 73 29 0a 20 20 28 6c 61 cat procs). (la
1b80: 6d 62 64 61 20 28 73 74 29 0a 20 20 20 20 28 6c mbda (st). (l
1b90: 65 74 20 6c 6f 6f 70 20 28 28 6c 73 20 70 72 6f et loop ((ls pro
1ba0: 63 73 29 20 28 73 74 20 73 74 29 29 0a 20 20 20 cs) (st st)).
1bb0: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6c 73 (if (null? ls
1bc0: 29 0a 20 20 20 20 20 20 20 20 20 20 73 74 0a 20 ). st.
1bd0: 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 (loop (
1be0: 63 64 72 20 6c 73 29 20 28 28 64 73 70 20 28 63 cdr ls) ((dsp (c
1bf0: 61 72 20 6c 73 29 29 20 73 74 29 29 29 29 29 29 ar ls)) st))))))
1c00: 0a 0a 28 64 65 66 69 6e 65 20 28 63 61 74 20 2e ..(define (cat .
1c10: 20 6c 73 29 20 28 61 70 70 6c 79 2d 63 61 74 20 ls) (apply-cat
1c20: 6c 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 66 ls))..(define (f
1c30: 6d 74 2d 6e 75 6c 6c 20 73 74 29 20 73 74 29 0a mt-null st) st).
1c40: 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b .;;;;;;;;;;;;;;;
1c50: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1c60: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1c70: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1c80: 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 3b 20 63 6f ;;;;;;;;;.;;; co
1c90: 6e 74 72 6f 6c 20 73 74 72 75 63 74 75 72 65 73 ntrol structures
1ca0: 0a 0a 28 64 65 66 69 6e 65 20 28 66 6d 74 2d 69 ..(define (fmt-i
1cb0: 66 20 63 68 65 63 6b 20 70 61 73 73 20 2e 20 6f f check pass . o
1cc0: 29 0a 20 20 28 6c 65 74 20 28 28 66 61 69 6c 20 ). (let ((fail
1cd0: 28 69 66 20 28 70 61 69 72 3f 20 6f 29 20 28 63 (if (pair? o) (c
1ce0: 61 72 20 6f 29 20 28 6c 61 6d 62 64 61 20 28 78 ar o) (lambda (x
1cf0: 29 20 78 29 29 29 29 0a 20 20 20 20 28 6c 61 6d ) x)))). (lam
1d00: 62 64 61 20 28 73 74 29 20 28 69 66 20 28 63 68 bda (st) (if (ch
1d10: 65 63 6b 20 73 74 29 20 28 28 64 73 70 20 70 61 eck st) ((dsp pa
1d20: 73 73 29 20 73 74 29 20 28 28 64 73 70 20 66 61 ss) st) ((dsp fa
1d30: 69 6c 29 20 73 74 29 29 29 29 29 0a 0a 28 64 65 il) st)))))..(de
1d40: 66 69 6e 65 20 28 66 6d 74 2d 74 72 79 2d 66 69 fine (fmt-try-fi
1d50: 74 20 70 72 6f 63 20 2e 20 66 61 69 6c 29 0a 20 t proc . fail).
1d60: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 66 61 69 6c (if (null? fail
1d70: 29 0a 20 20 20 20 20 20 70 72 6f 63 0a 20 20 20 ). proc.
1d80: 20 20 20 28 6c 61 6d 62 64 61 20 28 6f 72 69 67 (lambda (orig
1d90: 2d 73 74 29 0a 20 20 20 20 20 20 20 20 28 6c 65 -st). (le
1da0: 74 20 28 28 77 69 64 74 68 20 28 66 6d 74 2d 77 t ((width (fmt-w
1db0: 69 64 74 68 20 6f 72 69 67 2d 73 74 29 29 0a 20 idth orig-st)).
1dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 75 (bu
1dd0: 66 66 65 72 20 27 28 29 29 29 0a 20 20 20 20 20 ffer '())).
1de0: 20 20 20 20 20 28 63 61 6c 6c 2d 77 69 74 68 2d (call-with-
1df0: 63 75 72 72 65 6e 74 2d 63 6f 6e 74 69 6e 75 61 current-continua
1e00: 74 69 6f 6e 0a 20 20 20 20 20 20 20 20 20 20 20 tion.
1e10: 20 28 6c 61 6d 62 64 61 20 28 72 65 74 75 72 6e (lambda (return
1e20: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
1e30: 28 64 65 66 69 6e 65 20 28 6f 75 74 70 75 74 2a (define (output*
1e40: 20 73 74 72 20 73 74 29 0a 20 20 20 20 20 20 20 str st).
1e50: 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 6c 70 (let lp
1e60: 20 28 28 69 20 30 29 20 28 63 6f 6c 20 28 66 6d ((i 0) (col (fm
1e70: 74 2d 63 6f 6c 20 73 74 29 29 29 0a 20 20 20 20 t-col st))).
1e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
1e90: 65 74 20 28 28 6e 6c 69 20 28 73 74 72 69 6e 67 et ((nli (string
1ea0: 2d 69 6e 64 65 78 20 73 74 72 20 23 5c 6e 65 77 -index str #\new
1eb0: 6c 69 6e 65 20 69 29 29 29 0a 20 20 20 20 20 20 line i))).
1ec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
1ed0: 66 20 6e 6c 69 0a 20 20 20 20 20 20 20 20 20 20 f nli.
1ee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
1ef0: 66 20 28 3e 20 28 2b 20 28 2d 20 6e 6c 69 20 69 f (> (+ (- nli i
1f00: 29 20 63 6f 6c 29 20 77 69 64 74 68 29 0a 20 20 ) col) width).
1f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1f20: 20 20 20 20 20 20 20 20 20 20 28 72 65 74 75 72 (retur
1f30: 6e 20 28 28 61 70 70 6c 79 20 66 6d 74 2d 74 72 n ((apply fmt-tr
1f40: 79 2d 66 69 74 20 66 61 69 6c 29 20 6f 72 69 67 y-fit fail) orig
1f50: 2d 73 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 -st)).
1f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1f70: 20 20 28 6c 70 20 28 2b 20 6e 6c 69 20 31 29 20 (lp (+ nli 1)
1f80: 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 0)).
1f90: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
1fa0: 2a 20 28 28 6c 65 6e 20 28 28 6f 72 20 28 66 6d * ((len ((or (fm
1fb0: 74 2d 73 74 72 69 6e 67 2d 77 69 64 74 68 20 73 t-string-width s
1fc0: 74 29 20 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 t) string-length
1fd0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
1fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ff0: 20 20 20 20 20 20 20 73 74 72 29 29 0a 20 20 20 str)).
2000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2010: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6c (col
2020: 20 28 2b 20 28 2d 20 6c 65 6e 20 69 29 20 63 6f (+ (- len i) co
2030: 6c 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 l))).
2040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2050: 69 66 20 28 3e 20 63 6f 6c 20 77 69 64 74 68 29 if (> col width)
2060: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2080: 72 65 74 75 72 6e 20 28 28 61 70 70 6c 79 20 66 return ((apply f
2090: 6d 74 2d 74 72 79 2d 66 69 74 20 66 61 69 6c 29 mt-try-fit fail)
20a0: 20 6f 72 69 67 2d 73 74 29 29 0a 20 20 20 20 20 orig-st)).
20b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
20c0: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
20d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
20e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
20f0: 28 73 65 74 21 20 62 75 66 66 65 72 20 28 63 6f (set! buffer (co
2100: 6e 73 20 73 74 72 20 62 75 66 66 65 72 29 29 0a ns str buffer)).
2110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2130: 28 66 6d 74 2d 75 70 64 61 74 65 20 73 74 72 20 (fmt-update str
2140: 73 74 29 29 29 29 29 29 29 29 0a 20 20 20 20 20 st)))))))).
2150: 20 20 20 20 20 20 20 20 20 28 70 72 6f 63 20 28 (proc (
2160: 66 6d 74 2d 73 65 74 2d 70 6f 72 74 21 20 28 66 fmt-set-port! (f
2170: 6d 74 2d 73 65 74 2d 77 72 69 74 65 72 21 20 28 mt-set-writer! (
2180: 63 6f 70 79 2d 66 6d 74 2d 73 74 61 74 65 20 6f copy-fmt-state o
2190: 72 69 67 2d 73 74 29 0a 20 20 20 20 20 20 20 20 rig-st).
21a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
21b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
21c0: 20 20 20 20 20 20 20 20 20 20 20 20 6f 75 74 70 outp
21d0: 75 74 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 ut*).
21e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
21f0: 20 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 6f 75 (open-ou
2200: 74 70 75 74 2d 73 74 72 69 6e 67 29 29 29 0a 20 tput-string))).
2210: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 66 ((f
2220: 6d 74 2d 77 72 69 74 65 72 20 6f 72 69 67 2d 73 mt-writer orig-s
2230: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t).
2240: 20 20 28 73 74 72 69 6e 67 2d 63 6f 6e 63 61 74 (string-concat
2250: 65 6e 61 74 65 2d 72 65 76 65 72 73 65 20 62 75 enate-reverse bu
2260: 66 66 65 72 29 0a 20 20 20 20 20 20 20 20 20 20 ffer).
2270: 20 20 20 20 20 6f 72 69 67 2d 73 74 29 29 29 29 orig-st))))
2280: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 66 69 )))..(define (fi
2290: 74 73 2d 69 6e 2d 77 69 64 74 68 20 67 65 6e 20 ts-in-width gen
22a0: 77 69 64 74 68 29 0a 20 20 28 6c 61 6d 62 64 61 width). (lambda
22b0: 20 28 73 74 29 0a 20 20 20 20 28 6c 65 74 20 28 (st). (let (
22c0: 28 6f 75 74 70 75 74 20 28 66 6d 74 2d 77 72 69 (output (fmt-wri
22d0: 74 65 72 20 73 74 29 29 0a 20 20 20 20 20 20 20 ter st)).
22e0: 20 20 20 28 70 6f 72 74 20 28 6f 70 65 6e 2d 6f (port (open-o
22f0: 75 74 70 75 74 2d 73 74 72 69 6e 67 29 29 29 0a utput-string))).
2300: 20 20 20 20 20 20 28 63 61 6c 6c 2d 77 69 74 68 (call-with
2310: 2d 63 75 72 72 65 6e 74 2d 63 6f 6e 74 69 6e 75 -current-continu
2320: 61 74 69 6f 6e 0a 20 20 20 20 20 20 20 20 28 6c ation. (l
2330: 61 6d 62 64 61 20 28 72 65 74 75 72 6e 29 0a 20 ambda (return).
2340: 20 20 20 20 20 20 20 20 20 28 64 65 66 69 6e 65 (define
2350: 20 28 6f 75 74 70 75 74 2a 20 73 74 72 20 73 74 (output* str st
2360: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 6c ). (l
2370: 65 74 20 28 28 73 74 20 28 66 6d 74 2d 75 70 64 et ((st (fmt-upd
2380: 61 74 65 20 73 74 72 20 73 74 29 29 29 0a 20 20 ate str st))).
2390: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
23a0: 28 3e 20 28 66 6d 74 2d 63 6f 6c 20 73 74 29 20 (> (fmt-col st)
23b0: 77 69 64 74 68 29 0a 20 20 20 20 20 20 20 20 20 width).
23c0: 20 20 20 20 20 20 20 20 20 28 72 65 74 75 72 6e (return
23d0: 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 #f).
23e0: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 (begin.
23f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2400: 20 20 28 64 69 73 70 6c 61 79 20 73 74 72 20 70 (display str p
2410: 6f 72 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 ort).
2420: 20 20 20 20 20 20 20 20 20 73 74 29 29 29 29 0a st)))).
2430: 20 20 20 20 20 20 20 20 20 20 28 67 65 6e 20 28 (gen (
2440: 66 6d 74 2d 73 65 74 2d 70 6f 72 74 21 20 28 66 fmt-set-port! (f
2450: 6d 74 2d 73 65 74 2d 77 72 69 74 65 72 21 20 28 mt-set-writer! (
2460: 63 6f 70 79 2d 66 6d 74 2d 73 74 61 74 65 20 73 copy-fmt-state s
2470: 74 29 20 6f 75 74 70 75 74 2a 29 0a 20 20 20 20 t) output*).
2480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2490: 20 20 20 20 20 20 20 20 20 20 70 6f 72 74 29 29 port))
24a0: 0a 20 20 20 20 20 20 20 20 20 20 28 67 65 74 2d . (get-
24b0: 6f 75 74 70 75 74 2d 73 74 72 69 6e 67 20 70 6f output-string po
24c0: 72 74 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e rt))))))..(defin
24d0: 65 20 28 66 69 74 73 2d 69 6e 2d 63 6f 6c 75 6d e (fits-in-colum
24e0: 6e 73 20 6c 73 20 77 72 69 74 65 20 77 69 64 74 ns ls write widt
24f0: 68 29 0a 20 20 28 6c 61 6d 62 64 61 20 28 73 74 h). (lambda (st
2500: 29 0a 20 20 20 20 28 6c 65 74 20 28 28 6d 61 78 ). (let ((max
2510: 2d 77 20 28 71 75 6f 74 69 65 6e 74 20 77 69 64 -w (quotient wid
2520: 74 68 20 32 29 29 29 0a 20 20 20 20 20 20 28 6c th 2))). (l
2530: 65 74 20 6c 70 20 28 28 6c 73 20 6c 73 29 20 28 et lp ((ls ls) (
2540: 72 65 73 20 27 28 29 29 20 28 77 69 64 65 73 74 res '()) (widest
2550: 20 30 29 29 0a 20 20 20 20 20 20 20 20 28 63 6f 0)). (co
2560: 6e 64 0a 20 20 20 20 20 20 20 20 20 20 28 28 70 nd. ((p
2570: 61 69 72 3f 20 6c 73 29 0a 20 20 20 20 20 20 20 air? ls).
2580: 20 20 20 20 28 6c 65 74 20 28 28 73 74 72 20 28 (let ((str (
2590: 28 66 69 74 73 2d 69 6e 2d 77 69 64 74 68 20 28 (fits-in-width (
25a0: 77 72 69 74 65 20 28 63 61 72 20 6c 73 29 29 20 write (car ls))
25b0: 6d 61 78 2d 77 29 20 73 74 29 29 29 0a 20 20 20 max-w) st))).
25c0: 20 20 20 20 20 20 20 20 20 20 28 61 6e 64 20 73 (and s
25d0: 74 72 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 tr.
25e0: 20 20 20 20 20 28 6c 70 20 28 63 64 72 20 6c 73 (lp (cdr ls
25f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2600: 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 73 74 (cons st
2610: 72 20 72 65 73 29 0a 20 20 20 20 20 20 20 20 20 r res).
2620: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 (ma
2630: 78 20 28 28 6f 72 20 28 66 6d 74 2d 73 74 72 69 x ((or (fmt-stri
2640: 6e 67 2d 77 69 64 74 68 20 73 74 29 20 73 74 72 ng-width st) str
2650: 69 6e 67 2d 6c 65 6e 67 74 68 29 20 73 74 72 29 ing-length) str)
2660: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2670: 20 20 20 20 20 20 20 20 20 20 20 20 77 69 64 65 wide
2680: 73 74 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 st))))).
2690: 20 20 28 28 6e 75 6c 6c 3f 20 6c 73 29 20 28 63 ((null? ls) (c
26a0: 6f 6e 73 20 77 69 64 65 73 74 20 28 72 65 76 65 ons widest (reve
26b0: 72 73 65 20 72 65 73 29 29 29 0a 20 20 20 20 20 rse res))).
26c0: 20 20 20 20 20 28 65 6c 73 65 20 23 66 29 29 29 (else #f)))
26d0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 66 6d )))..(define (fm
26e0: 74 2d 63 61 70 74 75 72 65 20 70 72 6f 64 75 63 t-capture produc
26f0: 65 72 20 63 6f 6e 73 75 6d 65 72 29 0a 20 20 28 er consumer). (
2700: 6c 61 6d 62 64 61 20 28 73 74 29 0a 20 20 20 20 lambda (st).
2710: 28 6c 65 74 20 28 28 70 6f 72 74 20 28 6f 70 65 (let ((port (ope
2720: 6e 2d 6f 75 74 70 75 74 2d 73 74 72 69 6e 67 29 n-output-string)
2730: 29 29 0a 20 20 20 20 20 20 28 70 72 6f 64 75 63 )). (produc
2740: 65 72 20 28 66 6d 74 2d 73 65 74 2d 77 72 69 74 er (fmt-set-writ
2750: 65 72 21 20 28 66 6d 74 2d 73 65 74 2d 70 6f 72 er! (fmt-set-por
2760: 74 21 20 28 63 6f 70 79 2d 66 6d 74 2d 73 74 61 t! (copy-fmt-sta
2770: 74 65 20 73 74 29 20 70 6f 72 74 29 0a 20 20 20 te st) port).
2780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 66 6d fm
27a0: 74 2d 77 72 69 74 65 29 29 0a 20 20 20 20 20 20 t-write)).
27b0: 28 28 63 6f 6e 73 75 6d 65 72 20 28 67 65 74 2d ((consumer (get-
27c0: 6f 75 74 70 75 74 2d 73 74 72 69 6e 67 20 70 6f output-string po
27d0: 72 74 29 29 20 73 74 29 29 29 29 0a 0a 28 64 65 rt)) st))))..(de
27e0: 66 69 6e 65 20 28 66 6d 74 2d 74 6f 2d 73 74 72 fine (fmt-to-str
27f0: 69 6e 67 20 70 72 6f 64 75 63 65 72 29 0a 20 20 ing producer).
2800: 28 66 6d 74 2d 63 61 70 74 75 72 65 20 70 72 6f (fmt-capture pro
2810: 64 75 63 65 72 20 28 6c 61 6d 62 64 61 20 28 73 ducer (lambda (s
2820: 74 72 29 20 28 6c 61 6d 62 64 61 20 28 73 74 29 tr) (lambda (st)
2830: 20 73 74 72 29 29 29 29 0a 0a 3b 3b 3b 3b 3b 3b str))))..;;;;;;
2840: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
2850: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
2860: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
2870: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
2880: 3b 3b 0a 3b 3b 3b 20 73 74 61 6e 64 61 72 64 20 ;;.;;; standard
2890: 66 6f 72 6d 61 74 74 65 72 73 0a 0a 28 64 65 66 formatters..(def
28a0: 69 6e 65 20 28 6e 6c 20 73 74 29 0a 20 20 28 28 ine (nl st). ((
28b0: 66 6d 74 2d 77 72 69 74 65 72 20 73 74 29 20 6e fmt-writer st) n
28c0: 6c 2d 73 74 72 20 73 74 29 29 0a 0a 3b 3b 20 6f l-str st))..;; o
28d0: 75 74 70 75 74 20 61 20 6e 65 77 6c 69 6e 65 20 utput a newline
28e0: 69 66 66 20 77 65 27 72 65 20 6e 6f 74 20 61 74 iff we're not at
28f0: 20 74 68 65 20 73 74 61 72 74 20 6f 66 20 61 20 the start of a
2900: 66 72 65 73 68 20 6c 69 6e 65 0a 28 64 65 66 69 fresh line.(defi
2910: 6e 65 20 28 66 6c 20 73 74 29 0a 20 20 28 69 66 ne (fl st). (if
2920: 20 28 7a 65 72 6f 3f 20 28 66 6d 74 2d 63 6f 6c (zero? (fmt-col
2930: 20 73 74 29 29 20 73 74 20 28 6e 6c 20 73 74 29 st)) st (nl st)
2940: 29 29 0a 0a 3b 3b 20 74 61 62 20 74 6f 20 61 20 ))..;; tab to a
2950: 67 69 76 65 6e 20 74 61 62 2d 73 74 6f 70 0a 28 given tab-stop.(
2960: 64 65 66 69 6e 65 20 28 74 61 62 2d 74 6f 20 2e define (tab-to .
2970: 20 6f 29 0a 20 20 28 6c 61 6d 62 64 61 20 28 73 o). (lambda (s
2980: 74 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 74 t). (let* ((t
2990: 61 62 2d 77 69 64 74 68 20 28 69 66 20 28 70 61 ab-width (if (pa
29a0: 69 72 3f 20 6f 29 20 28 63 61 72 20 6f 29 20 38 ir? o) (car o) 8
29b0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 72 )). (r
29c0: 65 6d 20 28 6d 6f 64 75 6c 6f 20 28 66 6d 74 2d em (modulo (fmt-
29d0: 63 6f 6c 20 73 74 29 20 74 61 62 2d 77 69 64 74 col st) tab-widt
29e0: 68 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 h))). (if (
29f0: 70 6f 73 69 74 69 76 65 3f 20 72 65 6d 29 0a 20 positive? rem).
2a00: 20 20 20 20 20 20 20 20 20 28 28 66 6d 74 2d 77 ((fmt-w
2a10: 72 69 74 65 72 20 73 74 29 0a 20 20 20 20 20 20 riter st).
2a20: 20 20 20 20 20 28 6d 61 6b 65 2d 73 74 72 69 6e (make-strin
2a30: 67 20 28 2d 20 74 61 62 2d 77 69 64 74 68 20 72 g (- tab-width r
2a40: 65 6d 29 20 28 66 6d 74 2d 70 61 64 2d 63 68 61 em) (fmt-pad-cha
2a50: 72 20 73 74 29 29 0a 20 20 20 20 20 20 20 20 20 r st)).
2a60: 20 20 73 74 29 0a 20 20 20 20 20 20 20 20 20 20 st).
2a70: 73 74 29 29 29 29 0a 0a 3b 3b 20 6d 6f 76 65 20 st))))..;; move
2a80: 74 6f 20 61 6e 20 65 78 70 6c 69 63 69 74 20 63 to an explicit c
2a90: 6f 6c 75 6d 6e 0a 28 64 65 66 69 6e 65 20 28 73 olumn.(define (s
2aa0: 70 61 63 65 2d 74 6f 20 63 6f 6c 29 0a 20 20 28 pace-to col). (
2ab0: 6c 61 6d 62 64 61 20 28 73 74 29 0a 20 20 20 20 lambda (st).
2ac0: 28 6c 65 74 20 28 28 77 69 64 74 68 20 28 2d 20 (let ((width (-
2ad0: 63 6f 6c 20 28 66 6d 74 2d 63 6f 6c 20 73 74 29 col (fmt-col st)
2ae0: 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 70 ))). (if (p
2af0: 6f 73 69 74 69 76 65 3f 20 77 69 64 74 68 29 0a ositive? width).
2b00: 20 20 20 20 20 20 20 20 20 20 28 28 66 6d 74 2d ((fmt-
2b10: 77 72 69 74 65 72 20 73 74 29 20 28 6d 61 6b 65 writer st) (make
2b20: 2d 73 74 72 69 6e 67 20 77 69 64 74 68 20 28 66 -string width (f
2b30: 6d 74 2d 70 61 64 2d 63 68 61 72 20 73 74 29 29 mt-pad-char st))
2b40: 20 73 74 29 0a 20 20 20 20 20 20 20 20 20 20 73 st). s
2b50: 74 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 t))))..(define (
2b60: 66 6d 74 2d 6a 6f 69 6e 20 66 6d 74 20 6c 73 20 fmt-join fmt ls
2b70: 2e 20 6f 29 0a 20 20 28 6c 65 74 20 28 28 73 65 . o). (let ((se
2b80: 70 20 28 64 73 70 20 28 69 66 20 28 70 61 69 72 p (dsp (if (pair
2b90: 3f 20 6f 29 20 28 63 61 72 20 6f 29 20 22 22 29 ? o) (car o) "")
2ba0: 29 29 29 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 ))). (lambda
2bb0: 28 73 74 29 0a 20 20 20 20 20 20 28 69 66 20 28 (st). (if (
2bc0: 6e 75 6c 6c 3f 20 6c 73 29 0a 20 20 20 20 20 20 null? ls).
2bd0: 20 20 20 20 73 74 0a 20 20 20 20 20 20 20 20 20 st.
2be0: 20 28 6c 65 74 20 6c 70 20 28 28 6c 73 20 28 63 (let lp ((ls (c
2bf0: 64 72 20 6c 73 29 29 0a 20 20 20 20 20 20 20 20 dr ls)).
2c00: 20 20 20 20 20 20 20 20 20 20 20 28 73 74 20 28 (st (
2c10: 28 66 6d 74 20 28 63 61 72 20 6c 73 29 29 20 73 (fmt (car ls)) s
2c20: 74 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 t))).
2c30: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6c 73 29 0a (if (null? ls).
2c40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2c50: 73 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 st.
2c60: 20 20 20 28 6c 70 20 28 63 64 72 20 6c 73 29 20 (lp (cdr ls)
2c70: 28 28 66 6d 74 20 28 63 61 72 20 6c 73 29 29 20 ((fmt (car ls))
2c80: 28 73 65 70 20 73 74 29 29 29 29 29 29 29 29 29 (sep st)))))))))
2c90: 0a 0a 28 64 65 66 69 6e 65 20 28 66 6d 74 2d 6a ..(define (fmt-j
2ca0: 6f 69 6e 2f 70 72 65 66 69 78 20 66 6d 74 20 6c oin/prefix fmt l
2cb0: 73 20 2e 20 6f 29 0a 20 20 28 69 66 20 28 6e 75 s . o). (if (nu
2cc0: 6c 6c 3f 20 6c 73 29 0a 20 20 20 20 20 20 66 6d ll? ls). fm
2cd0: 74 2d 6e 75 6c 6c 0a 20 20 20 20 20 20 28 6c 65 t-null. (le
2ce0: 74 20 28 28 73 65 70 20 28 64 73 70 20 28 69 66 t ((sep (dsp (if
2cf0: 20 28 70 61 69 72 3f 20 6f 29 20 28 63 61 72 20 (pair? o) (car
2d00: 6f 29 20 22 22 29 29 29 29 0a 20 20 20 20 20 20 o) "")))).
2d10: 20 20 28 63 61 74 20 73 65 70 20 28 66 6d 74 2d (cat sep (fmt-
2d20: 6a 6f 69 6e 20 66 6d 74 20 6c 73 20 73 65 70 29 join fmt ls sep)
2d30: 29 29 29 29 0a 28 64 65 66 69 6e 65 20 28 66 6d )))).(define (fm
2d40: 74 2d 6a 6f 69 6e 2f 73 75 66 66 69 78 20 66 6d t-join/suffix fm
2d50: 74 20 6c 73 20 2e 20 6f 29 0a 20 20 28 69 66 20 t ls . o). (if
2d60: 28 6e 75 6c 6c 3f 20 6c 73 29 0a 20 20 20 20 20 (null? ls).
2d70: 20 66 6d 74 2d 6e 75 6c 6c 0a 20 20 20 20 20 20 fmt-null.
2d80: 28 6c 65 74 20 28 28 73 65 70 20 28 64 73 70 20 (let ((sep (dsp
2d90: 28 69 66 20 28 70 61 69 72 3f 20 6f 29 20 28 63 (if (pair? o) (c
2da0: 61 72 20 6f 29 20 22 22 29 29 29 29 0a 20 20 20 ar o) "")))).
2db0: 20 20 20 20 20 28 63 61 74 20 28 66 6d 74 2d 6a (cat (fmt-j
2dc0: 6f 69 6e 20 66 6d 74 20 6c 73 20 73 65 70 29 20 oin fmt ls sep)
2dd0: 73 65 70 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 sep))))..(define
2de0: 20 28 66 6d 74 2d 6a 6f 69 6e 2f 6c 61 73 74 20 (fmt-join/last
2df0: 66 6d 74 20 66 6d 74 2f 6c 61 73 74 20 6c 73 20 fmt fmt/last ls
2e00: 2e 20 6f 29 0a 20 20 28 6c 65 74 20 28 28 73 65 . o). (let ((se
2e10: 70 20 28 64 73 70 20 28 69 66 20 28 70 61 69 72 p (dsp (if (pair
2e20: 3f 20 6f 29 20 28 63 61 72 20 6f 29 20 22 22 29 ? o) (car o) "")
2e30: 29 29 29 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 ))). (lambda
2e40: 28 73 74 29 0a 20 20 20 20 20 20 28 63 6f 6e 64 (st). (cond
2e50: 0a 20 20 20 20 20 20 20 20 28 28 6e 75 6c 6c 3f . ((null?
2e60: 20 6c 73 29 0a 20 20 20 20 20 20 20 20 20 73 74 ls). st
2e70: 29 0a 20 20 20 20 20 20 20 20 28 28 6e 75 6c 6c ). ((null
2e80: 3f 20 28 63 64 72 20 6c 73 29 29 0a 20 20 20 20 ? (cdr ls)).
2e90: 20 20 20 20 20 28 28 66 6d 74 2f 6c 61 73 74 20 ((fmt/last
2ea0: 28 63 61 72 20 6c 73 29 29 20 28 73 65 70 20 73 (car ls)) (sep s
2eb0: 74 29 29 29 0a 20 20 20 20 20 20 20 20 28 65 6c t))). (el
2ec0: 73 65 0a 20 20 20 20 20 20 20 20 20 28 6c 65 74 se. (let
2ed0: 20 6c 70 20 28 28 6c 73 20 28 63 64 72 20 6c 73 lp ((ls (cdr ls
2ee0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
2ef0: 20 20 20 20 20 28 73 74 20 28 28 66 6d 74 20 28 (st ((fmt (
2f00: 63 61 72 20 6c 73 29 29 20 73 74 29 29 29 0a 20 car ls)) st))).
2f10: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e (if (n
2f20: 75 6c 6c 3f 20 28 63 64 72 20 6c 73 29 29 0a 20 ull? (cdr ls)).
2f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ((
2f40: 66 6d 74 2f 6c 61 73 74 20 28 63 61 72 20 6c 73 fmt/last (car ls
2f50: 29 29 20 28 73 65 70 20 73 74 29 29 0a 20 20 20 )) (sep st)).
2f60: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 70 20 (lp
2f70: 28 63 64 72 20 6c 73 29 20 28 28 66 6d 74 20 28 (cdr ls) ((fmt (
2f80: 63 61 72 20 6c 73 29 29 20 28 73 65 70 20 73 74 car ls)) (sep st
2f90: 29 29 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 ))))))))))..(def
2fa0: 69 6e 65 20 28 66 6d 74 2d 6a 6f 69 6e 2f 64 6f ine (fmt-join/do
2fb0: 74 20 66 6d 74 20 66 6d 74 2f 64 6f 74 20 6c 73 t fmt fmt/dot ls
2fc0: 20 2e 20 6f 29 0a 20 20 28 6c 65 74 20 28 28 73 . o). (let ((s
2fd0: 65 70 20 28 64 73 70 20 28 69 66 20 28 70 61 69 ep (dsp (if (pai
2fe0: 72 3f 20 6f 29 20 28 63 61 72 20 6f 29 20 22 22 r? o) (car o) ""
2ff0: 29 29 29 29 0a 20 20 20 20 28 6c 61 6d 62 64 61 )))). (lambda
3000: 20 28 73 74 29 0a 20 20 20 20 20 20 28 63 6f 6e (st). (con
3010: 64 0a 20 20 20 20 20 20 20 20 28 28 70 61 69 72 d. ((pair
3020: 3f 20 6c 73 29 0a 20 20 20 20 20 20 20 20 20 28 ? ls). (
3030: 6c 65 74 20 6c 70 20 28 28 6c 73 20 28 63 64 72 let lp ((ls (cdr
3040: 20 6c 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 ls)).
3050: 20 20 20 20 20 20 20 20 28 73 74 20 28 28 66 6d (st ((fm
3060: 74 20 28 63 61 72 20 6c 73 29 29 20 73 74 29 29 t (car ls)) st))
3070: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 63 6f ). (co
3080: 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 nd.
3090: 28 28 6e 75 6c 6c 3f 20 6c 73 29 20 73 74 29 0a ((null? ls) st).
30a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 70 ((p
30b0: 61 69 72 3f 20 6c 73 29 20 28 6c 70 20 28 63 64 air? ls) (lp (cd
30c0: 72 20 6c 73 29 20 28 28 66 6d 74 20 28 63 61 72 r ls) ((fmt (car
30d0: 20 6c 73 29 29 20 28 73 65 70 20 73 74 29 29 29 ls)) (sep st)))
30e0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ). (
30f0: 65 6c 73 65 20 28 28 66 6d 74 2f 64 6f 74 20 6c else ((fmt/dot l
3100: 73 29 20 28 73 65 70 20 73 74 29 29 29 29 29 29 s) (sep st))))))
3110: 0a 20 20 20 20 20 20 20 20 28 28 6e 75 6c 6c 3f . ((null?
3120: 20 6c 73 29 20 73 74 29 0a 20 20 20 20 20 20 20 ls) st).
3130: 20 28 65 6c 73 65 20 28 28 66 6d 74 2f 64 6f 74 (else ((fmt/dot
3140: 20 6c 73 29 20 73 74 29 29 29 29 29 29 0a 0a 28 ls) st))))))..(
3150: 64 65 66 69 6e 65 20 28 66 6d 74 2d 6a 6f 69 6e define (fmt-join
3160: 2f 72 61 6e 67 65 20 66 6d 74 20 73 74 61 72 74 /range fmt start
3170: 20 2e 20 6f 29 0a 20 20 28 6c 65 74 2d 6f 70 74 . o). (let-opt
3180: 69 6f 6e 61 6c 73 2a 20 6f 20 28 28 65 6e 64 20 ionals* o ((end
3190: 23 66 29 20 28 73 65 70 20 22 22 29 29 0a 20 20 #f) (sep "")).
31a0: 20 20 28 6c 61 6d 62 64 61 20 28 73 74 29 0a 20 (lambda (st).
31b0: 20 20 20 20 20 28 6c 65 74 20 6c 70 20 28 28 69 (let lp ((i
31c0: 20 28 2b 20 73 74 61 72 74 20 31 29 29 20 28 73 (+ start 1)) (s
31d0: 74 20 28 28 66 6d 74 20 73 74 61 72 74 29 20 73 t ((fmt start) s
31e0: 74 29 29 29 0a 20 20 20 20 20 20 20 20 28 69 66 t))). (if
31f0: 20 28 61 6e 64 20 65 6e 64 20 28 3e 3d 20 69 20 (and end (>= i
3200: 65 6e 64 29 29 0a 20 20 20 20 20 20 20 20 20 20 end)).
3210: 20 20 73 74 0a 20 20 20 20 20 20 20 20 20 20 20 st.
3220: 20 28 6c 70 20 28 2b 20 69 20 31 29 20 28 28 66 (lp (+ i 1) ((f
3230: 6d 74 20 69 29 20 28 28 64 73 70 20 73 65 70 29 mt i) ((dsp sep)
3240: 20 73 74 29 29 29 29 29 29 29 29 0a 0a 28 64 65 st))))))))..(de
3250: 66 69 6e 65 20 28 70 61 64 2f 62 6f 74 68 20 77 fine (pad/both w
3260: 69 64 74 68 20 2e 20 6c 73 29 0a 20 20 28 66 6d idth . ls). (fm
3270: 74 2d 63 61 70 74 75 72 65 0a 20 20 20 28 61 70 t-capture. (ap
3280: 70 6c 79 2d 63 61 74 20 6c 73 29 0a 20 20 20 28 ply-cat ls). (
3290: 6c 61 6d 62 64 61 20 28 73 74 72 29 0a 20 20 20 lambda (str).
32a0: 20 20 28 6c 61 6d 62 64 61 20 28 73 74 29 0a 20 (lambda (st).
32b0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 64 69 66 (let ((dif
32c0: 66 20 28 2d 20 77 69 64 74 68 20 28 28 6f 72 20 f (- width ((or
32d0: 28 66 6d 74 2d 73 74 72 69 6e 67 2d 77 69 64 74 (fmt-string-widt
32e0: 68 20 73 74 29 20 73 74 72 69 6e 67 2d 6c 65 6e h st) string-len
32f0: 67 74 68 29 20 73 74 72 29 29 29 0a 20 20 20 20 gth) str))).
3300: 20 20 20 20 20 20 20 20 20 28 6f 75 74 70 75 74 (output
3310: 20 28 66 6d 74 2d 77 72 69 74 65 72 20 73 74 29 (fmt-writer st)
3320: 29 29 0a 20 20 20 20 20 20 20 20 20 28 69 66 20 )). (if
3330: 28 70 6f 73 69 74 69 76 65 3f 20 64 69 66 66 29 (positive? diff)
3340: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c . (l
3350: 65 74 2a 20 28 28 64 69 66 66 2f 32 20 28 71 75 et* ((diff/2 (qu
3360: 6f 74 69 65 6e 74 20 64 69 66 66 20 32 29 29 0a otient diff 2)).
3370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3380: 20 20 20 20 28 6c 65 66 74 20 28 6d 61 6b 65 2d (left (make-
3390: 73 74 72 69 6e 67 20 64 69 66 66 2f 32 20 28 66 string diff/2 (f
33a0: 6d 74 2d 70 61 64 2d 63 68 61 72 20 73 74 29 29 mt-pad-char st))
33b0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
33c0: 20 20 20 20 20 20 28 72 69 67 68 74 20 28 69 66 (right (if
33d0: 20 28 65 76 65 6e 3f 20 64 69 66 66 29 0a 20 20 (even? diff).
33e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
33f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 6c 65 66 lef
3400: 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t.
3410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3420: 20 28 6d 61 6b 65 2d 73 74 72 69 6e 67 20 28 2b (make-string (+
3430: 20 31 20 64 69 66 66 2f 32 29 20 28 66 6d 74 2d 1 diff/2) (fmt-
3440: 70 61 64 2d 63 68 61 72 20 73 74 29 29 29 29 29 pad-char st)))))
3450: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3460: 28 6f 75 74 70 75 74 20 72 69 67 68 74 20 28 6f (output right (o
3470: 75 74 70 75 74 20 73 74 72 20 28 6f 75 74 70 75 utput str (outpu
3480: 74 20 6c 65 66 74 20 73 74 29 29 29 29 0a 20 20 t left st)))).
3490: 20 20 20 20 20 20 20 20 20 20 20 28 6f 75 74 70 (outp
34a0: 75 74 20 73 74 72 20 73 74 29 29 29 29 29 29 29 ut str st)))))))
34b0: 0a 0a 28 64 65 66 69 6e 65 20 28 70 61 64 20 77 ..(define (pad w
34c0: 69 64 74 68 20 2e 20 6c 73 29 0a 20 20 28 6c 61 idth . ls). (la
34d0: 6d 62 64 61 20 28 73 74 29 0a 20 20 20 20 28 6c mbda (st). (l
34e0: 65 74 2a 20 28 28 63 6f 6c 20 28 66 6d 74 2d 63 et* ((col (fmt-c
34f0: 6f 6c 20 73 74 29 29 0a 20 20 20 20 20 20 20 20 ol st)).
3500: 20 20 20 28 70 61 64 64 65 72 0a 20 20 20 20 20 (padder.
3510: 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 (lambda (
3520: 73 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 st).
3530: 20 20 28 6c 65 74 20 28 28 64 69 66 66 20 28 2d (let ((diff (-
3540: 20 77 69 64 74 68 20 28 2d 20 28 66 6d 74 2d 63 width (- (fmt-c
3550: 6f 6c 20 73 74 29 20 63 6f 6c 29 29 29 29 0a 20 ol st) col)))).
3560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3570: 69 66 20 28 70 6f 73 69 74 69 76 65 3f 20 64 69 if (positive? di
3580: 66 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ff).
3590: 20 20 20 20 20 20 20 20 28 28 66 6d 74 2d 77 72 ((fmt-wr
35a0: 69 74 65 72 20 73 74 29 20 28 6d 61 6b 65 2d 73 iter st) (make-s
35b0: 74 72 69 6e 67 20 64 69 66 66 20 28 66 6d 74 2d tring diff (fmt-
35c0: 70 61 64 2d 63 68 61 72 20 73 74 29 29 20 73 74 pad-char st)) st
35d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
35e0: 20 20 20 20 20 20 73 74 29 29 29 29 29 0a 20 20 st))))).
35f0: 20 20 20 20 28 28 63 61 74 20 28 61 70 70 6c 79 ((cat (apply
3600: 2d 63 61 74 20 6c 73 29 20 70 61 64 64 65 72 29 -cat ls) padder)
3610: 20 73 74 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 st))))..(define
3620: 20 70 61 64 2f 72 69 67 68 74 20 70 61 64 29 0a pad/right pad).
3630: 0a 28 64 65 66 69 6e 65 20 28 70 61 64 2f 6c 65 .(define (pad/le
3640: 66 74 20 77 69 64 74 68 20 2e 20 6c 73 29 0a 20 ft width . ls).
3650: 20 28 66 6d 74 2d 63 61 70 74 75 72 65 0a 20 20 (fmt-capture.
3660: 20 28 61 70 70 6c 79 2d 63 61 74 20 6c 73 29 0a (apply-cat ls).
3670: 20 20 20 28 6c 61 6d 62 64 61 20 28 73 74 72 29 (lambda (str)
3680: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 . (lambda (s
3690: 74 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 t). (let*
36a0: 28 28 73 74 72 2d 77 69 64 74 68 20 28 28 6f 72 ((str-width ((or
36b0: 20 28 66 6d 74 2d 73 74 72 69 6e 67 2d 77 69 64 (fmt-string-wid
36c0: 74 68 20 73 74 29 20 73 74 72 69 6e 67 2d 6c 65 th st) string-le
36d0: 6e 67 74 68 29 20 73 74 72 29 29 0a 20 20 20 20 ngth) str)).
36e0: 20 20 20 20 20 20 20 20 20 20 28 64 69 66 66 20 (diff
36f0: 28 2d 20 77 69 64 74 68 20 73 74 72 2d 77 69 64 (- width str-wid
3700: 74 68 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 th))). (
3710: 28 66 6d 74 2d 77 72 69 74 65 72 20 73 74 29 0a (fmt-writer st).
3720: 20 20 20 20 20 20 20 20 20 20 73 74 72 0a 20 20 str.
3730: 20 20 20 20 20 20 20 20 28 69 66 20 28 70 6f 73 (if (pos
3740: 69 74 69 76 65 3f 20 64 69 66 66 29 0a 20 20 20 itive? diff).
3750: 20 20 20 20 20 20 20 20 20 20 20 28 28 66 6d 74 ((fmt
3760: 2d 77 72 69 74 65 72 20 73 74 29 20 28 6d 61 6b -writer st) (mak
3770: 65 2d 73 74 72 69 6e 67 20 64 69 66 66 20 28 66 e-string diff (f
3780: 6d 74 2d 70 61 64 2d 63 68 61 72 20 73 74 29 29 mt-pad-char st))
3790: 20 73 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 st).
37a0: 20 20 20 73 74 29 29 29 29 29 29 29 0a 0a 28 64 st)))))))..(d
37b0: 65 66 69 6e 65 20 28 74 72 69 6d 2f 62 75 66 66 efine (trim/buff
37c0: 65 72 65 64 20 77 69 64 74 68 20 66 6d 74 20 70 ered width fmt p
37d0: 72 6f 63 29 0a 20 20 28 66 6d 74 2d 63 61 70 74 roc). (fmt-capt
37e0: 75 72 65 0a 20 20 20 66 6d 74 0a 20 20 20 28 6c ure. fmt. (l
37f0: 61 6d 62 64 61 20 28 73 74 72 29 0a 20 20 20 20 ambda (str).
3800: 20 28 6c 61 6d 62 64 61 20 28 73 74 29 0a 20 20 (lambda (st).
3810: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 73 74 72 (let* ((str
3820: 2d 77 69 64 74 68 20 28 28 6f 72 20 28 66 6d 74 -width ((or (fmt
3830: 2d 73 74 72 69 6e 67 2d 77 69 64 74 68 20 73 74 -string-width st
3840: 29 20 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 29 ) string-length)
3850: 20 73 74 72 29 29 0a 20 20 20 20 20 20 20 20 20 str)).
3860: 20 20 20 20 20 28 64 69 66 66 20 28 2d 20 73 74 (diff (- st
3870: 72 2d 77 69 64 74 68 20 77 69 64 74 68 29 29 29 r-width width)))
3880: 0a 20 20 20 20 20 20 20 20 20 28 28 66 6d 74 2d . ((fmt-
3890: 77 72 69 74 65 72 20 73 74 29 0a 20 20 20 20 20 writer st).
38a0: 20 20 20 20 20 28 69 66 20 28 70 6f 73 69 74 69 (if (positi
38b0: 76 65 3f 20 64 69 66 66 29 0a 20 20 20 20 20 20 ve? diff).
38c0: 20 20 20 20 20 20 20 20 28 70 72 6f 63 20 73 74 (proc st
38d0: 72 20 73 74 72 2d 77 69 64 74 68 20 64 69 66 66 r str-width diff
38e0: 20 73 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 st).
38f0: 20 20 20 73 74 72 29 0a 20 20 20 20 20 20 20 20 str).
3900: 20 20 73 74 29 29 29 29 29 29 0a 0a 28 64 65 66 st))))))..(def
3910: 69 6e 65 20 28 74 72 69 6d 20 77 69 64 74 68 20 ine (trim width
3920: 2e 20 6c 73 29 0a 20 20 28 6c 61 6d 62 64 61 20 . ls). (lambda
3930: 28 73 74 29 0a 20 20 20 20 28 6c 65 74 20 28 28 (st). (let ((
3940: 65 6c 6c 20 28 66 6d 74 2d 65 6c 6c 69 70 73 65 ell (fmt-ellipse
3950: 73 20 73 74 29 29 29 0a 20 20 20 20 20 20 28 69 s st))). (i
3960: 66 20 65 6c 6c 0a 20 20 20 20 20 20 20 20 20 20 f ell.
3970: 28 28 74 72 69 6d 2f 62 75 66 66 65 72 65 64 0a ((trim/buffered.
3980: 20 20 20 20 20 20 20 20 20 20 20 20 77 69 64 74 widt
3990: 68 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 61 h. (a
39a0: 70 70 6c 79 2d 63 61 74 20 6c 73 29 0a 20 20 20 pply-cat ls).
39b0: 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 (lambda
39c0: 20 28 73 74 72 20 73 74 72 2d 77 69 64 74 68 20 (str str-width
39d0: 64 69 66 66 20 73 74 29 0a 20 20 20 20 20 20 20 diff st).
39e0: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 65 (let* ((e
39f0: 6c 6c 20 28 69 66 20 28 63 68 61 72 3f 20 65 6c ll (if (char? el
3a00: 6c 29 20 28 73 74 72 69 6e 67 20 65 6c 6c 29 20 l) (string ell)
3a10: 65 6c 6c 29 29 0a 20 20 20 20 20 20 20 20 20 20 ell)).
3a20: 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 6c 2d (ell-
3a30: 6c 65 6e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 len (string-leng
3a40: 74 68 20 65 6c 6c 29 29 0a 20 20 20 20 20 20 20 th ell)).
3a50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
3a60: 69 66 66 20 28 2d 20 28 2b 20 73 74 72 2d 77 69 iff (- (+ str-wi
3a70: 64 74 68 20 65 6c 6c 2d 6c 65 6e 29 20 77 69 64 dth ell-len) wid
3a80: 74 68 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 th))).
3a90: 20 20 20 20 20 20 28 69 66 20 28 6e 65 67 61 74 (if (negat
3aa0: 69 76 65 3f 20 64 69 66 66 29 0a 20 20 20 20 20 ive? diff).
3ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 65 e
3ac0: 6c 6c 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ll.
3ad0: 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 61 (string-a
3ae0: 70 70 65 6e 64 0a 20 20 20 20 20 20 20 20 20 20 ppend.
3af0: 20 20 20 20 20 20 20 20 20 20 20 28 73 75 62 73 (subs
3b00: 74 72 69 6e 67 2f 73 68 61 72 65 64 20 73 74 72 tring/shared str
3b10: 20 30 20 28 2d 20 28 73 74 72 69 6e 67 2d 6c 65 0 (- (string-le
3b20: 6e 67 74 68 20 73 74 72 29 20 64 69 66 66 29 29 ngth str) diff))
3b30: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3b40: 20 20 20 20 20 20 65 6c 6c 29 29 29 29 29 0a 20 ell))))).
3b50: 20 20 20 20 20 20 20 20 20 20 73 74 29 0a 20 20 st).
3b60: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 6f (let ((o
3b70: 75 74 70 75 74 20 28 66 6d 74 2d 77 72 69 74 65 utput (fmt-write
3b80: 72 20 73 74 29 29 0a 20 20 20 20 20 20 20 20 20 r st)).
3b90: 20 20 20 20 20 20 20 28 73 74 61 72 74 2d 63 6f (start-co
3ba0: 6c 20 28 66 6d 74 2d 63 6f 6c 20 73 74 29 29 29 l (fmt-col st)))
3bb0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 . (ca
3bc0: 6c 6c 2d 77 69 74 68 2d 63 75 72 72 65 6e 74 2d ll-with-current-
3bd0: 63 6f 6e 74 69 6e 75 61 74 69 6f 6e 0a 20 20 20 continuation.
3be0: 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 (lamb
3bf0: 64 61 20 28 72 65 74 75 72 6e 29 0a 20 20 20 20 da (return).
3c00: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 66 (def
3c10: 69 6e 65 20 28 6f 75 74 70 75 74 2a 20 73 74 72 ine (output* str
3c20: 20 73 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 st).
3c30: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6c (let* ((l
3c40: 65 6e 20 28 28 6f 72 20 28 66 6d 74 2d 73 74 72 en ((or (fmt-str
3c50: 69 6e 67 2d 77 69 64 74 68 20 73 74 29 20 73 74 ing-width st) st
3c60: 72 69 6e 67 2d 6c 65 6e 67 74 68 29 20 73 74 72 ring-length) str
3c70: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
3c80: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 69 66 (dif
3c90: 66 20 28 2d 20 28 2b 20 28 2d 20 28 66 6d 74 2d f (- (+ (- (fmt-
3ca0: 63 6f 6c 20 73 74 29 20 73 74 61 72 74 2d 63 6f col st) start-co
3cb0: 6c 29 20 6c 65 6e 29 20 77 69 64 74 68 29 29 29 l) len) width)))
3cc0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3cd0: 20 20 20 20 20 28 69 66 20 28 70 6f 73 69 74 69 (if (positi
3ce0: 76 65 3f 20 64 69 66 66 29 0a 20 20 20 20 20 20 ve? diff).
3cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3d00: 20 20 28 72 65 74 75 72 6e 0a 20 20 20 20 20 20 (return.
3d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3d20: 20 20 20 28 66 6d 74 2d 73 65 74 2d 77 72 69 74 (fmt-set-writ
3d30: 65 72 21 0a 20 20 20 20 20 20 20 20 20 20 20 20 er!.
3d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6f (o
3d50: 75 74 70 75 74 20 28 73 75 62 73 74 72 69 6e 67 utput (substring
3d60: 2f 73 68 61 72 65 64 20 73 74 72 20 30 20 28 2d /shared str 0 (-
3d70: 20 6c 65 6e 20 64 69 66 66 29 29 20 73 74 29 0a len diff)) st).
3d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3d90: 20 20 20 20 20 20 20 20 20 20 6f 75 74 70 75 74 output
3da0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
3db0: 20 20 20 20 20 20 20 20 20 20 20 28 6f 75 74 70 (outp
3dc0: 75 74 20 73 74 72 20 73 74 29 29 29 29 0a 20 20 ut str st)))).
3dd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ((
3de0: 66 6d 74 2d 6c 65 74 20 27 77 72 69 74 65 72 20 fmt-let 'writer
3df0: 6f 75 74 70 75 74 2a 20 28 61 70 70 6c 79 2d 63 output* (apply-c
3e00: 61 74 20 6c 73 29 29 20 73 74 29 29 29 29 29 29 at ls)) st))))))
3e10: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 74 72 69 ))..(define (tri
3e20: 6d 2f 6c 65 6e 67 74 68 20 77 69 64 74 68 20 2e m/length width .
3e30: 20 6c 73 29 0a 20 20 28 6c 61 6d 62 64 61 20 28 ls). (lambda (
3e40: 73 74 29 0a 20 20 20 20 28 63 61 6c 6c 2d 77 69 st). (call-wi
3e50: 74 68 2d 63 75 72 72 65 6e 74 2d 63 6f 6e 74 69 th-current-conti
3e60: 6e 75 61 74 69 6f 6e 0a 20 20 20 20 20 20 28 6c nuation. (l
3e70: 61 6d 62 64 61 20 28 72 65 74 75 72 6e 29 0a 20 ambda (return).
3e80: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 6f 75 (let ((ou
3e90: 74 70 75 74 20 28 66 6d 74 2d 77 72 69 74 65 72 tput (fmt-writer
3ea0: 20 73 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 st)).
3eb0: 20 20 20 20 28 73 75 6d 20 30 29 29 0a 20 20 20 (sum 0)).
3ec0: 20 20 20 20 20 20 20 28 64 65 66 69 6e 65 20 28 (define (
3ed0: 6f 75 74 70 75 74 2a 20 73 74 72 20 73 74 29 0a output* str st).
3ee0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
3ef0: 20 28 28 6c 65 6e 20 28 73 74 72 69 6e 67 2d 6c ((len (string-l
3f00: 65 6e 67 74 68 20 73 74 72 29 29 29 0a 20 20 20 ength str))).
3f10: 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 (set!
3f20: 20 73 75 6d 20 28 2b 20 73 75 6d 20 6c 65 6e 29 sum (+ sum len)
3f30: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3f40: 28 69 66 20 28 3e 20 73 75 6d 20 77 69 64 74 68 (if (> sum width
3f50: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3f60: 20 20 20 20 28 72 65 74 75 72 6e 0a 20 20 20 20 (return.
3f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3f80: 66 6d 74 2d 73 65 74 2d 77 72 69 74 65 72 21 0a fmt-set-writer!.
3f90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3fa0: 20 20 20 20 28 6f 75 74 70 75 74 20 28 73 75 62 (output (sub
3fb0: 73 74 72 69 6e 67 2f 73 68 61 72 65 64 20 73 74 string/shared st
3fc0: 72 20 30 20 28 2d 20 6c 65 6e 20 28 2d 20 73 75 r 0 (- len (- su
3fd0: 6d 20 77 69 64 74 68 29 29 29 20 73 74 29 0a 20 m width))) st).
3fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3ff0: 20 20 20 6f 75 74 70 75 74 29 29 0a 20 20 20 20 output)).
4000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6f (o
4010: 75 74 70 75 74 20 73 74 72 20 73 74 29 29 29 29 utput str st))))
4020: 0a 20 20 20 20 20 20 20 20 20 20 28 28 66 6d 74 . ((fmt
4030: 2d 6c 65 74 20 27 77 72 69 74 65 72 20 6f 75 74 -let 'writer out
4040: 70 75 74 2a 20 28 61 70 70 6c 79 2d 63 61 74 20 put* (apply-cat
4050: 6c 73 29 29 20 73 74 29 29 29 29 29 29 0a 0a 28 ls)) st))))))..(
4060: 64 65 66 69 6e 65 20 28 74 72 69 6d 2f 6c 65 66 define (trim/lef
4070: 74 20 77 69 64 74 68 20 2e 20 6c 73 29 0a 20 20 t width . ls).
4080: 28 74 72 69 6d 2f 62 75 66 66 65 72 65 64 0a 20 (trim/buffered.
4090: 20 20 77 69 64 74 68 0a 20 20 20 28 61 70 70 6c width. (appl
40a0: 79 2d 63 61 74 20 6c 73 29 0a 20 20 20 28 6c 61 y-cat ls). (la
40b0: 6d 62 64 61 20 28 73 74 72 20 73 74 72 2d 77 69 mbda (str str-wi
40c0: 64 74 68 20 64 69 66 66 20 73 74 29 0a 20 20 20 dth diff st).
40d0: 20 20 28 6c 65 74 20 28 28 65 6c 6c 20 28 66 6d (let ((ell (fm
40e0: 74 2d 65 6c 6c 69 70 73 65 73 20 73 74 29 29 29 t-ellipses st)))
40f0: 0a 20 20 20 20 20 20 20 28 69 66 20 65 6c 6c 0a . (if ell.
4100: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a (let*
4110: 20 28 28 65 6c 6c 20 28 69 66 20 28 63 68 61 72 ((ell (if (char
4120: 3f 20 65 6c 6c 29 20 28 73 74 72 69 6e 67 20 65 ? ell) (string e
4130: 6c 6c 29 20 65 6c 6c 29 29 0a 20 20 20 20 20 20 ll) ell)).
4140: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 6c (ell
4150: 2d 6c 65 6e 20 28 73 74 72 69 6e 67 2d 6c 65 6e -len (string-len
4160: 67 74 68 20 65 6c 6c 29 29 0a 20 20 20 20 20 20 gth ell)).
4170: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 69 66 (dif
4180: 66 20 28 2d 20 28 2b 20 73 74 72 2d 77 69 64 74 f (- (+ str-widt
4190: 68 20 65 6c 6c 2d 6c 65 6e 29 20 77 69 64 74 68 h ell-len) width
41a0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
41b0: 20 28 69 66 20 28 6e 65 67 61 74 69 76 65 3f 20 (if (negative?
41c0: 64 69 66 66 29 0a 20 20 20 20 20 20 20 20 20 20 diff).
41d0: 20 20 20 20 20 20 20 65 6c 6c 0a 20 20 20 20 20 ell.
41e0: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 72 (str
41f0: 69 6e 67 2d 61 70 70 65 6e 64 20 65 6c 6c 20 28 ing-append ell (
4200: 73 75 62 73 74 72 69 6e 67 2f 73 68 61 72 65 64 substring/shared
4210: 20 73 74 72 20 64 69 66 66 29 29 29 29 0a 20 20 str diff)))).
4220: 20 20 20 20 20 20 20 20 20 28 73 75 62 73 74 72 (substr
4230: 69 6e 67 2f 73 68 61 72 65 64 20 73 74 72 20 64 ing/shared str d
4240: 69 66 66 29 29 29 29 29 29 0a 0a 28 64 65 66 69 iff))))))..(defi
4250: 6e 65 20 28 74 72 69 6d 2f 62 6f 74 68 20 77 69 ne (trim/both wi
4260: 64 74 68 20 2e 20 6c 73 29 0a 20 20 28 74 72 69 dth . ls). (tri
4270: 6d 2f 62 75 66 66 65 72 65 64 0a 20 20 20 77 69 m/buffered. wi
4280: 64 74 68 0a 20 20 20 28 61 70 70 6c 79 2d 63 61 dth. (apply-ca
4290: 74 20 6c 73 29 0a 20 20 20 28 6c 61 6d 62 64 61 t ls). (lambda
42a0: 20 28 73 74 72 20 73 74 72 2d 77 69 64 74 68 20 (str str-width
42b0: 64 69 66 66 20 73 74 29 0a 20 20 20 20 20 28 6c diff st). (l
42c0: 65 74 20 28 28 65 6c 6c 20 28 66 6d 74 2d 65 6c et ((ell (fmt-el
42d0: 6c 69 70 73 65 73 20 73 74 29 29 29 0a 20 20 20 lipses st))).
42e0: 20 20 20 20 28 69 66 20 65 6c 6c 0a 20 20 20 20 (if ell.
42f0: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 65 (let* ((e
4300: 6c 6c 20 28 69 66 20 28 63 68 61 72 3f 20 65 6c ll (if (char? el
4310: 6c 29 20 28 73 74 72 69 6e 67 20 65 6c 6c 29 20 l) (string ell)
4320: 65 6c 6c 29 29 0a 20 20 20 20 20 20 20 20 20 20 ell)).
4330: 20 20 20 20 20 20 20 20 28 65 6c 6c 2d 6c 65 6e (ell-len
4340: 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 (string-length
4350: 65 6c 6c 29 29 0a 20 20 20 20 20 20 20 20 20 20 ell)).
4360: 20 20 20 20 20 20 20 20 28 64 69 66 66 20 28 2d (diff (-
4370: 20 28 2b 20 73 74 72 2d 77 69 64 74 68 20 65 6c (+ str-width el
4380: 6c 2d 6c 65 6e 20 65 6c 6c 2d 6c 65 6e 29 20 77 l-len ell-len) w
4390: 69 64 74 68 29 29 0a 20 20 20 20 20 20 20 20 20 idth)).
43a0: 20 20 20 20 20 20 20 20 20 28 6c 65 66 74 20 28 (left (
43b0: 71 75 6f 74 69 65 6e 74 20 64 69 66 66 20 32 29 quotient diff 2)
43c0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
43d0: 20 20 20 20 28 72 69 67 68 74 20 28 2d 20 28 73 (right (- (s
43e0: 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 73 74 72 tring-length str
43f0: 29 20 28 71 75 6f 74 69 65 6e 74 20 28 2b 20 64 ) (quotient (+ d
4400: 69 66 66 20 31 29 20 32 29 29 29 29 0a 20 20 20 iff 1) 2)))).
4410: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e (if (n
4420: 65 67 61 74 69 76 65 3f 20 64 69 66 66 29 0a 20 egative? diff).
4430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4440: 65 6c 6c 0a 20 20 20 20 20 20 20 20 20 20 20 20 ell.
4450: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 (string-app
4460: 65 6e 64 20 65 6c 6c 20 28 73 75 62 73 74 72 69 end ell (substri
4470: 6e 67 2f 73 68 61 72 65 64 20 73 74 72 20 6c 65 ng/shared str le
4480: 66 74 20 72 69 67 68 74 29 20 65 6c 6c 29 29 29 ft right) ell)))
4490: 0a 20 20 20 20 20 20 20 20 20 20 20 28 73 75 62 . (sub
44a0: 73 74 72 69 6e 67 2f 73 68 61 72 65 64 20 73 74 string/shared st
44b0: 72 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 r.
44c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
44d0: 71 75 6f 74 69 65 6e 74 20 28 2b 20 64 69 66 66 quotient (+ diff
44e0: 20 31 29 20 32 29 0a 20 20 20 20 20 20 20 20 20 1) 2).
44f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4500: 20 20 20 20 28 2d 20 28 73 74 72 69 6e 67 2d 6c (- (string-l
4510: 65 6e 67 74 68 20 73 74 72 29 20 28 71 75 6f 74 ength str) (quot
4520: 69 65 6e 74 20 64 69 66 66 20 32 29 29 29 29 29 ient diff 2)))))
4530: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 66 69 )))..(define (fi
4540: 74 20 77 69 64 74 68 20 2e 20 6c 73 29 0a 20 20 t width . ls).
4550: 28 70 61 64 20 77 69 64 74 68 20 28 74 72 69 6d (pad width (trim
4560: 20 77 69 64 74 68 20 28 61 70 70 6c 79 2d 63 61 width (apply-ca
4570: 74 20 6c 73 29 29 29 29 0a 28 64 65 66 69 6e 65 t ls)))).(define
4580: 20 28 66 69 74 2f 6c 65 66 74 20 77 69 64 74 68 (fit/left width
4590: 20 2e 20 6c 73 29 0a 20 20 28 70 61 64 2f 6c 65 . ls). (pad/le
45a0: 66 74 20 77 69 64 74 68 20 28 74 72 69 6d 2f 6c ft width (trim/l
45b0: 65 66 74 20 77 69 64 74 68 20 28 61 70 70 6c 79 eft width (apply
45c0: 2d 63 61 74 20 6c 73 29 29 29 29 0a 28 64 65 66 -cat ls)))).(def
45d0: 69 6e 65 20 28 66 69 74 2f 62 6f 74 68 20 77 69 ine (fit/both wi
45e0: 64 74 68 20 2e 20 6c 73 29 0a 20 20 28 70 61 64 dth . ls). (pad
45f0: 2f 62 6f 74 68 20 77 69 64 74 68 20 28 74 72 69 /both width (tri
4600: 6d 2f 62 6f 74 68 20 77 69 64 74 68 20 28 61 70 m/both width (ap
4610: 70 6c 79 2d 63 61 74 20 6c 73 29 29 29 29 0a 0a ply-cat ls))))..
4620: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
4630: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
4640: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
4650: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
4660: 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 3b 20 53 74 72 ;;;;;;;;.;;; Str
4670: 69 6e 67 2d 6d 61 70 20 66 6f 72 6d 61 74 74 65 ing-map formatte
4680: 72 73 0a 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b rs..(define (mak
4690: 65 2d 73 74 72 69 6e 67 2d 66 6d 74 2d 74 72 61 e-string-fmt-tra
46a0: 6e 73 66 6f 72 6d 65 72 20 70 72 6f 63 29 0a 20 nsformer proc).
46b0: 20 28 6c 61 6d 62 64 61 20 6c 73 0a 20 20 20 20 (lambda ls.
46c0: 28 6c 61 6d 62 64 61 20 28 73 74 29 0a 20 20 20 (lambda (st).
46d0: 20 20 20 28 6c 65 74 20 28 28 62 61 73 65 2d 77 (let ((base-w
46e0: 72 69 74 65 72 20 28 66 6d 74 2d 77 72 69 74 65 riter (fmt-write
46f0: 72 20 73 74 29 29 29 0a 20 20 20 20 20 20 20 20 r st))).
4700: 28 28 66 6d 74 2d 6c 65 74 0a 20 20 20 20 20 20 ((fmt-let.
4710: 20 20 20 20 27 77 72 69 74 65 72 20 28 6c 61 6d 'writer (lam
4720: 62 64 61 20 28 73 74 72 20 73 74 29 20 28 62 61 bda (str st) (ba
4730: 73 65 2d 77 72 69 74 65 72 20 28 70 72 6f 63 20 se-writer (proc
4740: 73 74 72 29 20 73 74 29 29 0a 20 20 20 20 20 20 str) st)).
4750: 20 20 20 20 28 61 70 70 6c 79 2d 63 61 74 20 6c (apply-cat l
4760: 73 29 29 0a 20 20 20 20 20 20 20 20 20 73 74 29 s)). st)
4770: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 75 70 ))))..(define up
4780: 63 61 73 65 20 28 6d 61 6b 65 2d 73 74 72 69 6e case (make-strin
4790: 67 2d 66 6d 74 2d 74 72 61 6e 73 66 6f 72 6d 65 g-fmt-transforme
47a0: 72 20 73 74 72 69 6e 67 2d 75 70 63 61 73 65 29 r string-upcase)
47b0: 29 0a 28 64 65 66 69 6e 65 20 64 6f 77 6e 63 61 ).(define downca
47c0: 73 65 20 28 6d 61 6b 65 2d 73 74 72 69 6e 67 2d se (make-string-
47d0: 66 6d 74 2d 74 72 61 6e 73 66 6f 72 6d 65 72 20 fmt-transformer
47e0: 73 74 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 29 string-downcase)
47f0: 29 0a 28 64 65 66 69 6e 65 20 74 69 74 6c 65 63 ).(define titlec
4800: 61 73 65 20 28 6d 61 6b 65 2d 73 74 72 69 6e 67 ase (make-string
4810: 2d 66 6d 74 2d 74 72 61 6e 73 66 6f 72 6d 65 72 -fmt-transformer
4820: 20 73 74 72 69 6e 67 2d 74 69 74 6c 65 63 61 73 string-titlecas
4830: 65 29 29 0a 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b e))..;;;;;;;;;;;
4840: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
4850: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
4860: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
4870: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b ;;;;;;;;;;;;;.;;
4880: 3b 20 4e 75 6d 65 72 69 63 20 66 6f 72 6d 61 74 ; Numeric format
4890: 74 69 6e 67 0a 0a 28 64 65 66 69 6e 65 20 2a 6d ting..(define *m
48a0: 69 6e 2d 65 2a 20 2d 31 30 32 34 29 0a 28 64 65 in-e* -1024).(de
48b0: 66 69 6e 65 20 2a 62 6f 74 2d 66 2a 20 28 65 78 fine *bot-f* (ex
48c0: 70 74 20 32 20 35 32 29 29 0a 3b 3b 28 64 65 66 pt 2 52)).;;(def
48d0: 69 6e 65 20 2a 74 6f 70 2d 66 2a 20 28 2a 20 32 ine *top-f* (* 2
48e0: 20 2a 62 6f 74 2d 66 2a 29 29 0a 0a 28 64 65 66 *bot-f*))..(def
48f0: 69 6e 65 20 28 69 6e 74 65 67 65 72 2d 6c 6f 67 ine (integer-log
4900: 20 61 20 62 61 73 65 29 0a 20 20 28 69 66 20 28 a base). (if (
4910: 7a 65 72 6f 3f 20 61 29 0a 20 20 20 20 20 20 30 zero? a). 0
4920: 0a 20 20 20 20 20 20 28 69 6e 65 78 61 63 74 2d . (inexact-
4930: 3e 65 78 61 63 74 20 28 63 65 69 6c 69 6e 67 20 >exact (ceiling
4940: 28 2f 20 28 6c 6f 67 20 28 2b 20 61 20 31 29 29 (/ (log (+ a 1))
4950: 20 28 6c 6f 67 20 62 61 73 65 29 29 29 29 29 29 (log base))))))
4960: 0a 28 64 65 66 69 6e 65 20 28 69 6e 74 65 67 65 .(define (intege
4970: 72 2d 6c 65 6e 67 74 68 2a 20 61 29 0a 20 20 28 r-length* a). (
4980: 69 66 20 28 6e 65 67 61 74 69 76 65 3f 20 61 29 if (negative? a)
4990: 0a 20 20 20 20 20 20 28 69 6e 74 65 67 65 72 2d . (integer-
49a0: 6c 6f 67 20 28 2d 20 31 20 61 29 20 32 29 0a 20 log (- 1 a) 2).
49b0: 20 20 20 20 20 28 69 6e 74 65 67 65 72 2d 6c 6f (integer-lo
49c0: 67 20 61 20 32 29 29 29 0a 0a 28 64 65 66 69 6e g a 2)))..(defin
49d0: 65 20 69 6e 76 6c 6f 67 32 6f 66 0a 20 20 28 6c e invlog2of. (l
49e0: 65 74 20 28 28 74 61 62 6c 65 20 28 6d 61 6b 65 et ((table (make
49f0: 2d 76 65 63 74 6f 72 20 33 37 29 29 0a 20 20 20 -vector 37)).
4a00: 20 20 20 20 20 28 6c 6f 67 32 20 28 6c 6f 67 20 (log2 (log
4a10: 32 29 29 29 0a 20 20 20 20 28 64 6f 20 28 28 62 2))). (do ((b
4a20: 20 32 20 28 2b 20 62 20 31 29 29 29 0a 20 20 20 2 (+ b 1))).
4a30: 20 20 20 20 20 28 28 3d 20 62 20 33 37 29 29 0a ((= b 37)).
4a40: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 (vector-se
4a50: 74 21 20 74 61 62 6c 65 20 62 20 28 2f 20 6c 6f t! table b (/ lo
4a60: 67 32 20 28 6c 6f 67 20 62 29 29 29 29 0a 20 20 g2 (log b)))).
4a70: 20 20 28 6c 61 6d 62 64 61 20 28 62 29 0a 20 20 (lambda (b).
4a80: 20 20 20 20 28 69 66 20 28 3c 3d 20 32 20 62 20 (if (<= 2 b
4a90: 33 36 29 0a 20 20 20 20 20 20 20 20 20 20 28 76 36). (v
4aa0: 65 63 74 6f 72 2d 72 65 66 20 74 61 62 6c 65 20 ector-ref table
4ab0: 62 29 0a 20 20 20 20 20 20 20 20 20 20 28 2f 20 b). (/
4ac0: 6c 6f 67 32 20 28 6c 6f 67 20 62 29 29 29 29 29 log2 (log b)))))
4ad0: 29 0a 0a 28 64 65 66 69 6e 65 20 66 61 73 74 2d )..(define fast-
4ae0: 65 78 70 74 0a 20 20 28 6c 65 74 20 28 28 74 61 expt. (let ((ta
4af0: 62 6c 65 20 28 6d 61 6b 65 2d 76 65 63 74 6f 72 ble (make-vector
4b00: 20 33 32 36 29 29 29 0a 20 20 20 20 28 64 6f 20 326))). (do
4b10: 28 28 6b 20 30 20 28 2b 20 6b 20 31 29 29 20 28 ((k 0 (+ k 1)) (
4b20: 76 20 31 20 28 2a 20 76 20 31 30 29 29 29 0a 20 v 1 (* v 10))).
4b30: 20 20 20 20 20 20 20 28 28 3d 20 6b 20 33 32 36 ((= k 326
4b40: 29 29 0a 20 20 20 20 20 20 28 76 65 63 74 6f 72 )). (vector
4b50: 2d 73 65 74 21 20 74 61 62 6c 65 20 6b 20 76 29 -set! table k v)
4b60: 29 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 62 ). (lambda (b
4b70: 20 6b 29 0a 20 20 20 20 20 20 28 69 66 20 28 61 k). (if (a
4b80: 6e 64 20 28 3d 20 62 20 31 30 29 20 28 3c 3d 20 nd (= b 10) (<=
4b90: 30 20 6b 20 33 32 36 29 29 0a 20 20 20 20 20 20 0 k 326)).
4ba0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
4bb0: 74 61 62 6c 65 20 28 69 6e 65 78 61 63 74 2d 3e table (inexact->
4bc0: 65 78 61 63 74 20 28 74 72 75 6e 63 61 74 65 20 exact (truncate
4bd0: 6b 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 k))). (
4be0: 65 78 70 74 20 62 20 6b 29 29 29 29 29 0a 0a 28 expt b k)))))..(
4bf0: 64 65 66 69 6e 65 20 28 6d 69 72 72 6f 72 2d 6f define (mirror-o
4c00: 66 20 63 29 0a 20 20 28 63 61 73 65 20 63 20 28 f c). (case c (
4c10: 28 23 5c 28 29 20 23 5c 29 29 20 28 28 23 5c 5b (#\() #\)) ((#\[
4c20: 29 20 23 5c 5d 29 20 28 28 23 5c 7b 29 20 23 5c ) #\]) ((#\{) #\
4c30: 7d 29 20 28 28 23 5c 3c 29 20 23 5c 3e 29 20 28 }) ((#\<) #\>) (
4c40: 65 6c 73 65 20 63 29 29 29 0a 0a 28 64 65 66 69 else c)))..(defi
4c50: 6e 65 20 64 65 66 61 75 6c 74 2d 64 69 67 69 74 ne default-digit
4c60: 73 0a 20 20 28 6c 69 73 74 2d 3e 76 65 63 74 6f s. (list->vecto
4c70: 72 20 28 73 74 72 69 6e 67 2d 3e 6c 69 73 74 20 r (string->list
4c80: 22 30 31 32 33 34 35 36 37 38 39 41 42 43 44 45 "0123456789ABCDE
4c90: 46 47 48 49 4a 4b 4c 4d 4e 4f 50 51 52 53 54 55 FGHIJKLMNOPQRSTU
4ca0: 56 57 58 59 5a 22 29 29 29 0a 0a 3b 3b 20 6b 61 VWXYZ")))..;; ka
4cb0: 6e 6a 69 20 28 31 30 20 69 6e 63 6c 75 64 65 64 nji (10 included
4cc0: 20 66 6f 72 20 62 61 73 65 20 31 31 20 3b 29 0a for base 11 ;).
4cd0: 3b 3b 20 28 76 65 63 74 6f 72 20 22 ef bc 90 22 ;; (vector "..."
4ce0: 20 22 e4 b8 80 22 20 22 e4 ba 8c 22 20 22 e4 b8 "..." "..." "..
4cf0: 89 22 20 22 e5 9b 9b 22 20 22 e4 ba 94 22 20 22 ." "..." "..." "
4d00: e5 85 ad 22 20 22 e4 b8 83 22 20 22 e5 85 ab 22 ..." "..." "..."
4d10: 20 22 e4 b9 9d 22 20 22 e5 8d 81 22 29 0a 0a 3b "..." "...")..;
4d20: 3b 20 6f 6c 64 20 73 74 79 6c 65 20 6b 61 6e 6a ; old style kanj
4d30: 69 3a 0a 3b 3b 20 28 76 65 63 74 6f 72 20 22 e9 i:.;; (vector ".
4d40: 9b b6 22 20 22 e5 a3 b1 22 20 22 e5 bc 90 22 20 .." "..." "..."
4d50: 22 e5 8f 82 22 20 22 e8 82 86 22 20 22 e4 bc 8d "..." "..." "...
4d60: 22 20 22 e9 99 b8 22 20 22 e6 9f 92 22 20 22 e6 " "..." "..." ".
4d70: 8d 8c 22 20 22 e7 8e 96 22 20 22 e6 8b be 22 29 .." "..." "...")
4d80: 0a 0a 3b 3b 20 47 65 6e 65 72 61 6c 20 61 6c 67 ..;; General alg
4d90: 6f 72 69 74 68 6d 20 62 61 73 65 64 20 6f 6e 20 orithm based on
4da0: 22 50 72 69 6e 74 69 6e 67 20 46 6c 6f 61 74 69 "Printing Floati
4db0: 6e 67 2d 50 6f 69 6e 74 20 4e 75 6d 62 65 72 73 ng-Point Numbers
4dc0: 20 51 75 69 63 6b 6c 79 0a 3b 3b 20 61 6e 64 20 Quickly.;; and
4dd0: 41 63 63 75 72 61 74 65 6c 79 22 20 62 79 20 42 Accurately" by B
4de0: 75 72 67 65 72 20 61 6e 64 20 44 79 62 76 69 67 urger and Dybvig
4df0: 20 28 46 50 2d 50 72 69 6e 74 69 6e 67 2d 50 4c (FP-Printing-PL
4e00: 44 49 39 36 2e 70 64 66 29 2e 20 20 54 68 65 0a DI96.pdf). The.
4e10: 3b 3b 20 63 6f 64 65 20 62 65 6c 6f 77 20 77 69 ;; code below wi
4e20: 6c 6c 20 62 65 20 68 61 72 64 20 74 6f 20 72 65 ll be hard to re
4e30: 61 64 20 6f 75 74 20 6f 66 20 74 68 61 74 20 63 ad out of that c
4e40: 6f 6e 74 65 78 74 20 75 6e 74 69 6c 20 69 74 27 ontext until it'
4e50: 73 0a 3b 3b 20 63 6c 65 61 6e 65 64 20 75 70 2e s.;; cleaned up.
4e60: 0a 0a 28 64 65 66 69 6e 65 20 28 6e 75 6d 2d 3e ..(define (num->
4e70: 73 74 72 69 6e 67 20 6e 20 73 74 20 2e 20 6f 70 string n st . op
4e80: 74 29 0a 20 20 28 63 61 6c 6c 2d 77 69 74 68 2d t). (call-with-
4e90: 6f 75 74 70 75 74 2d 73 74 72 69 6e 67 0a 20 20 output-string.
4ea0: 20 20 28 6c 61 6d 62 64 61 20 28 70 6f 72 74 29 (lambda (port)
4eb0: 0a 20 20 20 20 20 20 28 6c 65 74 2d 6f 70 74 69 . (let-opti
4ec0: 6f 6e 61 6c 73 2a 20 6f 70 74 0a 20 20 20 20 20 onals* opt.
4ed0: 20 20 20 20 20 28 28 62 61 73 65 20 28 66 6d 74 ((base (fmt
4ee0: 2d 72 61 64 69 78 20 73 74 29 29 0a 20 20 20 20 -radix st)).
4ef0: 20 20 20 20 20 20 20 28 64 69 67 69 74 73 20 28 (digits (
4f00: 66 6d 74 2d 70 72 65 63 69 73 69 6f 6e 20 73 74 fmt-precision st
4f10: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 73 )). (s
4f20: 69 67 6e 3f 20 23 66 29 0a 20 20 20 20 20 20 20 ign? #f).
4f30: 20 20 20 20 28 63 6f 6d 6d 69 66 79 3f 20 23 66 (commify? #f
4f40: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 63 6f ). (co
4f50: 6d 6d 61 2d 73 65 70 20 28 61 6e 64 20 63 6f 6d mma-sep (and com
4f60: 6d 69 66 79 3f 20 28 66 6d 74 2d 72 65 66 20 73 mify? (fmt-ref s
4f70: 74 20 27 63 6f 6d 6d 61 2d 63 68 61 72 20 23 5c t 'comma-char #\
4f80: 2c 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ,))).
4f90: 28 64 65 63 69 6d 61 6c 2d 73 65 70 20 28 6f 72 (decimal-sep (or
4fa0: 20 28 66 6d 74 2d 64 65 63 69 6d 61 6c 2d 73 65 (fmt-decimal-se
4fb0: 70 20 73 74 29 0a 20 20 20 20 20 20 20 20 20 20 p st).
4fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4fd0: 20 20 28 69 66 20 28 65 71 76 3f 20 63 6f 6d 6d (if (eqv? comm
4fe0: 61 2d 73 65 70 20 23 5c 2e 29 20 23 5c 2c 20 23 a-sep #\.) #\, #
4ff0: 5c 2e 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 \.))).
5000: 20 28 63 6f 6d 6d 61 2d 72 75 6c 65 20 28 69 66 (comma-rule (if
5010: 20 28 65 71 3f 20 63 6f 6d 6d 69 66 79 3f 20 23 (eq? commify? #
5020: 74 29 20 33 20 63 6f 6d 6d 69 66 79 3f 29 29 0a t) 3 commify?)).
5030: 20 20 20 20 20 20 20 20 20 20 20 28 61 6c 69 67 (alig
5040: 6e 20 28 66 6d 74 2d 64 65 63 69 6d 61 6c 2d 61 n (fmt-decimal-a
5050: 6c 69 67 6e 20 73 74 29 29 0a 20 20 20 20 20 20 lign st)).
5060: 20 20 20 20 20 28 64 69 67 69 74 2d 76 65 63 20 (digit-vec
5070: 64 65 66 61 75 6c 74 2d 64 69 67 69 74 73 29 0a default-digits).
5080: 20 20 20 20 20 20 20 20 20 20 20 28 73 74 61 63 (stac
5090: 6b 20 27 28 29 29 29 0a 0a 20 20 20 20 20 20 20 k '()))..
50a0: 20 28 64 65 66 69 6e 65 20 28 77 72 69 74 65 2d (define (write-
50b0: 64 69 67 69 74 20 64 29 0a 20 20 20 20 20 20 20 digit d).
50c0: 20 20 20 28 64 69 73 70 6c 61 79 20 28 76 65 63 (display (vec
50d0: 74 6f 72 2d 72 65 66 20 64 69 67 69 74 2d 76 65 tor-ref digit-ve
50e0: 63 20 28 69 6e 65 78 61 63 74 2d 3e 65 78 61 63 c (inexact->exac
50f0: 74 20 28 74 72 75 6e 63 61 74 65 20 64 29 29 29 t (truncate d)))
5100: 20 70 6f 72 74 29 29 0a 0a 20 20 20 20 20 20 20 port))..
5110: 20 3b 3b 20 54 68 69 73 20 69 73 20 75 67 6c 79 ;; This is ugly
5120: 20 62 65 63 61 75 73 65 20 77 65 20 6e 65 65 64 because we need
5130: 20 74 6f 20 6b 65 65 70 20 61 20 6c 69 73 74 20 to keep a list
5140: 6f 66 20 61 6c 6c 20 6f 75 74 70 75 74 0a 20 20 of all output.
5150: 20 20 20 20 20 20 3b 3b 20 6f 66 20 74 68 65 20 ;; of the
5160: 66 6f 72 6d 20 78 39 39 39 39 2e 2e 2e 20 69 6e form x9999... in
5170: 20 63 61 73 65 20 77 65 20 67 65 74 20 74 6f 20 case we get to
5180: 74 68 65 20 65 6e 64 20 6f 66 20 74 68 65 0a 20 the end of the.
5190: 20 20 20 20 20 20 20 3b 3b 20 70 72 65 63 69 73 ;; precis
51a0: 69 6f 6e 20 61 6e 64 20 6e 65 65 64 20 74 6f 20 ion and need to
51b0: 72 6f 75 6e 64 20 75 70 2e 20 20 41 6c 61 73 2c round up. Alas,
51c0: 20 69 66 20 69 74 20 77 65 72 65 6e 27 74 20 66 if it weren't f
51d0: 6f 72 0a 20 20 20 20 20 20 20 20 3b 3b 20 64 65 or. ;; de
51e0: 63 69 6d 61 6c 73 20 61 6e 64 20 63 6f 6d 6d 61 cimals and comma
51f0: 73 2c 20 77 65 20 63 6f 75 6c 64 20 6a 75 73 74 s, we could just
5200: 20 6b 65 65 70 20 74 72 61 63 6b 20 6f 66 20 74 keep track of t
5210: 68 65 20 6c 61 73 74 0a 20 20 20 20 20 20 20 20 he last.
5220: 3b 3b 20 6e 6f 6e 2d 39 20 64 69 67 69 74 20 61 ;; non-9 digit a
5230: 6e 64 20 74 68 65 20 6e 75 6d 62 65 72 20 6f 66 nd the number of
5240: 20 6e 69 6e 65 73 20 73 65 65 6e 2c 20 77 69 74 nines seen, wit
5250: 68 6f 75 74 20 61 6e 79 20 6e 65 65 64 0a 20 20 hout any need.
5260: 20 20 20 20 20 20 3b 3b 20 66 6f 72 20 61 20 68 ;; for a h
5270: 65 61 70 2d 61 6c 6c 6f 63 61 74 65 64 20 73 74 eap-allocated st
5280: 61 63 6b 2e 0a 20 20 20 20 20 20 20 20 28 64 65 ack.. (de
5290: 66 69 6e 65 20 28 77 72 69 74 65 2d 64 69 67 69 fine (write-digi
52a0: 74 2d 6c 69 73 74 20 6c 73 29 0a 20 20 20 20 20 t-list ls).
52b0: 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 (for-each.
52c0: 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 (lambd
52d0: 61 20 28 78 29 20 28 69 66 20 28 6e 75 6d 62 65 a (x) (if (numbe
52e0: 72 3f 20 78 29 20 28 77 72 69 74 65 2d 64 69 67 r? x) (write-dig
52f0: 69 74 20 78 29 20 28 64 69 73 70 6c 61 79 20 78 it x) (display x
5300: 20 70 6f 72 74 29 29 29 0a 20 20 20 20 20 20 20 port))).
5310: 20 20 20 20 6c 73 29 29 0a 0a 20 20 20 20 20 20 ls))..
5320: 20 20 28 64 65 66 69 6e 65 20 28 66 6c 75 73 68 (define (flush
5330: 29 0a 20 20 20 20 20 20 20 20 20 20 28 77 72 69 ). (wri
5340: 74 65 2d 64 69 67 69 74 2d 6c 69 73 74 20 28 72 te-digit-list (r
5350: 65 76 65 72 73 65 20 73 74 61 63 6b 29 29 0a 20 everse stack)).
5360: 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 73 (set! s
5370: 74 61 63 6b 20 27 28 29 29 29 0a 0a 20 20 20 20 tack '()))..
5380: 20 20 20 20 28 64 65 66 69 6e 65 20 28 66 6c 75 (define (flu
5390: 73 68 2f 72 6f 75 6e 64 65 64 29 0a 20 20 20 20 sh/rounded).
53a0: 20 20 20 20 20 20 28 6c 65 74 20 6c 70 20 28 28 (let lp ((
53b0: 6c 73 20 73 74 61 63 6b 29 20 28 72 65 73 20 27 ls stack) (res '
53c0: 28 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ())).
53d0: 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 (cond.
53e0: 20 20 20 20 28 28 6e 75 6c 6c 3f 20 6c 73 29 0a ((null? ls).
53f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 77 (w
5400: 72 69 74 65 2d 64 69 67 69 74 2d 6c 69 73 74 20 rite-digit-list
5410: 28 63 6f 6e 73 20 23 5c 31 20 72 65 73 29 29 29 (cons #\1 res)))
5420: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 . ((
5430: 6e 6f 74 20 28 6e 75 6d 62 65 72 3f 20 28 63 61 not (number? (ca
5440: 72 20 6c 73 29 29 29 0a 20 20 20 20 20 20 20 20 r ls))).
5450: 20 20 20 20 20 20 28 6c 70 20 28 63 64 72 20 6c (lp (cdr l
5460: 73 29 20 28 63 6f 6e 73 20 28 63 61 72 20 6c 73 s) (cons (car ls
5470: 29 20 72 65 73 29 29 29 0a 20 20 20 20 20 20 20 ) res))).
5480: 20 20 20 20 20 20 28 28 3d 20 28 63 61 72 20 6c ((= (car l
5490: 73 29 20 28 2d 20 62 61 73 65 20 31 29 29 0a 20 s) (- base 1)).
54a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 70 (lp
54b0: 20 28 63 64 72 20 6c 73 29 20 28 63 6f 6e 73 20 (cdr ls) (cons
54c0: 23 5c 30 20 72 65 73 29 29 29 0a 20 20 20 20 20 #\0 res))).
54d0: 20 20 20 20 20 20 20 20 28 65 6c 73 65 0a 20 20 (else.
54e0: 20 20 20 20 20 20 20 20 20 20 20 20 28 77 72 69 (wri
54f0: 74 65 2d 64 69 67 69 74 2d 6c 69 73 74 0a 20 20 te-digit-list.
5500: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 (ap
5510: 70 65 6e 64 20 28 72 65 76 65 72 73 65 20 28 63 pend (reverse (c
5520: 64 72 20 6c 73 29 29 20 28 63 6f 6e 73 20 28 2b dr ls)) (cons (+
5530: 20 31 20 28 63 61 72 20 6c 73 29 29 20 72 65 73 1 (car ls)) res
5540: 29 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 )))))).
5550: 20 28 73 65 74 21 20 73 74 61 63 6b 20 27 28 29 (set! stack '()
5560: 29 29 0a 0a 20 20 20 20 20 20 20 20 28 64 65 66 )).. (def
5570: 69 6e 65 20 28 6f 75 74 70 75 74 20 64 69 67 69 ine (output digi
5580: 74 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 t). (if
5590: 20 28 61 6e 64 20 28 6e 75 6d 62 65 72 3f 20 64 (and (number? d
55a0: 69 67 69 74 29 20 28 3c 20 64 69 67 69 74 20 28 igit) (< digit (
55b0: 2d 20 62 61 73 65 20 31 29 29 29 0a 20 20 20 20 - base 1))).
55c0: 20 20 20 20 20 20 20 20 20 20 28 66 6c 75 73 68 (flush
55d0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 73 65 )). (se
55e0: 74 21 20 73 74 61 63 6b 20 28 63 6f 6e 73 20 64 t! stack (cons d
55f0: 69 67 69 74 20 73 74 61 63 6b 29 29 29 0a 0a 20 igit stack)))..
5600: 20 20 20 20 20 20 20 28 64 65 66 69 6e 65 20 28 (define (
5610: 77 72 69 74 65 2d 70 72 65 66 69 78 20 70 72 65 write-prefix pre
5620: 66 69 78 20 61 6c 69 67 6e 20 6b 29 0a 20 20 20 fix align k).
5630: 20 20 20 20 20 20 20 28 69 66 20 61 6c 69 67 6e (if align
5640: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
5650: 6c 65 74 2a 20 28 28 70 72 65 66 69 78 20 28 63 let* ((prefix (c
5660: 6f 6e 64 20 28 28 73 74 72 69 6e 67 3f 20 70 72 ond ((string? pr
5670: 65 66 69 78 29 20 70 72 65 66 69 78 29 0a 20 20 efix) prefix).
5680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
56a0: 20 28 28 63 68 61 72 3f 20 70 72 65 66 69 78 29 ((char? prefix)
56b0: 20 28 73 74 72 69 6e 67 20 70 72 65 66 69 78 29 (string prefix)
56c0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
56d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
56e0: 20 20 20 20 20 28 65 6c 73 65 20 22 22 29 29 29 (else "")))
56f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
5700: 20 20 20 20 20 20 28 64 69 66 66 20 28 2d 20 61 (diff (- a
5710: 6c 69 67 6e 0a 20 20 20 20 20 20 20 20 20 20 20 lign.
5720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5730: 20 20 20 28 2b 20 28 69 66 20 28 3c 3d 20 6b 20 (+ (if (<= k
5740: 30 29 20 31 20 6b 29 20 28 73 74 72 69 6e 67 2d 0) 1 k) (string-
5750: 6c 65 6e 67 74 68 20 70 72 65 66 69 78 29 29 0a length prefix)).
5760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 31 29 1)
5780: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
5790: 20 20 20 28 69 66 20 28 70 6f 73 69 74 69 76 65 (if (positive
57a0: 3f 20 64 69 66 66 29 0a 20 20 20 20 20 20 20 20 ? diff).
57b0: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 69 73 (dis
57c0: 70 6c 61 79 20 28 6d 61 6b 65 2d 73 74 72 69 6e play (make-strin
57d0: 67 20 64 69 66 66 20 28 66 6d 74 2d 70 61 64 2d g diff (fmt-pad-
57e0: 63 68 61 72 20 73 74 29 29 20 70 6f 72 74 29 29 char st)) port))
57f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
5800: 20 28 64 69 73 70 6c 61 79 20 70 72 65 66 69 78 (display prefix
5810: 20 70 6f 72 74 29 29 0a 20 20 20 20 20 20 20 20 port)).
5820: 20 20 20 20 20 20 28 69 66 20 70 72 65 66 69 78 (if prefix
5830: 20 28 64 69 73 70 6c 61 79 20 70 72 65 66 69 78 (display prefix
5840: 20 70 6f 72 74 29 29 29 29 20 0a 0a 20 20 20 20 port)))) ..
5850: 20 20 20 20 28 64 65 66 69 6e 65 20 28 77 72 69 (define (wri
5860: 74 65 2d 72 65 61 6c 20 6e 20 70 72 65 66 69 78 te-real n prefix
5870: 20 61 6c 69 67 6e 29 0a 0a 20 20 20 20 20 20 20 align)..
5880: 20 20 20 28 6c 65 74 2a 20 28 28 6d 2b 65 20 28 (let* ((m+e (
5890: 6d 61 6e 74 69 73 73 61 2b 65 78 70 6f 6e 65 6e mantissa+exponen
58a0: 74 20 28 65 78 61 63 74 2d 3e 69 6e 65 78 61 63 t (exact->inexac
58b0: 74 20 6e 29 29 29 0a 20 20 20 20 20 20 20 20 20 t n))).
58c0: 20 20 20 20 20 20 20 20 28 66 20 28 63 61 72 20 (f (car
58d0: 6d 2b 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 m+e)).
58e0: 20 20 20 20 20 20 20 28 65 20 28 63 61 64 72 20 (e (cadr
58f0: 6d 2b 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 m+e)).
5900: 20 20 20 20 20 20 20 28 69 6e 76 2d 62 61 73 65 (inv-base
5910: 20 28 69 6e 76 6c 6f 67 32 6f 66 20 62 61 73 65 (invlog2of base
5920: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
5930: 20 20 20 20 28 72 6f 75 6e 64 3f 20 28 65 76 65 (round? (eve
5940: 6e 3f 20 66 29 29 0a 20 20 20 20 20 20 20 20 20 n? f)).
5950: 20 20 20 20 20 20 20 20 28 73 6d 61 6c 6c 65 72 (smaller
5960: 20 28 69 66 20 72 6f 75 6e 64 3f 20 3c 3d 20 3c (if round? <= <
5970: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
5980: 20 20 20 20 28 62 69 67 67 65 72 20 28 69 66 20 (bigger (if
5990: 72 6f 75 6e 64 3f 20 3e 3d 20 3e 29 29 29 0a 0a round? >= >)))..
59a0: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 66 (def
59b0: 69 6e 65 20 28 70 61 64 20 64 20 69 29 20 3b 3b ine (pad d i) ;;
59c0: 20 6a 75 73 74 20 70 61 64 20 30 27 73 2c 20 6e just pad 0's, n
59d0: 6f 74 20 23 27 73 0a 20 20 20 20 20 20 20 20 20 ot #'s.
59e0: 20 20 20 20 20 28 77 72 69 74 65 2d 64 69 67 69 (write-digi
59f0: 74 20 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 t d).
5a00: 20 20 20 28 6c 65 74 20 6c 70 20 28 28 69 20 28 (let lp ((i (
5a10: 2d 20 69 20 31 29 29 29 0a 20 20 20 20 20 20 20 - i 1))).
5a20: 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 (cond.
5a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5a40: 28 28 3e 3d 20 69 20 30 29 0a 20 20 20 20 20 20 ((>= i 0).
5a50: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
5a60: 28 61 6e 64 20 63 6f 6d 6d 69 66 79 3f 0a 20 20 (and commify?.
5a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5a80: 20 20 20 20 20 20 20 20 20 28 69 66 20 64 69 67 (if dig
5a90: 69 74 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 its.
5aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ab0: 20 20 20 28 61 6e 64 20 28 3e 20 69 20 64 69 67 (and (> i dig
5ac0: 69 74 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 its).
5ad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ae0: 20 20 20 20 20 20 20 20 20 28 7a 65 72 6f 3f 20 (zero?
5af0: 28 6d 6f 64 75 6c 6f 20 28 2d 20 69 20 28 2d 20 (modulo (- i (-
5b00: 64 69 67 69 74 73 20 31 29 29 0a 20 20 20 20 20 digits 1)).
5b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 63 6f co
5b40: 6d 6d 61 2d 72 75 6c 65 29 29 29 0a 20 20 20 20 mma-rule))).
5b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b60: 20 20 20 20 20 20 20 20 20 20 20 28 61 6e 64 20 (and
5b70: 28 70 6f 73 69 74 69 76 65 3f 20 69 29 0a 20 20 (positive? i).
5b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ba0: 20 20 28 7a 65 72 6f 3f 20 28 6d 6f 64 75 6c 6f (zero? (modulo
5bb0: 20 69 20 63 6f 6d 6d 61 2d 72 75 6c 65 29 29 29 i comma-rule)))
5bc0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
5bd0: 20 20 20 20 20 20 20 20 20 28 64 69 73 70 6c 61 (displa
5be0: 79 20 63 6f 6d 6d 61 2d 73 65 70 20 70 6f 72 74 y comma-sep port
5bf0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
5c00: 20 20 20 20 20 28 69 66 20 28 3d 20 69 20 28 2d (if (= i (-
5c10: 20 64 69 67 69 74 73 20 31 29 29 0a 20 20 20 20 digits 1)).
5c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5c30: 20 20 28 64 69 73 70 6c 61 79 20 64 65 63 69 6d (display decim
5c40: 61 6c 2d 73 65 70 20 70 6f 72 74 29 29 0a 20 20 al-sep port)).
5c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5c60: 28 77 72 69 74 65 2d 64 69 67 69 74 20 30 29 0a (write-digit 0).
5c70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5c80: 20 20 28 6c 70 20 28 2d 20 69 20 31 29 29 29 29 (lp (- i 1))))
5c90: 29 29 0a 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))..
5ca0: 28 64 65 66 69 6e 65 20 28 70 61 64 2d 61 6c 6c (define (pad-all
5cb0: 20 64 20 69 29 0a 20 20 20 20 20 20 20 20 20 20 d i).
5cc0: 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 (cond.
5cd0: 20 20 20 20 20 20 20 20 20 28 28 3e 3d 20 64 20 ((>= d
5ce0: 62 61 73 65 29 0a 20 20 20 20 20 20 20 20 20 20 base).
5cf0: 20 20 20 20 20 20 28 66 6c 75 73 68 2f 72 6f 75 (flush/rou
5d00: 6e 64 65 64 29 29 0a 20 20 20 20 20 20 20 20 20 nded)).
5d10: 20 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 (else.
5d20: 20 20 20 20 20 20 20 20 20 20 20 20 28 66 6c 75 (flu
5d30: 73 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 sh).
5d40: 20 20 20 20 28 77 72 69 74 65 2d 64 69 67 69 74 (write-digit
5d50: 20 64 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 d))).
5d60: 20 20 20 20 28 6c 65 74 20 6c 70 20 28 28 69 20 (let lp ((i
5d70: 28 2d 20 69 20 31 29 29 29 0a 20 20 20 20 20 20 (- i 1))).
5d80: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a (cond.
5d90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5da0: 20 28 28 3e 20 69 20 30 29 0a 20 20 20 20 20 20 ((> i 0).
5db0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
5dc0: 28 61 6e 64 20 63 6f 6d 6d 69 66 79 3f 20 28 7a (and commify? (z
5dd0: 65 72 6f 3f 20 28 6d 6f 64 75 6c 6f 20 69 20 63 ero? (modulo i c
5de0: 6f 6d 6d 61 2d 72 75 6c 65 29 29 29 0a 20 20 20 omma-rule))).
5df0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5e00: 20 20 20 28 64 69 73 70 6c 61 79 20 63 6f 6d 6d (display comm
5e10: 61 2d 73 65 70 20 70 6f 72 74 29 29 0a 20 20 20 a-sep port)).
5e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
5e30: 77 72 69 74 65 2d 64 69 67 69 74 20 30 29 0a 20 write-digit 0).
5e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5e50: 20 28 6c 70 20 28 2d 20 69 20 31 29 29 29 0a 20 (lp (- i 1))).
5e60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5e70: 28 28 61 6e 64 20 28 3d 20 69 20 30 29 20 28 69 ((and (= i 0) (i
5e80: 6e 65 78 61 63 74 3f 20 6e 29 29 0a 20 20 20 20 nexact? n)).
5e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
5ea0: 69 73 70 6c 61 79 20 64 65 63 69 6d 61 6c 2d 73 isplay decimal-s
5eb0: 65 70 20 70 6f 72 74 29 0a 20 20 20 20 20 20 20 ep port).
5ec0: 20 20 20 20 20 20 20 20 20 20 20 28 77 72 69 74 (writ
5ed0: 65 2d 64 69 67 69 74 20 30 29 29 29 29 29 0a 0a e-digit 0)))))..
5ee0: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 28 64 ;;(d
5ef0: 65 66 69 6e 65 20 28 70 61 64 2d 73 63 69 20 64 efine (pad-sci d
5f00: 20 69 20 6b 29 0a 20 20 20 20 20 20 20 20 20 20 i k).
5f10: 20 20 3b 3b 20 20 28 63 6f 6e 64 0a 20 20 20 20 ;; (cond.
5f20: 20 20 20 20 20 20 20 20 3b 3b 20 20 20 28 28 3e ;; ((>
5f30: 3d 20 64 20 62 61 73 65 29 0a 20 20 20 20 20 20 = d base).
5f40: 20 20 20 20 20 20 3b 3b 20 20 20 20 28 66 6c 75 ;; (flu
5f50: 73 68 2f 72 6f 75 6e 64 65 64 29 29 0a 20 20 20 sh/rounded)).
5f60: 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 28 65 ;; (e
5f70: 6c 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 lse.
5f80: 3b 3b 20 20 20 20 28 66 6c 75 73 68 29 0a 20 20 ;; (flush).
5f90: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 ;;
5fa0: 28 77 72 69 74 65 2d 64 69 67 69 74 20 64 29 29 (write-digit d))
5fb0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ). ;;
5fc0: 20 20 28 77 72 69 74 65 2d 63 68 61 72 20 23 5c (write-char #\
5fd0: 65 20 70 6f 72 74 29 0a 20 20 20 20 20 20 20 20 e port).
5fe0: 20 20 20 20 3b 3b 20 20 28 63 6f 6e 64 0a 20 20 ;; (cond.
5ff0: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 28 ;; (
6000: 28 70 6f 73 69 74 69 76 65 3f 20 6b 29 0a 20 20 (positive? k).
6010: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 ;;
6020: 28 77 72 69 74 65 2d 63 68 61 72 20 23 5c 2b 20 (write-char #\+
6030: 70 6f 72 74 29 0a 20 20 20 20 20 20 20 20 20 20 port).
6040: 20 20 3b 3b 20 20 20 20 28 77 72 69 74 65 20 28 ;; (write (
6050: 2d 20 6b 20 31 29 20 70 6f 72 74 29 29 0a 20 20 - k 1) port)).
6060: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 28 ;; (
6070: 65 6c 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 else.
6080: 20 3b 3b 20 20 20 20 28 77 72 69 74 65 20 6b 20 ;; (write k
6090: 70 6f 72 74 29 29 29 29 0a 0a 20 20 20 20 20 20 port))))..
60a0: 20 20 20 20 20 20 28 64 65 66 69 6e 65 20 28 73 (define (s
60b0: 63 61 6c 65 20 72 20 73 20 6d 2b 20 6d 2d 20 6b cale r s m+ m- k
60c0: 20 66 20 65 29 0a 20 20 20 20 20 20 20 20 20 20 f e).
60d0: 20 20 20 20 28 6c 65 74 20 28 28 65 73 74 20 28 (let ((est (
60e0: 69 6e 65 78 61 63 74 2d 3e 65 78 61 63 74 0a 20 inexact->exact.
60f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6100: 20 20 20 20 20 20 20 20 20 28 63 65 69 6c 69 6e (ceilin
6110: 67 20 28 2d 20 28 2a 20 28 2b 20 65 20 28 69 6e g (- (* (+ e (in
6120: 74 65 67 65 72 2d 6c 65 6e 67 74 68 2a 20 66 29 teger-length* f)
6130: 20 2d 31 29 0a 20 20 20 20 20 20 20 20 20 20 20 -1).
6140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
6160: 6e 76 6c 6f 67 32 6f 66 20 62 61 73 65 29 29 0a nvlog2of base)).
6170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6190: 20 20 20 20 20 20 31 2e 30 65 2d 31 30 29 29 29 1.0e-10)))
61a0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
61b0: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 65 67 (if (not (neg
61c0: 61 74 69 76 65 3f 20 65 73 74 29 29 0a 20 20 20 ative? est)).
61d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
61e0: 20 28 66 69 78 75 70 20 72 20 28 2a 20 73 20 28 (fixup r (* s (
61f0: 66 61 73 74 2d 65 78 70 74 20 62 61 73 65 20 65 fast-expt base e
6200: 73 74 29 29 20 6d 2b 20 6d 2d 20 65 73 74 29 0a st)) m+ m- est).
6210: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6220: 20 20 20 20 28 6c 65 74 20 28 28 73 6b 61 6c 65 (let ((skale
6230: 20 28 66 61 73 74 2d 65 78 70 74 20 62 61 73 65 (fast-expt base
6240: 20 28 2d 20 65 73 74 29 29 29 29 0a 20 20 20 20 (- est)))).
6250: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6260: 20 20 28 66 69 78 75 70 20 28 2a 20 72 20 73 6b (fixup (* r sk
6270: 61 6c 65 29 20 73 20 28 2a 20 6d 2b 20 73 6b 61 ale) s (* m+ ska
6280: 6c 65 29 20 28 2a 20 6d 2d 20 73 6b 61 6c 65 29 le) (* m- skale)
6290: 20 65 73 74 29 29 29 29 29 0a 0a 20 20 20 20 20 est)))))..
62a0: 20 20 20 20 20 20 20 28 64 65 66 69 6e 65 20 28 (define (
62b0: 66 69 78 75 70 20 72 20 73 20 6d 2b 20 6d 2d 20 fixup r s m+ m-
62c0: 6b 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 k).
62d0: 20 28 69 66 20 28 61 6e 64 20 28 62 69 67 67 65 (if (and (bigge
62e0: 72 20 28 2b 20 72 20 6d 2b 29 20 73 29 29 20 3b r (+ r m+) s)) ;
62f0: 3b 20 28 6f 72 20 64 69 67 69 74 73 20 28 3e 3d ; (or digits (>=
6300: 20 6b 20 2d 34 29 29 0a 20 20 20 20 20 20 20 20 k -4)).
6310: 20 20 20 20 20 20 20 20 20 20 28 6c 65 61 64 20 (lead
6320: 72 20 73 20 6d 2b 20 6d 2d 20 28 2b 20 6b 20 31 r s m+ m- (+ k 1
6330: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
6340: 20 20 20 20 20 28 6c 65 61 64 20 28 2a 20 72 20 (lead (* r
6350: 62 61 73 65 29 20 73 20 28 2a 20 6d 2b 20 62 61 base) s (* m+ ba
6360: 73 65 29 20 28 2a 20 6d 2d 20 62 61 73 65 29 20 se) (* m- base)
6370: 6b 29 29 29 0a 0a 20 20 20 20 20 20 20 20 20 20 k)))..
6380: 20 20 28 64 65 66 69 6e 65 20 28 6c 65 61 64 20 (define (lead
6390: 72 20 73 20 6d 2b 20 6d 2d 20 6b 29 0a 20 20 20 r s m+ m- k).
63a0: 20 20 20 20 20 20 20 20 20 20 20 28 77 72 69 74 (writ
63b0: 65 2d 70 72 65 66 69 78 20 70 72 65 66 69 78 20 e-prefix prefix
63c0: 61 6c 69 67 6e 20 6b 29 0a 20 20 20 20 20 20 20 align k).
63d0: 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 (cond.
63e0: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 61 6e ((an
63f0: 64 20 28 6e 6f 74 20 64 69 67 69 74 73 29 20 28 d (not digits) (
6400: 6f 72 20 28 3e 20 6b 20 31 34 29 20 28 3c 20 6b or (> k 14) (< k
6410: 20 2d 34 29 29 29 0a 20 20 20 20 20 20 20 20 20 -4))).
6420: 20 20 20 20 20 20 20 28 77 72 69 74 65 20 6e 20 (write n
6430: 70 6f 72 74 29 29 20 20 20 20 20 20 3b 20 58 58 port)) ; XX
6440: 58 58 20 6e 61 74 69 76 65 20 77 72 69 74 65 20 XX native write
6450: 66 6f 72 20 73 63 69 0a 20 20 20 20 20 20 20 20 for sci.
6460: 20 20 20 20 20 20 20 3b 3b 28 28 61 6e 64 20 28 ;;((and (
6470: 6e 6f 74 20 64 69 67 69 74 73 29 20 28 3e 20 6b not digits) (> k
6480: 20 31 34 29 29 0a 20 20 20 20 20 20 20 20 20 20 14)).
6490: 20 20 20 20 20 3b 3b 20 28 67 65 6e 65 72 61 74 ;; (generat
64a0: 65 2d 73 63 69 20 72 20 73 20 6d 2b 20 6d 2d 20 e-sci r s m+ m-
64b0: 6b 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 k)).
64c0: 20 20 20 3b 3b 28 28 61 6e 64 20 28 6e 6f 74 20 ;;((and (not
64d0: 64 69 67 69 74 73 29 20 28 3c 20 6b 20 2d 34 29 digits) (< k -4)
64e0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
64f0: 20 3b 3b 20 28 69 66 20 28 3e 3d 20 28 2f 20 72 ;; (if (>= (/ r
6500: 20 73 29 20 62 61 73 65 29 0a 20 20 20 20 20 20 s) base).
6510: 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 ;;
6520: 28 67 65 6e 65 72 61 74 65 2d 73 63 69 20 28 2f (generate-sci (/
6530: 20 72 20 62 61 73 65 29 20 73 20 28 2f 20 6d 2b r base) s (/ m+
6540: 20 62 61 73 65 29 20 28 2f 20 6d 2d 20 62 61 73 base) (/ m- bas
6550: 65 29 20 6b 29 0a 20 20 20 20 20 20 20 20 20 20 e) k).
6560: 20 20 20 20 20 3b 3b 20 20 20 20 20 28 67 65 6e ;; (gen
6570: 65 72 61 74 65 2d 73 63 69 20 72 20 73 20 6d 2b erate-sci r s m+
6580: 20 6d 2d 20 6b 29 29 29 0a 20 20 20 20 20 20 20 m- k))).
6590: 20 20 20 20 20 20 20 20 28 65 6c 73 65 0a 20 20 (else.
65a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
65b0: 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 ond.
65c0: 20 20 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 ((and (not
65d0: 64 69 67 69 74 73 29 0a 20 20 20 20 20 20 20 20 digits).
65e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
65f0: 6f 72 20 28 6e 65 67 61 74 69 76 65 3f 20 6b 29 or (negative? k)
6600: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6610: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 6e 64 (and
6620: 20 28 7a 65 72 6f 3f 20 6b 29 20 28 6e 6f 74 20 (zero? k) (not
6630: 28 69 6e 74 65 67 65 72 3f 20 6e 29 29 29 29 29 (integer? n)))))
6640: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6650: 20 20 20 28 77 72 69 74 65 2d 64 69 67 69 74 20 (write-digit
6660: 30 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 0).
6670: 20 20 20 20 20 28 64 69 73 70 6c 61 79 20 64 65 (display de
6680: 63 69 6d 61 6c 2d 73 65 70 20 70 6f 72 74 29 0a cimal-sep port).
6690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
66a0: 20 20 28 6c 65 74 20 6c 70 20 28 28 69 20 30 29 (let lp ((i 0)
66b0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
66c0: 20 20 20 20 20 20 28 63 6f 6e 64 20 28 28 3e 20 (cond ((>
66d0: 69 20 6b 29 0a 20 20 20 20 20 20 20 20 20 20 20 i k).
66e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
66f0: 28 77 72 69 74 65 2d 64 69 67 69 74 20 30 29 0a (write-digit 0).
6700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6710: 20 20 20 20 20 20 20 20 20 20 20 28 6c 70 20 28 (lp (
6720: 2d 20 69 20 31 29 29 29 29 29 29 29 0a 20 20 20 - i 1))))))).
6730: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
6740: 20 64 69 67 69 74 73 0a 20 20 20 20 20 20 20 20 digits.
6750: 20 20 20 20 20 20 20 20 20 20 20 20 28 67 65 6e (gen
6760: 65 72 61 74 65 2d 66 69 78 65 64 20 72 20 73 20 erate-fixed r s
6770: 6d 2b 20 6d 2d 20 6b 29 0a 20 20 20 20 20 20 20 m+ m- k).
6780: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 67 65 (ge
6790: 6e 65 72 61 74 65 2d 61 6c 6c 20 72 20 73 20 6d nerate-all r s m
67a0: 2b 20 6d 2d 20 6b 29 29 29 29 29 0a 0a 20 20 20 + m- k)))))..
67b0: 20 20 20 20 20 20 20 20 20 28 64 65 66 69 6e 65 (define
67c0: 20 28 67 65 6e 65 72 61 74 65 2d 61 6c 6c 20 72 (generate-all r
67d0: 20 73 20 6d 2b 20 6d 2d 20 6b 29 0a 20 20 20 20 s m+ m- k).
67e0: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 67 (let g
67f0: 65 6e 20 28 28 72 20 72 29 20 28 6d 2b 20 6d 2b en ((r r) (m+ m+
6800: 29 20 28 6d 2d 20 6d 2d 29 20 28 69 20 6b 29 29 ) (m- m-) (i k))
6810: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6820: 20 28 63 6f 6e 64 20 28 28 3d 20 69 20 6b 29 29 (cond ((= i k))
6830: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6840: 20 20 20 20 20 20 20 28 28 7a 65 72 6f 3f 20 69 ((zero? i
6850: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
6860: 20 20 20 20 20 20 20 20 20 28 6f 75 74 70 75 74 (output
6870: 20 64 65 63 69 6d 61 6c 2d 73 65 70 29 29 0a 20 decimal-sep)).
6880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6890: 20 20 20 20 20 28 28 61 6e 64 20 63 6f 6d 6d 69 ((and commi
68a0: 66 79 3f 0a 20 20 20 20 20 20 20 20 20 20 20 20 fy?.
68b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
68c0: 28 70 6f 73 69 74 69 76 65 3f 20 69 29 0a 20 20 (positive? i).
68d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
68e0: 20 20 20 20 20 20 20 20 20 20 28 7a 65 72 6f 3f (zero?
68f0: 20 28 6d 6f 64 75 6c 6f 20 69 20 63 6f 6d 6d 61 (modulo i comma
6900: 2d 72 75 6c 65 29 29 29 0a 20 20 20 20 20 20 20 -rule))).
6910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6920: 28 6f 75 74 70 75 74 20 63 6f 6d 6d 61 2d 73 65 (output comma-se
6930: 70 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 p))).
6940: 20 20 20 20 20 28 6c 65 74 20 28 28 64 20 28 71 (let ((d (q
6950: 75 6f 74 69 65 6e 74 20 72 20 73 29 29 0a 20 20 uotient r s)).
6960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6970: 20 20 20 20 28 72 20 28 72 65 6d 61 69 6e 64 65 (r (remainde
6980: 72 20 72 20 73 29 29 29 0a 20 20 20 20 20 20 20 r r s))).
6990: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
69a0: 6e 6f 74 20 28 73 6d 61 6c 6c 65 72 20 72 20 6d not (smaller r m
69b0: 2d 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 -)).
69c0: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a (cond.
69d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
69e0: 20 20 20 20 20 20 20 28 28 6e 6f 74 20 28 62 69 ((not (bi
69f0: 67 67 65 72 20 28 2b 20 72 20 6d 2b 29 20 73 29 gger (+ r m+) s)
6a00: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
6a10: 20 20 20 20 20 20 20 20 20 20 28 6f 75 74 70 75 (outpu
6a20: 74 20 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 t d).
6a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 67 65 (ge
6a40: 6e 20 28 2a 20 72 20 62 61 73 65 29 20 28 2a 20 n (* r base) (*
6a50: 6d 2b 20 62 61 73 65 29 20 28 2a 20 6d 2d 20 62 m+ base) (* m- b
6a60: 61 73 65 29 20 28 2d 20 69 20 31 29 29 29 0a 20 ase) (- i 1))).
6a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6a80: 20 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 (else.
6a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6aa0: 20 20 20 20 28 70 61 64 2d 61 6c 6c 20 28 2b 20 (pad-all (+
6ab0: 64 20 31 29 20 69 29 29 29 0a 20 20 20 20 20 20 d 1) i))).
6ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6ad0: 28 69 66 20 28 6e 6f 74 20 28 62 69 67 67 65 72 (if (not (bigger
6ae0: 20 28 2b 20 72 20 6d 2b 29 20 73 29 29 0a 20 20 (+ r m+) s)).
6af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6b00: 20 20 20 20 20 20 20 20 28 70 61 64 2d 61 6c 6c (pad-all
6b10: 20 64 20 69 29 0a 20 20 20 20 20 20 20 20 20 20 d i).
6b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6b30: 28 70 61 64 2d 61 6c 6c 20 28 69 66 20 28 3c 20 (pad-all (if (<
6b40: 28 2a 20 72 20 32 29 20 73 29 20 64 20 28 2b 20 (* r 2) s) d (+
6b50: 64 20 31 29 29 20 69 29 29 29 29 29 29 0a 0a 20 d 1)) i))))))..
6b60: 20 20 20 20 20 20 20 20 20 20 20 28 64 65 66 69 (defi
6b70: 6e 65 20 28 67 65 6e 65 72 61 74 65 2d 66 69 78 ne (generate-fix
6b80: 65 64 20 72 20 73 20 6d 2b 20 6d 2d 20 6b 29 0a ed r s m+ m- k).
6b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
6ba0: 66 20 28 3c 3d 20 6b 20 30 29 20 0a 20 20 20 20 f (<= k 0) .
6bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
6bc0: 65 74 21 20 73 74 61 63 6b 20 28 61 70 70 65 6e et! stack (appen
6bd0: 64 20 28 6d 61 6b 65 2d 6c 69 73 74 20 28 6d 69 d (make-list (mi
6be0: 6e 20 28 2d 20 6b 29 20 64 69 67 69 74 73 29 20 n (- k) digits)
6bf0: 30 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 0).
6c00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6c10: 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 20 64 (list d
6c20: 65 63 69 6d 61 6c 2d 73 65 70 20 30 29 29 29 29 ecimal-sep 0))))
6c30: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
6c40: 6c 65 74 20 28 28 69 30 20 28 2d 20 28 2b 20 6b let ((i0 (- (+ k
6c50: 20 64 69 67 69 74 73 29 20 31 29 29 29 0a 20 20 digits) 1))).
6c60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
6c70: 65 74 20 67 65 6e 20 28 28 72 20 72 29 20 28 6d et gen ((r r) (m
6c80: 2b 20 6d 2b 29 20 28 6d 2d 20 6d 2d 29 20 28 69 + m+) (m- m-) (i
6c90: 20 69 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 i0)).
6ca0: 20 20 20 20 20 20 20 20 28 63 6f 6e 64 20 28 28 (cond ((
6cb0: 3d 20 69 20 69 30 29 29 0a 20 20 20 20 20 20 20 = i i0)).
6cc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6cd0: 20 28 28 3d 20 69 20 28 2d 20 64 69 67 69 74 73 ((= i (- digits
6ce0: 20 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 1)).
6cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6f (o
6d00: 75 74 70 75 74 20 64 65 63 69 6d 61 6c 2d 73 65 utput decimal-se
6d10: 70 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 p)).
6d20: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 61 6e ((an
6d30: 64 20 63 6f 6d 6d 69 66 79 3f 0a 20 20 20 20 20 d commify?.
6d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6d50: 20 20 20 20 20 20 20 20 20 28 3e 20 69 20 64 69 (> i di
6d60: 67 69 74 73 29 0a 20 20 20 20 20 20 20 20 20 20 gits).
6d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6d80: 20 20 20 20 28 7a 65 72 6f 3f 20 28 6d 6f 64 75 (zero? (modu
6d90: 6c 6f 20 28 2d 20 69 20 28 2d 20 64 69 67 69 74 lo (- i (- digit
6da0: 73 20 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 s 1)).
6db0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6dd0: 20 20 20 63 6f 6d 6d 61 2d 72 75 6c 65 29 29 29 comma-rule)))
6de0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6df0: 20 20 20 20 20 20 20 20 20 20 28 6f 75 74 70 75 (outpu
6e00: 74 20 63 6f 6d 6d 61 2d 73 65 70 29 29 29 0a 20 t comma-sep))).
6e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6e20: 20 28 6c 65 74 20 28 28 64 20 28 71 75 6f 74 69 (let ((d (quoti
6e30: 65 6e 74 20 72 20 73 29 29 0a 20 20 20 20 20 20 ent r s)).
6e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6e50: 20 20 28 72 20 28 72 65 6d 61 69 6e 64 65 72 20 (r (remainder
6e60: 72 20 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 r s))).
6e70: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 (cond
6e80: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6e90: 20 20 20 20 20 20 28 28 3c 20 69 20 30 29 0a 20 ((< i 0).
6ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6eb0: 20 20 20 20 20 28 6c 65 74 20 28 28 64 32 20 28 (let ((d2 (
6ec0: 2a 20 32 20 28 69 66 20 28 3e 3d 20 28 2a 20 72 * 2 (if (>= (* r
6ed0: 20 32 29 20 73 29 20 28 2b 20 64 20 31 29 20 64 2) s) (+ d 1) d
6ee0: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
6ef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
6f00: 20 28 61 6e 64 20 28 6e 6f 74 20 28 3e 20 28 2d (and (not (> (-
6f10: 20 6b 29 20 64 69 67 69 74 73 29 29 0a 20 20 20 k) digits)).
6f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6f (o
6f40: 72 20 28 3e 20 64 32 20 62 61 73 65 29 0a 20 20 r (> d2 base).
6f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6f70: 20 20 20 28 61 6e 64 20 28 3d 20 64 32 20 62 61 (and (= d2 ba
6f80: 73 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 se).
6f90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p
6fb0: 61 69 72 3f 20 73 74 61 63 6b 29 0a 20 20 20 20 air? stack).
6fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6fe0: 20 20 20 20 20 20 28 6e 75 6d 62 65 72 3f 20 28 (number? (
6ff0: 63 61 72 20 73 74 61 63 6b 29 29 0a 20 20 20 20 car stack)).
7000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7020: 20 20 20 20 20 20 28 6f 64 64 3f 20 28 63 61 72 (odd? (car
7030: 20 73 74 61 63 6b 29 29 29 29 29 0a 20 20 20 20 stack))))).
7040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7050: 20 20 20 20 20 20 20 20 28 66 6c 75 73 68 2f 72 (flush/r
7060: 6f 75 6e 64 65 64 29 0a 20 20 20 20 20 20 20 20 ounded).
7070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7080: 20 20 20 20 28 66 6c 75 73 68 29 29 29 29 0a 20 (flush)))).
7090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
70a0: 20 20 20 20 28 28 73 6d 61 6c 6c 65 72 20 72 20 ((smaller r
70b0: 6d 2d 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 m-).
70c0: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a (cond.
70d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
70e0: 20 20 20 20 20 20 20 28 28 3e 3d 20 64 20 62 61 ((>= d ba
70f0: 73 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 se).
7100: 20 20 20 20 20 20 20 20 20 20 20 20 28 66 6c 75 (flu
7110: 73 68 2f 72 6f 75 6e 64 65 64 29 0a 20 20 20 20 sh/rounded).
7120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7130: 20 20 20 20 28 70 61 64 20 30 20 69 29 29 0a 20 (pad 0 i)).
7140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7150: 20 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 (else.
7160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7170: 20 20 20 20 28 66 6c 75 73 68 29 0a 20 20 20 20 (flush).
7180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7190: 20 20 20 20 28 69 66 20 28 62 69 67 67 65 72 20 (if (bigger
71a0: 28 2b 20 72 20 6d 2b 29 20 73 29 0a 20 20 20 20 (+ r m+) s).
71b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
71c0: 20 20 20 20 20 20 20 20 28 70 61 64 20 28 69 66 (pad (if
71d0: 20 28 3c 20 28 2a 20 72 20 32 29 20 73 29 20 64 (< (* r 2) s) d
71e0: 20 28 2b 20 64 20 31 29 29 20 69 29 0a 20 20 20 (+ d 1)) i).
71f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7200: 20 20 20 20 20 20 20 20 20 28 70 61 64 20 64 20 (pad d
7210: 69 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 i))))).
7220: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 62 69 ((bi
7230: 67 67 65 72 20 28 2b 20 72 20 6d 2b 29 20 73 29 gger (+ r m+) s)
7240: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7250: 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 (cond.
7260: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7270: 20 20 20 20 28 28 3e 3d 20 64 20 28 2d 20 62 61 ((>= d (- ba
7280: 73 65 20 31 29 29 0a 20 20 20 20 20 20 20 20 20 se 1)).
7290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
72a0: 66 6c 75 73 68 2f 72 6f 75 6e 64 65 64 29 0a 20 flush/rounded).
72b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
72c0: 20 20 20 20 20 20 20 28 70 61 64 20 30 20 69 29 (pad 0 i)
72d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
72e0: 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 0a 20 (else.
72f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7300: 20 20 20 20 20 20 20 28 66 6c 75 73 68 29 0a 20 (flush).
7310: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7320: 20 20 20 20 20 20 20 28 70 61 64 20 28 2b 20 64 (pad (+ d
7330: 20 31 29 20 69 29 29 29 29 0a 20 20 20 20 20 20 1) i)))).
7340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
7350: 65 6c 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 else.
7360: 20 20 20 20 20 20 20 20 20 20 20 28 6f 75 74 70 (outp
7370: 75 74 20 64 29 0a 20 20 20 20 20 20 20 20 20 20 ut d).
7380: 20 20 20 20 20 20 20 20 20 20 20 20 28 67 65 6e (gen
7390: 20 28 2a 20 72 20 62 61 73 65 29 20 28 2a 20 6d (* r base) (* m
73a0: 2b 20 62 61 73 65 29 20 28 2a 20 6d 2d 20 62 61 + base) (* m- ba
73b0: 73 65 29 20 28 2d 20 69 20 31 29 29 29 29 29 29 se) (- i 1))))))
73c0: 29 29 0a 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))..
73d0: 3b 3b 28 64 65 66 69 6e 65 20 28 67 65 6e 65 72 ;;(define (gener
73e0: 61 74 65 2d 73 63 69 20 72 20 73 20 6d 2b 20 6d ate-sci r s m+ m
73f0: 2d 20 6b 29 0a 20 20 20 20 20 20 20 20 20 20 20 - k).
7400: 20 3b 3b 20 20 28 6c 65 74 20 67 65 6e 20 28 28 ;; (let gen ((
7410: 72 20 72 29 20 28 6d 2b 20 6d 2b 29 20 28 6d 2d r r) (m+ m+) (m-
7420: 20 6d 2d 29 20 28 69 20 6b 29 29 0a 20 20 20 20 m-) (i k)).
7430: 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 28 63 ;; (c
7440: 6f 6e 64 20 28 28 3d 20 69 20 28 2d 20 6b 20 31 ond ((= i (- k 1
7450: 29 29 20 28 64 69 73 70 6c 61 79 20 64 65 63 69 )) (display deci
7460: 6d 61 6c 2d 73 65 70 20 70 6f 72 74 29 29 29 0a mal-sep port))).
7470: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 20 ;;
7480: 20 20 28 6c 65 74 20 28 28 64 20 28 71 75 6f 74 (let ((d (quot
7490: 69 65 6e 74 20 72 20 73 29 29 0a 20 20 20 20 20 ient r s)).
74a0: 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 ;;
74b0: 20 20 20 28 72 20 28 72 65 6d 61 69 6e 64 65 72 (r (remainder
74c0: 20 72 20 73 29 29 29 0a 20 20 20 20 20 20 20 20 r s))).
74d0: 20 20 20 20 3b 3b 20 20 20 20 20 20 28 69 66 20 ;; (if
74e0: 28 6e 6f 74 20 28 73 6d 61 6c 6c 65 72 20 72 20 (not (smaller r
74f0: 6d 2d 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 m-)).
7500: 20 3b 3b 20 20 20 20 20 20 20 20 20 20 28 63 6f ;; (co
7510: 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 3b nd. ;
7520: 3b 20 20 20 20 20 20 20 20 20 20 20 28 28 6e 6f ; ((no
7530: 74 20 28 62 69 67 67 65 72 20 28 2b 20 72 20 6d t (bigger (+ r m
7540: 2b 29 20 73 29 29 0a 20 20 20 20 20 20 20 20 20 +) s)).
7550: 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ;;
7560: 20 28 6f 75 74 70 75 74 20 64 29 0a 20 20 20 20 (output d).
7570: 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 ;;
7580: 20 20 20 20 20 20 28 67 65 6e 20 28 2a 20 72 20 (gen (* r
7590: 62 61 73 65 29 20 28 2a 20 6d 2b 20 62 61 73 65 base) (* m+ base
75a0: 29 20 28 2a 20 6d 2d 20 62 61 73 65 29 20 28 2d ) (* m- base) (-
75b0: 20 69 20 31 29 29 29 0a 20 20 20 20 20 20 20 20 i 1))).
75c0: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 ;;
75d0: 20 28 65 6c 73 65 20 28 70 61 64 2d 73 63 69 20 (else (pad-sci
75e0: 28 2b 20 64 20 31 29 20 69 20 6b 29 29 29 0a 20 (+ d 1) i k))).
75f0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 ;;
7600: 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 (if (not
7610: 28 62 69 67 67 65 72 20 28 2b 20 72 20 6d 2b 29 (bigger (+ r m+)
7620: 20 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 s)).
7630: 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
7640: 20 28 70 61 64 2d 73 63 69 20 64 20 69 20 6b 29 (pad-sci d i k)
7650: 0a 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 . ;;
7660: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 61 (pa
7670: 64 2d 73 63 69 20 28 69 66 20 28 3c 20 28 2a 20 d-sci (if (< (*
7680: 72 20 32 29 20 73 29 20 64 20 28 2b 20 64 20 31 r 2) s) d (+ d 1
7690: 29 29 20 69 20 6b 29 29 29 29 29 29 0a 0a 20 20 )) i k))))))..
76a0: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a (cond.
76b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 6e ((n
76c0: 65 67 61 74 69 76 65 3f 20 65 29 0a 20 20 20 20 egative? e).
76d0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6f (if (o
76e0: 72 20 28 3d 20 65 20 2a 6d 69 6e 2d 65 2a 29 20 r (= e *min-e*)
76f0: 28 6e 6f 74 20 28 3d 20 66 20 2a 62 6f 74 2d 66 (not (= f *bot-f
7700: 2a 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 *))).
7710: 20 20 20 20 20 20 20 28 73 63 61 6c 65 20 28 2a (scale (*
7720: 20 66 20 32 29 20 28 2a 20 28 65 78 70 74 20 32 f 2) (* (expt 2
7730: 2e 30 20 28 2d 20 65 29 29 20 32 29 20 31 20 31 .0 (- e)) 2) 1 1
7740: 20 30 20 66 20 65 29 0a 20 20 20 20 20 20 20 20 0 f e).
7750: 20 20 20 20 20 20 20 20 20 20 28 73 63 61 6c 65 (scale
7760: 20 28 2a 20 66 20 32 20 32 29 20 28 2a 20 28 65 (* f 2 2) (* (e
7770: 78 70 74 20 32 2e 30 20 28 2d 20 31 20 65 29 29 xpt 2.0 (- 1 e))
7780: 20 32 29 20 32 20 31 20 30 20 66 20 65 29 29 29 2) 2 1 0 f e)))
7790: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 . (e
77a0: 6c 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 lse.
77b0: 20 20 28 69 66 20 28 3d 20 66 20 2a 62 6f 74 2d (if (= f *bot-
77c0: 66 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 f*).
77d0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 62 65 20 (let ((be
77e0: 28 65 78 70 74 20 32 20 65 29 29 29 0a 20 20 20 (expt 2 e))).
77f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7800: 20 28 73 63 61 6c 65 20 28 2a 20 66 20 62 65 20 (scale (* f be
7810: 32 29 20 32 2e 30 20 62 65 20 62 65 20 30 20 66 2) 2.0 be be 0 f
7820: 20 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 e)).
7830: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 62 (let* ((b
7840: 65 20 28 65 78 70 74 20 32 20 65 29 29 20 28 62 e (expt 2 e)) (b
7850: 65 31 20 28 2a 20 62 65 20 32 29 29 29 0a 20 20 e1 (* be 2))).
7860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7870: 20 20 28 73 63 61 6c 65 20 28 2a 20 66 20 62 65 (scale (* f be
7880: 31 20 32 29 20 28 2a 20 32 2e 30 20 32 29 20 62 1 2) (* 2.0 2) b
7890: 65 31 20 62 65 20 30 20 66 20 65 29 29 29 29 29 e1 be 0 f e)))))
78a0: 29 29 0a 0a 20 20 20 20 20 20 20 20 28 64 65 66 )).. (def
78b0: 69 6e 65 20 28 77 72 69 74 65 2d 66 69 78 65 64 ine (write-fixed
78c0: 2d 72 61 74 69 6f 6e 61 6c 20 70 20 70 72 65 66 -rational p pref
78d0: 69 78 20 61 6c 69 67 6e 29 0a 20 20 20 20 20 20 ix align).
78e0: 20 20 20 20 28 64 65 66 69 6e 65 20 28 67 65 74 (define (get
78f0: 2d 73 63 61 6c 65 20 71 29 20 28 65 78 70 74 20 -scale q) (expt
7900: 62 61 73 65 20 28 2d 20 28 69 6e 74 65 67 65 72 base (- (integer
7910: 2d 6c 6f 67 20 71 20 62 61 73 65 29 20 31 29 29 -log q base) 1))
7920: 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 ). (let
7930: 20 28 28 6e 20 28 6e 75 6d 65 72 61 74 6f 72 20 ((n (numerator
7940: 70 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 p)).
7950: 20 20 20 20 28 64 20 28 64 65 6e 6f 6d 69 6e 61 (d (denomina
7960: 74 6f 72 20 70 29 29 0a 20 20 20 20 20 20 20 20 tor p)).
7970: 20 20 20 20 20 20 20 20 28 6b 20 28 69 6e 74 65 (k (inte
7980: 67 65 72 2d 6c 6f 67 20 70 20 62 61 73 65 29 29 ger-log p base))
7990: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 77 ). (w
79a0: 72 69 74 65 2d 70 72 65 66 69 78 20 70 72 65 66 rite-prefix pref
79b0: 69 78 20 61 6c 69 67 6e 20 6b 29 0a 20 20 20 20 ix align k).
79c0: 20 20 20 20 20 20 20 20 28 6c 65 74 20 6c 70 20 (let lp
79d0: 28 28 6e 20 6e 29 0a 20 20 20 20 20 20 20 20 20 ((n n).
79e0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 20 28 (i (
79f0: 2d 20 6b 29 29 29 0a 20 20 20 20 20 20 20 20 20 - k))).
7a00: 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 (cond.
7a10: 20 20 20 20 20 20 20 20 20 20 28 28 3c 20 69 20 ((< i
7a20: 64 69 67 69 74 73 29 0a 20 20 20 20 20 20 20 20 digits).
7a30: 20 20 20 20 20 20 20 20 28 69 66 20 28 7a 65 72 (if (zer
7a40: 6f 3f 20 69 29 20 28 6f 75 74 70 75 74 20 64 65 o? i) (output de
7a50: 63 69 6d 61 6c 2d 73 65 70 29 29 0a 20 20 20 20 cimal-sep)).
7a60: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
7a70: 20 28 28 71 20 28 71 75 6f 74 69 65 6e 74 20 6e ((q (quotient n
7a80: 20 64 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 d))).
7a90: 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 (cond.
7aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ab0: 20 28 28 3e 3d 20 71 20 62 61 73 65 29 0a 20 20 ((>= q base).
7ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ad0: 20 20 28 6c 65 74 2a 20 28 28 73 63 61 6c 65 20 (let* ((scale
7ae0: 28 67 65 74 2d 73 63 61 6c 65 20 71 29 29 0a 20 (get-scale q)).
7af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7b00: 20 20 20 20 20 20 20 20 20 20 28 64 69 67 69 74 (digit
7b10: 20 28 71 75 6f 74 69 65 6e 74 20 71 20 73 63 61 (quotient q sca
7b20: 6c 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 le)).
7b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7b40: 28 6e 32 20 28 2d 20 6e 20 28 2a 20 64 20 64 69 (n2 (- n (* d di
7b50: 67 69 74 20 73 63 61 6c 65 29 29 29 29 0a 20 20 git scale)))).
7b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7b70: 20 20 20 20 28 6f 75 74 70 75 74 20 64 69 67 69 (output digi
7b80: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t).
7b90: 20 20 20 20 20 20 20 20 20 28 6c 70 20 6e 32 20 (lp n2
7ba0: 28 2b 20 69 20 31 29 29 29 29 0a 20 20 20 20 20 (+ i 1)))).
7bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 (e
7bc0: 6c 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 lse.
7bd0: 20 20 20 20 20 20 20 20 28 6f 75 74 70 75 74 20 (output
7be0: 71 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 q).
7bf0: 20 20 20 20 20 20 20 28 6c 70 20 28 2a 20 28 72 (lp (* (r
7c00: 65 6d 61 69 6e 64 65 72 20 6e 20 64 29 20 62 61 emainder n d) ba
7c10: 73 65 29 20 28 2b 20 69 20 31 29 29 29 29 29 29 se) (+ i 1))))))
7c20: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7c30: 28 65 6c 73 65 0a 20 20 20 20 20 20 20 20 20 20 (else.
7c40: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 71 20 (let* ((q
7c50: 28 71 75 6f 74 69 65 6e 74 20 6e 20 64 29 29 0a (quotient n d)).
7c60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7c70: 20 20 20 20 20 20 20 28 64 69 67 69 74 0a 20 20 (digit.
7c80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7c90: 20 20 20 20 20 20 28 2a 20 32 20 28 69 66 20 28 (* 2 (if (
7ca0: 3e 3d 20 71 20 62 61 73 65 29 20 28 71 75 6f 74 >= q base) (quot
7cb0: 69 65 6e 74 20 71 20 28 67 65 74 2d 73 63 61 6c ient q (get-scal
7cc0: 65 20 71 29 29 20 71 29 29 29 29 0a 20 20 20 20 e q)) q)))).
7cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
7ce0: 66 20 28 6f 72 20 28 3e 20 64 69 67 69 74 20 62 f (or (> digit b
7cf0: 61 73 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 ase).
7d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
7d10: 61 6e 64 20 28 3d 20 64 69 67 69 74 20 62 61 73 and (= digit bas
7d20: 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e).
7d30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d40: 20 20 28 6c 65 74 20 28 28 70 72 65 76 20 28 66 (let ((prev (f
7d50: 69 6e 64 20 69 6e 74 65 67 65 72 3f 20 73 74 61 ind integer? sta
7d60: 63 6b 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 ck))).
7d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d80: 20 20 20 20 20 20 20 28 61 6e 64 20 70 72 65 76 (and prev
7d90: 20 28 6f 64 64 3f 20 70 72 65 76 29 29 29 29 29 (odd? prev)))))
7da0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7db0: 20 20 20 20 20 20 20 28 66 6c 75 73 68 2f 72 6f (flush/ro
7dc0: 75 6e 64 65 64 29 0a 20 20 20 20 20 20 20 20 20 unded).
7dd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 6c (fl
7de0: 75 73 68 29 29 29 29 29 29 29 29 0a 0a 20 20 20 ush))))))))..
7df0: 20 20 20 20 20 28 64 65 66 69 6e 65 20 28 77 72 (define (wr
7e00: 61 70 2d 73 69 67 6e 20 6e 20 73 69 67 6e 3f 20 ap-sign n sign?
7e10: 61 6c 69 67 6e 20 77 72 69 74 65 72 29 0a 20 20 align writer).
7e20: 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 (cond.
7e30: 20 20 20 20 20 20 20 20 20 28 28 6e 65 67 61 74 ((negat
7e40: 69 76 65 3f 20 6e 29 0a 20 20 20 20 20 20 20 20 ive? n).
7e50: 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 (cond.
7e60: 20 20 20 20 20 20 20 28 28 63 68 61 72 3f 20 73 ((char? s
7e70: 69 67 6e 3f 29 0a 20 20 20 20 20 20 20 20 20 20 ign?).
7e80: 20 20 20 20 28 77 72 69 74 65 72 20 28 61 62 73 (writer (abs
7e90: 20 6e 29 20 73 69 67 6e 3f 20 61 6c 69 67 6e 29 n) sign? align)
7ea0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
7eb0: 64 69 73 70 6c 61 79 20 28 6d 69 72 72 6f 72 2d display (mirror-
7ec0: 6f 66 20 73 69 67 6e 3f 29 20 70 6f 72 74 29 29 of sign?) port))
7ed0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 . (e
7ee0: 6c 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 lse.
7ef0: 20 20 28 77 72 69 74 65 72 20 28 61 62 73 20 6e (writer (abs n
7f00: 29 20 23 5c 2d 20 61 6c 69 67 6e 29 29 29 29 0a ) #\- align)))).
7f10: 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 (else
7f20: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f . (co
7f30: 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 nd.
7f40: 28 28 61 6e 64 20 73 69 67 6e 3f 20 28 6e 6f 74 ((and sign? (not
7f50: 20 28 63 68 61 72 3f 20 73 69 67 6e 3f 29 29 29 (char? sign?)))
7f60: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
7f70: 77 72 69 74 65 72 20 6e 20 23 5c 2b 20 61 6c 69 writer n #\+ ali
7f80: 67 6e 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 gn)).
7f90: 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 20 20 (else.
7fa0: 20 20 20 20 20 20 28 77 72 69 74 65 72 20 6e 20 (writer n
7fb0: 23 66 20 61 6c 69 67 6e 29 29 29 29 29 29 0a 0a #f align))))))..
7fc0: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 69 (let ((i
7fd0: 6d 61 67 20 28 69 6d 61 67 2d 70 61 72 74 20 6e mag (imag-part n
7fe0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 63 ))). (c
7ff0: 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 28 ond. (
8000: 28 61 6e 64 20 62 61 73 65 20 28 6e 6f 74 20 28 (and base (not (
8010: 61 6e 64 20 28 69 6e 74 65 67 65 72 3f 20 62 61 and (integer? ba
8020: 73 65 29 20 28 3c 3d 20 32 20 62 61 73 65 20 33 se) (<= 2 base 3
8030: 36 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 6)))).
8040: 20 20 28 65 72 72 6f 72 20 22 69 6e 76 61 6c 69 (error "invali
8050: 64 20 62 61 73 65 20 66 6f 72 20 6e 75 6d 65 72 d base for numer
8060: 69 63 20 66 6f 72 6d 61 74 74 69 6e 67 22 20 62 ic formatting" b
8070: 61 73 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 ase)).
8080: 20 28 28 7a 65 72 6f 3f 20 69 6d 61 67 29 0a 20 ((zero? imag).
8090: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 (cond
80a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 . ((
80b0: 61 6e 64 20 28 65 78 61 63 74 3f 20 6e 29 20 28 and (exact? n) (
80c0: 6e 6f 74 20 28 69 6e 74 65 67 65 72 3f 20 6e 29 not (integer? n)
80d0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
80e0: 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 (cond.
80f0: 20 20 20 20 20 20 28 64 69 67 69 74 73 0a 20 20 (digits.
8100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 77 (w
8110: 72 61 70 2d 73 69 67 6e 20 6e 20 73 69 67 6e 3f rap-sign n sign?
8120: 20 61 6c 69 67 6e 20 77 72 69 74 65 2d 66 69 78 align write-fix
8130: 65 64 2d 72 61 74 69 6f 6e 61 6c 29 29 0a 20 20 ed-rational)).
8140: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c (el
8150: 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 se.
8160: 20 20 20 28 77 72 61 70 2d 73 69 67 6e 20 28 6e (wrap-sign (n
8170: 75 6d 65 72 61 74 6f 72 20 6e 29 20 73 69 67 6e umerator n) sign
8180: 3f 20 23 66 20 77 72 69 74 65 2d 72 65 61 6c 29 ? #f write-real)
8190: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
81a0: 20 28 77 72 69 74 65 2d 63 68 61 72 20 23 5c 2f (write-char #\/
81b0: 20 70 6f 72 74 29 0a 20 20 20 20 20 20 20 20 20 port).
81c0: 20 20 20 20 20 20 20 28 77 72 61 70 2d 73 69 67 (wrap-sig
81d0: 6e 20 28 64 65 6e 6f 6d 69 6e 61 74 6f 72 20 6e n (denominator n
81e0: 29 20 23 66 20 23 66 20 77 72 69 74 65 2d 72 65 ) #f #f write-re
81f0: 61 6c 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 al)))).
8200: 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 (else.
8210: 20 20 20 20 20 20 20 20 28 77 72 61 70 2d 73 69 (wrap-si
8220: 67 6e 20 6e 20 73 69 67 6e 3f 20 61 6c 69 67 6e gn n sign? align
8230: 20 77 72 69 74 65 2d 72 65 61 6c 29 29 29 29 0a write-real)))).
8240: 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 (else
8250: 20 28 77 72 61 70 2d 73 69 67 6e 20 28 72 65 61 (wrap-sign (rea
8260: 6c 2d 70 61 72 74 20 6e 29 20 73 69 67 6e 3f 20 l-part n) sign?
8270: 23 66 20 77 72 69 74 65 2d 72 65 61 6c 29 0a 20 #f write-real).
8280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8290: 28 77 72 61 70 2d 73 69 67 6e 20 69 6d 61 67 20 (wrap-sign imag
82a0: 23 74 20 23 66 20 77 72 69 74 65 2d 72 65 61 6c #t #f write-real
82b0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
82c0: 20 20 20 28 77 72 69 74 65 2d 63 68 61 72 20 23 (write-char #
82d0: 5c 69 20 70 6f 72 74 29 29 29 29 29 29 29 29 0a \i port)))))))).
82e0: 0a 28 64 65 66 69 6e 65 20 28 6e 75 6d 20 6e 20 .(define (num n
82f0: 2e 20 6f 70 74 29 0a 20 20 28 6c 61 6d 62 64 61 . opt). (lambda
8300: 20 28 73 74 29 20 28 28 66 6d 74 2d 77 72 69 74 (st) ((fmt-writ
8310: 65 72 20 73 74 29 20 28 61 70 70 6c 79 20 6e 75 er st) (apply nu
8320: 6d 2d 3e 73 74 72 69 6e 67 20 6e 20 73 74 20 6f m->string n st o
8330: 70 74 29 20 73 74 29 29 29 0a 0a 28 64 65 66 69 pt) st)))..(defi
8340: 6e 65 20 28 6e 75 6d 2f 63 6f 6d 6d 61 20 6e 20 ne (num/comma n
8350: 2e 20 6f 29 0a 20 20 28 6c 61 6d 62 64 61 20 28 . o). (lambda (
8360: 73 74 29 0a 20 20 20 20 28 6c 65 74 2d 6f 70 74 st). (let-opt
8370: 69 6f 6e 61 6c 73 2a 20 6f 0a 20 20 20 20 20 20 ionals* o.
8380: 20 20 28 28 62 61 73 65 20 28 66 6d 74 2d 72 61 ((base (fmt-ra
8390: 64 69 78 20 73 74 29 29 0a 20 20 20 20 20 20 20 dix st)).
83a0: 20 20 28 64 69 67 69 74 73 20 28 66 6d 74 2d 70 (digits (fmt-p
83b0: 72 65 63 69 73 69 6f 6e 20 73 74 29 29 0a 20 20 recision st)).
83c0: 20 20 20 20 20 20 20 28 73 69 67 6e 3f 20 23 66 (sign? #f
83d0: 29 0a 20 20 20 20 20 20 20 20 20 28 63 6f 6d 6d ). (comm
83e0: 61 2d 72 75 6c 65 20 33 29 0a 20 20 20 20 20 20 a-rule 3).
83f0: 20 20 20 28 63 6f 6d 6d 61 2d 73 65 70 20 28 66 (comma-sep (f
8400: 6d 74 2d 72 65 66 20 73 74 20 27 63 6f 6d 6d 61 mt-ref st 'comma
8410: 2d 63 68 61 72 20 23 5c 2c 29 29 0a 20 20 20 20 -char #\,)).
8420: 20 20 20 20 20 28 64 65 63 69 6d 61 6c 2d 73 65 (decimal-se
8430: 70 20 28 6f 72 20 28 66 6d 74 2d 64 65 63 69 6d p (or (fmt-decim
8440: 61 6c 2d 73 65 70 20 73 74 29 0a 20 20 20 20 20 al-sep st).
8450: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8460: 20 20 20 20 20 28 69 66 20 28 65 71 76 3f 20 63 (if (eqv? c
8470: 6f 6d 6d 61 2d 73 65 70 20 23 5c 2e 29 20 23 5c omma-sep #\.) #\
8480: 2c 20 23 5c 2e 29 29 29 29 0a 20 20 20 20 20 20 , #\.)))).
8490: 28 28 6e 75 6d 20 6e 20 62 61 73 65 20 64 69 67 ((num n base dig
84a0: 69 74 73 20 73 69 67 6e 3f 20 63 6f 6d 6d 61 2d its sign? comma-
84b0: 72 75 6c 65 20 63 6f 6d 6d 61 2d 73 65 70 20 64 rule comma-sep d
84c0: 65 63 69 6d 61 6c 2d 73 65 70 29 20 73 74 29 29 ecimal-sep) st))
84d0: 29 29 0a 0a 3b 3b 20 53 49 20 73 75 66 66 69 78 ))..;; SI suffix
84e0: 20 66 6f 72 6d 61 74 74 69 6e 67 2c 20 61 73 20 formatting, as
84f0: 75 73 65 64 20 69 6e 20 2d 2d 68 75 6d 61 6e 2d used in --human-
8500: 72 65 61 64 61 62 6c 65 20 6f 70 74 69 6f 6e 73 readable options
8510: 20 74 6f 20 73 6f 6d 65 0a 3b 3b 20 47 4e 55 20 to some.;; GNU
8520: 63 6f 6d 6d 61 6e 64 73 20 28 73 75 63 68 20 61 commands (such a
8530: 73 20 6c 73 29 2e 20 20 53 65 65 0a 3b 3b 0a 3b s ls). See.;;.;
8540: 3b 20 20 20 68 74 74 70 3a 2f 2f 77 77 77 2e 62 ; http://www.b
8550: 69 70 6d 2e 6f 72 67 2f 65 6e 2f 73 69 2f 73 69 ipm.org/en/si/si
8560: 5f 62 72 6f 63 68 75 72 65 2f 63 68 61 70 74 65 _brochure/chapte
8570: 72 33 2f 70 72 65 66 69 78 65 73 2e 68 74 6d 6c r3/prefixes.html
8580: 0a 3b 3b 20 20 20 68 74 74 70 3a 2f 2f 70 68 79 .;; http://phy
8590: 73 69 63 73 2e 6e 69 73 74 2e 67 6f 76 2f 63 75 sics.nist.gov/cu
85a0: 75 2f 55 6e 69 74 73 2f 62 69 6e 61 72 79 2e 68 u/Units/binary.h
85b0: 74 6d 6c 0a 3b 3b 0a 3b 3b 20 4e 6f 74 65 3a 20 tml.;;.;; Note:
85c0: 6c 6f 77 65 72 63 61 73 65 20 22 6b 22 20 66 6f lowercase "k" fo
85d0: 72 20 62 61 73 65 20 31 30 2c 20 75 70 70 65 72 r base 10, upper
85e0: 63 61 73 65 20 22 4b 22 20 66 6f 72 20 62 61 73 case "K" for bas
85f0: 65 20 32 0a 0a 28 64 65 66 69 6e 65 20 6e 75 6d e 2..(define num
8600: 2f 73 69 0a 20 20 28 6c 65 74 2a 20 28 28 6e 61 /si. (let* ((na
8610: 6d 65 73 31 30 20 27 23 28 22 22 20 22 6b 22 20 mes10 '#("" "k"
8620: 22 4d 22 20 22 47 22 20 22 54 22 20 22 45 22 20 "M" "G" "T" "E"
8630: 22 50 22 20 22 5a 22 20 22 59 22 29 29 0a 20 20 "P" "Z" "Y")).
8640: 20 20 20 20 20 20 20 28 6e 61 6d 65 73 32 20 28 (names2 (
8650: 6c 69 73 74 2d 3e 76 65 63 74 6f 72 0a 20 20 20 list->vector.
8660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
8670: 63 6f 6e 73 20 22 22 0a 20 20 20 20 20 20 20 20 cons "".
8680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8690: 28 63 6f 6e 73 20 22 4b 69 22 20 28 6d 61 70 20 (cons "Ki" (map
86a0: 28 6c 61 6d 62 64 61 20 28 73 29 20 28 73 74 72 (lambda (s) (str
86b0: 69 6e 67 2d 61 70 70 65 6e 64 20 73 20 22 69 22 ing-append s "i"
86c0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
86d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
86e0: 20 20 20 20 20 20 20 20 20 20 20 28 63 64 64 72 (cddr
86f0: 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 6e (vector->list n
8700: 61 6d 65 73 31 30 29 29 29 29 29 29 29 29 0a 20 ames10)))))))).
8710: 20 20 20 28 6c 61 6d 62 64 61 20 28 6e 20 2e 20 (lambda (n .
8720: 6f 29 0a 20 20 20 20 20 20 28 6c 65 74 2d 6f 70 o). (let-op
8730: 74 69 6f 6e 61 6c 73 2a 20 6f 20 28 28 62 61 73 tionals* o ((bas
8740: 65 20 31 30 32 34 29 0a 20 20 20 20 20 20 20 20 e 1024).
8750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8760: 20 28 73 75 66 66 69 78 20 22 22 29 0a 20 20 20 (suffix "").
8770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8780: 20 20 20 20 20 20 28 6e 61 6d 65 73 20 28 69 66 (names (if
8790: 20 28 3d 20 62 61 73 65 20 31 30 32 34 29 20 6e (= base 1024) n
87a0: 61 6d 65 73 32 20 6e 61 6d 65 73 31 30 29 29 29 ames2 names10)))
87b0: 0a 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 . (let* (
87c0: 28 6b 20 28 6d 69 6e 20 28 69 6e 65 78 61 63 74 (k (min (inexact
87d0: 2d 3e 65 78 61 63 74 20 28 66 6c 6f 6f 72 20 28 ->exact (floor (
87e0: 2f 20 28 6c 6f 67 20 6e 29 20 28 6c 6f 67 20 62 / (log n) (log b
87f0: 61 73 65 29 29 29 29 0a 20 20 20 20 20 20 20 20 ase)))).
8800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
8810: 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 6e 61 vector-length na
8820: 6d 65 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 mes))).
8830: 20 20 20 20 20 20 28 6e 32 20 28 2f 20 28 72 6f (n2 (/ (ro
8840: 75 6e 64 20 28 2a 20 28 2f 20 6e 20 28 65 78 70 und (* (/ n (exp
8850: 74 20 62 61 73 65 20 6b 29 29 20 31 30 29 29 20 t base k)) 10))
8860: 31 30 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 10))).
8870: 28 63 61 74 20 28 69 66 20 28 69 6e 74 65 67 65 (cat (if (intege
8880: 72 3f 20 6e 32 29 0a 20 20 20 20 20 20 20 20 20 r? n2).
8890: 20 20 20 20 20 20 20 20 20 20 28 6e 75 6d 62 65 (numbe
88a0: 72 2d 3e 73 74 72 69 6e 67 20 28 69 6e 65 78 61 r->string (inexa
88b0: 63 74 2d 3e 65 78 61 63 74 20 6e 32 29 29 0a 20 ct->exact n2)).
88c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
88d0: 20 20 28 65 78 61 63 74 2d 3e 69 6e 65 78 61 63 (exact->inexac
88e0: 74 20 6e 32 29 29 0a 20 20 20 20 20 20 20 20 20 t n2)).
88f0: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 (vector-re
8900: 66 20 6e 61 6d 65 73 20 6b 29 0a 20 20 20 20 20 f names k).
8910: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 7a (if (z
8920: 65 72 6f 3f 20 6b 29 20 22 22 20 73 75 66 66 69 ero? k) "" suffi
8930: 78 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e x)))))))..(defin
8940: 65 20 72 6f 6d 61 6e 2d 6e 75 6d 65 72 61 6c 73 e roman-numerals
8950: 0a 20 20 27 28 28 31 30 30 30 20 2e 20 23 5c 4d . '((1000 . #\M
8960: 29 20 28 35 30 30 20 2e 20 23 5c 44 29 20 28 31 ) (500 . #\D) (1
8970: 30 30 20 2e 20 23 5c 43 29 0a 20 20 20 20 28 35 00 . #\C). (5
8980: 30 20 2e 20 23 5c 4c 29 20 28 31 30 20 2e 20 23 0 . #\L) (10 . #
8990: 5c 58 29 20 28 35 20 2e 20 23 5c 56 29 20 28 31 \X) (5 . #\V) (1
89a0: 20 2e 20 23 5c 49 29 29 29 0a 0a 28 64 65 66 69 . #\I)))..(defi
89b0: 6e 65 20 28 6e 75 6d 2f 6f 6c 64 2d 72 6f 6d 61 ne (num/old-roma
89c0: 6e 20 6e 75 6d 29 0a 20 20 28 6c 61 6d 62 64 61 n num). (lambda
89d0: 20 28 73 74 29 0a 20 20 20 20 28 6c 65 74 20 6c (st). (let l
89e0: 70 20 28 28 6e 75 6d 20 6e 75 6d 29 20 28 72 65 p ((num num) (re
89f0: 73 20 27 28 29 29 29 0a 20 20 20 20 20 20 28 69 s '())). (i
8a00: 66 20 28 70 6f 73 69 74 69 76 65 3f 20 6e 75 6d f (positive? num
8a10: 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 ). (let
8a20: 20 28 28 63 68 20 28 66 69 6e 64 20 28 6c 61 6d ((ch (find (lam
8a30: 62 64 61 20 28 78 29 20 28 3e 3d 20 6e 75 6d 20 bda (x) (>= num
8a40: 28 63 61 72 20 78 29 29 29 20 72 6f 6d 61 6e 2d (car x))) roman-
8a50: 6e 75 6d 65 72 61 6c 73 29 29 29 0a 20 20 20 20 numerals))).
8a60: 20 20 20 20 20 20 20 20 28 6c 70 20 28 2d 20 6e (lp (- n
8a70: 75 6d 20 28 63 61 72 20 63 68 29 29 20 28 63 6f um (car ch)) (co
8a80: 6e 73 20 28 63 64 72 20 63 68 29 20 72 65 73 29 ns (cdr ch) res)
8a90: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 66 6d )). (fm
8aa0: 74 2d 77 72 69 74 65 20 28 72 65 76 65 72 73 65 t-write (reverse
8ab0: 2d 6c 69 73 74 2d 3e 73 74 72 69 6e 67 20 72 65 -list->string re
8ac0: 73 29 20 73 74 29 29 29 29 29 0a 0a 28 64 65 66 s) st)))))..(def
8ad0: 69 6e 65 20 28 6e 75 6d 2f 72 6f 6d 61 6e 20 6e ine (num/roman n
8ae0: 75 6d 29 0a 20 20 28 6c 61 6d 62 64 61 20 28 73 um). (lambda (s
8af0: 74 29 0a 20 20 20 20 28 6c 65 74 20 6c 70 31 20 t). (let lp1
8b00: 28 28 6e 75 6d 20 6e 75 6d 29 20 28 72 65 73 20 ((num num) (res
8b10: 27 28 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 '())). (if
8b20: 28 70 6f 73 69 74 69 76 65 3f 20 6e 75 6d 29 0a (positive? num).
8b30: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 6c (let l
8b40: 70 32 20 28 28 6c 73 20 72 6f 6d 61 6e 2d 6e 75 p2 ((ls roman-nu
8b50: 6d 65 72 61 6c 73 29 29 0a 20 20 20 20 20 20 20 merals)).
8b60: 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 (let* ((
8b70: 62 69 67 20 28 63 61 72 20 6c 73 29 29 0a 20 20 big (car ls)).
8b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8b90: 20 20 20 20 28 62 69 67 2d 6e 20 28 63 61 72 20 (big-n (car
8ba0: 62 69 67 29 29 29 0a 20 20 20 20 20 20 20 20 20 big))).
8bb0: 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 (cond.
8bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8bd0: 28 28 3e 3d 20 6e 75 6d 20 62 69 67 2d 6e 29 0a ((>= num big-n).
8be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8bf0: 20 20 20 28 6c 70 31 20 28 2d 20 6e 75 6d 20 62 (lp1 (- num b
8c00: 69 67 2d 6e 29 20 28 63 6f 6e 73 20 28 63 64 72 ig-n) (cons (cdr
8c10: 20 62 69 67 29 20 72 65 73 29 29 29 0a 20 20 20 big) res))).
8c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
8c30: 28 61 6e 64 20 28 3e 20 28 2a 20 32 20 6e 75 6d (and (> (* 2 num
8c40: 29 20 62 69 67 2d 6e 29 0a 20 20 20 20 20 20 20 ) big-n).
8c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8c60: 20 28 66 69 6e 64 20 28 6c 61 6d 62 64 61 20 28 (find (lambda (
8c70: 63 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 c).
8c80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8c90: 20 20 20 28 6c 65 74 20 28 28 78 20 28 63 61 72 (let ((x (car
8ca0: 20 63 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 c))).
8cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8cc0: 20 20 20 20 20 20 20 20 28 3c 3d 20 28 2b 20 78 (<= (+ x
8cd0: 20 31 29 20 28 2d 20 62 69 67 2d 6e 20 78 29 20 1) (- big-n x)
8ce0: 6e 75 6d 29 29 29 0a 20 20 20 20 20 20 20 20 20 num))).
8cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8d00: 20 20 20 20 20 6c 73 29 29 0a 20 20 20 20 20 20 ls)).
8d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 3d 3e 20 =>
8d20: 28 6c 61 6d 62 64 61 20 28 63 29 0a 20 20 20 20 (lambda (c).
8d30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8d40: 20 20 20 20 28 6c 70 31 20 28 2d 20 6e 75 6d 20 (lp1 (- num
8d50: 28 2d 20 62 69 67 2d 6e 20 28 63 61 72 20 63 29 (- big-n (car c)
8d60: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
8d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8d80: 28 63 6f 6e 73 20 28 63 64 72 20 62 69 67 29 20 (cons (cdr big)
8d90: 28 63 6f 6e 73 20 28 63 64 72 20 63 29 20 72 65 (cons (cdr c) re
8da0: 73 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 s))))).
8db0: 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 0a 20 (else.
8dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8dd0: 20 20 28 6c 70 32 20 28 63 64 72 20 6c 73 29 29 (lp2 (cdr ls))
8de0: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 )))). (
8df0: 66 6d 74 2d 77 72 69 74 65 20 28 72 65 76 65 72 fmt-write (rever
8e00: 73 65 2d 6c 69 73 74 2d 3e 73 74 72 69 6e 67 20 se-list->string
8e10: 72 65 73 29 20 73 74 29 29 29 29 29 0a 0a 3b 3b res) st)))))..;;
8e20: 20 46 6f 72 63 65 20 61 20 6e 75 6d 62 65 72 20 Force a number
8e30: 69 6e 74 6f 20 61 20 66 69 78 65 64 20 77 69 64 into a fixed wid
8e40: 74 68 2c 20 70 72 69 6e 74 20 61 73 20 23 27 73 th, print as #'s
8e50: 20 69 66 20 64 6f 65 73 6e 27 74 20 66 69 74 2e if doesn't fit.
8e60: 0a 3b 3b 20 4e 65 65 64 73 20 74 6f 20 62 65 20 .;; Needs to be
8e70: 77 72 61 70 70 65 64 20 69 6e 20 61 20 50 41 44 wrapped in a PAD
8e80: 20 69 66 20 79 6f 75 20 77 61 6e 74 20 74 6f 20 if you want to
8e90: 65 78 70 61 6e 64 20 74 6f 20 74 68 65 20 77 69 expand to the wi
8ea0: 64 74 68 2e 0a 0a 28 64 65 66 69 6e 65 20 28 6e dth...(define (n
8eb0: 75 6d 2f 66 69 74 20 77 69 64 74 68 20 6e 20 2e um/fit width n .
8ec0: 20 61 72 67 73 29 0a 20 20 28 66 6d 74 2d 63 61 args). (fmt-ca
8ed0: 70 74 75 72 65 0a 20 20 20 28 61 70 70 6c 79 20 pture. (apply
8ee0: 6e 75 6d 20 6e 20 61 72 67 73 29 0a 20 20 20 28 num n args). (
8ef0: 6c 61 6d 62 64 61 20 28 73 74 72 29 0a 20 20 20 lambda (str).
8f00: 20 20 28 6c 61 6d 62 64 61 20 28 73 74 29 0a 20 (lambda (st).
8f10: 20 20 20 20 20 20 28 69 66 20 28 3e 20 28 73 74 (if (> (st
8f20: 72 69 6e 67 2d 6c 65 6e 67 74 68 20 73 74 72 29 ring-length str)
8f30: 20 77 69 64 74 68 29 0a 20 20 20 20 20 20 20 20 width).
8f40: 20 20 20 28 6c 65 74 20 28 28 70 72 65 63 20 28 (let ((prec (
8f50: 69 66 20 28 61 6e 64 20 28 70 61 69 72 3f 20 61 if (and (pair? a
8f60: 72 67 73 29 20 28 70 61 69 72 3f 20 28 63 64 72 rgs) (pair? (cdr
8f70: 20 61 72 67 73 29 29 29 0a 20 20 20 20 20 20 20 args))).
8f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8f90: 20 20 20 20 28 63 61 64 72 20 61 72 67 73 29 0a (cadr args).
8fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8fb0: 20 20 20 20 20 20 20 20 20 20 20 28 66 6d 74 2d (fmt-
8fc0: 70 72 65 63 69 73 69 6f 6e 20 73 74 29 29 29 29 precision st))))
8fd0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 . (i
8fe0: 66 20 70 72 65 63 0a 20 20 20 20 20 20 20 20 20 f prec.
8ff0: 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 (let* ((
9000: 64 65 63 69 6d 61 6c 2d 73 65 70 0a 20 20 20 20 decimal-sep.
9010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9020: 20 20 20 20 20 28 6f 72 20 28 66 6d 74 2d 72 65 (or (fmt-re
9030: 66 20 73 74 20 27 64 65 63 69 6d 61 6c 2d 73 65 f st 'decimal-se
9040: 70 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 p).
9050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9060: 28 69 66 20 28 65 71 76 3f 20 23 5c 2e 20 28 66 (if (eqv? #\. (f
9070: 6d 74 2d 72 65 66 20 73 74 20 27 63 6f 6d 6d 61 mt-ref st 'comma
9080: 2d 73 65 70 29 29 20 23 5c 2c 20 23 5c 2e 29 29 -sep)) #\, #\.))
9090: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
90a0: 20 20 20 20 20 20 20 20 20 20 28 64 69 66 66 20 (diff
90b0: 28 2d 20 77 69 64 74 68 20 28 2b 20 70 72 65 63 (- width (+ prec
90c0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
90d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
90e0: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
90f0: 63 68 61 72 3f 20 64 65 63 69 6d 61 6c 2d 73 65 char? decimal-se
9100: 70 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 p).
9110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9130: 20 31 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 1.
9140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9160: 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 (string-length
9170: 64 65 63 69 6d 61 6c 2d 73 65 70 29 29 29 29 29 decimal-sep)))))
9180: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
9190: 20 20 20 20 20 28 28 63 61 74 20 28 69 66 20 28 ((cat (if (
91a0: 70 6f 73 69 74 69 76 65 3f 20 64 69 66 66 29 20 positive? diff)
91b0: 28 6d 61 6b 65 2d 73 74 72 69 6e 67 20 64 69 66 (make-string dif
91c0: 66 20 23 5c 23 29 20 22 22 29 0a 20 20 20 20 20 f #\#) "").
91d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
91e0: 20 20 20 20 64 65 63 69 6d 61 6c 2d 73 65 70 20 decimal-sep
91f0: 28 6d 61 6b 65 2d 73 74 72 69 6e 67 20 70 72 65 (make-string pre
9200: 63 20 23 5c 23 29 29 0a 20 20 20 20 20 20 20 20 c #\#)).
9210: 20 20 20 20 20 20 20 20 20 20 20 20 73 74 29 29 st))
9220: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
9230: 20 20 28 28 66 6d 74 2d 77 72 69 74 65 72 20 73 ((fmt-writer s
9240: 74 29 20 28 6d 61 6b 65 2d 73 74 72 69 6e 67 20 t) (make-string
9250: 77 69 64 74 68 20 23 5c 23 29 20 73 74 29 29 29 width #\#) st)))
9260: 0a 20 20 20 20 20 20 20 20 20 20 20 28 28 66 6d . ((fm
9270: 74 2d 77 72 69 74 65 72 20 73 74 29 20 73 74 72 t-writer st) str
9280: 20 73 74 29 29 29 29 29 29 0a 0a 3b 3b 3b 3b 3b st))))))..;;;;;
9290: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
92a0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
92b0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
92c0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
92d0: 3b 3b 3b 0a 3b 3b 3b 20 73 68 61 72 65 64 20 73 ;;;.;;; shared s
92e0: 74 72 75 63 74 75 72 65 20 75 74 69 6c 69 74 69 tructure utiliti
92f0: 65 73 0a 0a 28 64 65 66 69 6e 65 20 28 65 71 3f es..(define (eq?
9300: 2d 74 61 62 6c 65 2d 72 65 66 20 74 61 62 20 78 -table-ref tab x
9310: 29 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 ) (hash-table-re
9320: 66 2f 64 65 66 61 75 6c 74 20 74 61 62 20 78 20 f/default tab x
9330: 23 66 29 29 0a 28 64 65 66 69 6e 65 20 28 65 71 #f)).(define (eq
9340: 3f 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 61 62 ?-table-set! tab
9350: 20 78 20 76 29 20 28 68 61 73 68 2d 74 61 62 6c x v) (hash-tabl
9360: 65 2d 73 65 74 21 20 74 61 62 20 78 20 76 29 29 e-set! tab x v))
9370: 0a 0a 3b 3b 20 58 58 58 58 20 65 78 74 65 6e 64 ..;; XXXX extend
9380: 20 66 6f 72 20 72 65 63 6f 72 64 73 20 61 6e 64 for records and
9390: 20 6f 74 68 65 72 20 63 6f 6e 74 61 69 6e 65 72 other container
93a0: 20 64 61 74 61 20 74 79 70 65 73 0a 28 64 65 66 data types.(def
93b0: 69 6e 65 20 28 6d 61 6b 65 2d 73 68 61 72 65 64 ine (make-shared
93c0: 2d 72 65 66 2d 74 61 62 6c 65 20 6f 62 6a 29 0a -ref-table obj).
93d0: 20 20 28 6c 65 74 20 28 28 74 61 62 20 28 6d 61 (let ((tab (ma
93e0: 6b 65 2d 65 71 3f 2d 74 61 62 6c 65 29 29 0a 20 ke-eq?-table)).
93f0: 20 20 20 20 20 20 20 28 72 65 73 20 28 6d 61 6b (res (mak
9400: 65 2d 65 71 3f 2d 74 61 62 6c 65 29 29 0a 20 20 e-eq?-table)).
9410: 20 20 20 20 20 20 28 69 6e 64 65 78 20 30 29 29 (index 0))
9420: 0a 20 20 20 20 28 6c 65 74 20 77 61 6c 6b 20 28 . (let walk (
9430: 28 6f 62 6a 20 6f 62 6a 29 29 0a 20 20 20 20 20 (obj obj)).
9440: 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 28 (cond. (
9450: 28 65 71 3f 2d 74 61 62 6c 65 2d 72 65 66 20 74 (eq?-table-ref t
9460: 61 62 20 6f 62 6a 29 0a 20 20 20 20 20 20 20 20 ab obj).
9470: 20 3d 3e 20 28 6c 61 6d 62 64 61 20 28 69 29 20 => (lambda (i)
9480: 28 65 71 3f 2d 74 61 62 6c 65 2d 73 65 74 21 20 (eq?-table-set!
9490: 74 61 62 20 6f 62 6a 20 28 2b 20 69 20 31 29 29 tab obj (+ i 1))
94a0: 29 29 0a 20 20 20 20 20 20 20 20 28 28 6e 6f 74 )). ((not
94b0: 20 28 6f 72 20 28 73 79 6d 62 6f 6c 3f 20 6f 62 (or (symbol? ob
94c0: 6a 29 20 28 6e 75 6d 62 65 72 3f 20 6f 62 6a 29 j) (number? obj)
94d0: 20 28 63 68 61 72 3f 20 6f 62 6a 29 0a 20 20 20 (char? obj).
94e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
94f0: 62 6f 6f 6c 65 61 6e 3f 20 6f 62 6a 29 20 28 6e boolean? obj) (n
9500: 75 6c 6c 3f 20 6f 62 6a 29 20 28 65 6f 66 2d 6f ull? obj) (eof-o
9510: 62 6a 65 63 74 3f 20 6f 62 6a 29 29 29 0a 20 20 bject? obj))).
9520: 20 20 20 20 20 20 20 28 65 71 3f 2d 74 61 62 6c (eq?-tabl
9530: 65 2d 73 65 74 21 20 74 61 62 20 6f 62 6a 20 31 e-set! tab obj 1
9540: 29 0a 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 ). (cond
9550: 0a 20 20 20 20 20 20 20 20 20 20 20 28 28 70 61 . ((pa
9560: 69 72 3f 20 6f 62 6a 29 0a 20 20 20 20 20 20 20 ir? obj).
9570: 20 20 20 20 20 28 77 61 6c 6b 20 28 63 61 72 20 (walk (car
9580: 6f 62 6a 29 29 0a 20 20 20 20 20 20 20 20 20 20 obj)).
9590: 20 20 28 77 61 6c 6b 20 28 63 64 72 20 6f 62 6a (walk (cdr obj
95a0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 ))). (
95b0: 28 76 65 63 74 6f 72 3f 20 6f 62 6a 29 0a 20 20 (vector? obj).
95c0: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let (
95d0: 28 6c 65 6e 20 28 76 65 63 74 6f 72 2d 6c 65 6e (len (vector-len
95e0: 67 74 68 20 6f 62 6a 29 29 29 0a 20 20 20 20 20 gth obj))).
95f0: 20 20 20 20 20 20 20 20 20 28 64 6f 20 28 28 69 (do ((i
9600: 20 30 20 28 2b 20 69 20 31 29 29 29 20 28 28 3e 0 (+ i 1))) ((>
9610: 3d 20 69 20 6c 65 6e 29 29 0a 20 20 20 20 20 20 = i len)).
9620: 20 20 20 20 20 20 20 20 20 20 28 77 61 6c 6b 20 (walk
9630: 28 76 65 63 74 6f 72 2d 72 65 66 20 6f 62 6a 20 (vector-ref obj
9640: 69 29 29 29 29 29 29 29 29 29 0a 20 20 20 20 28 i))))))))). (
9650: 68 61 73 68 2d 74 61 62 6c 65 2d 77 61 6c 6b 0a hash-table-walk.
9660: 20 20 20 20 20 74 61 62 0a 20 20 20 20 20 28 6c tab. (l
9670: 61 6d 62 64 61 20 28 6f 62 6a 20 63 6f 75 6e 74 ambda (obj count
9680: 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 3e 20 ). (if (>
9690: 63 6f 75 6e 74 20 31 29 0a 20 20 20 20 20 20 20 count 1).
96a0: 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 (begin.
96b0: 20 20 20 20 20 20 20 20 28 65 71 3f 2d 74 61 62 (eq?-tab
96c0: 6c 65 2d 73 65 74 21 20 72 65 73 20 6f 62 6a 20 le-set! res obj
96d0: 28 63 6f 6e 73 20 69 6e 64 65 78 20 23 66 29 29 (cons index #f))
96e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 . (s
96f0: 65 74 21 20 69 6e 64 65 78 20 28 2b 20 69 6e 64 et! index (+ ind
9700: 65 78 20 31 29 29 29 29 29 29 0a 20 20 20 20 72 ex 1)))))). r
9710: 65 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 es))..(define (g
9720: 65 6e 2d 73 68 61 72 65 64 2d 72 65 66 20 69 20 en-shared-ref i
9730: 73 75 66 66 69 78 29 0a 20 20 28 73 74 72 69 6e suffix). (strin
9740: 67 2d 61 70 70 65 6e 64 20 22 23 22 20 28 6e 75 g-append "#" (nu
9750: 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 69 29 20 mber->string i)
9760: 73 75 66 66 69 78 29 29 0a 0a 28 64 65 66 69 6e suffix))..(defin
9770: 65 20 28 6d 61 79 62 65 2d 67 65 6e 2d 73 68 61 e (maybe-gen-sha
9780: 72 65 64 2d 72 65 66 20 73 74 20 63 65 6c 6c 20 red-ref st cell
9790: 73 68 61 72 65 73 29 0a 20 20 28 63 6f 6e 64 0a shares). (cond.
97a0: 20 20 20 20 28 28 70 61 69 72 3f 20 63 65 6c 6c ((pair? cell
97b0: 29 0a 20 20 20 20 20 28 73 65 74 2d 63 61 72 21 ). (set-car!
97c0: 20 63 65 6c 6c 20 28 63 64 72 20 73 68 61 72 65 cell (cdr share
97d0: 73 29 29 0a 20 20 20 20 20 28 73 65 74 2d 63 64 s)). (set-cd
97e0: 72 21 20 63 65 6c 6c 20 23 74 29 0a 20 20 20 20 r! cell #t).
97f0: 20 28 73 65 74 2d 63 64 72 21 20 73 68 61 72 65 (set-cdr! share
9800: 73 20 28 2b 20 28 63 64 72 20 73 68 61 72 65 73 s (+ (cdr shares
9810: 29 20 31 29 29 0a 20 20 20 20 20 28 28 66 6d 74 ) 1)). ((fmt
9820: 2d 77 72 69 74 65 72 20 73 74 29 20 28 67 65 6e -writer st) (gen
9830: 2d 73 68 61 72 65 64 2d 72 65 66 20 28 63 61 72 -shared-ref (car
9840: 20 63 65 6c 6c 29 20 22 3d 22 29 20 73 74 29 29 cell) "=") st))
9850: 0a 20 20 20 20 28 65 6c 73 65 20 73 74 29 29 29 . (else st)))
9860: 0a 0a 28 64 65 66 69 6e 65 20 28 63 61 6c 6c 2d ..(define (call-
9870: 77 69 74 68 2d 73 68 61 72 65 64 2d 72 65 66 20 with-shared-ref
9880: 6f 62 6a 20 73 74 20 73 68 61 72 65 73 20 70 72 obj st shares pr
9890: 6f 63 29 0a 20 20 28 6c 65 74 20 28 28 63 65 6c oc). (let ((cel
98a0: 6c 20 28 65 71 3f 2d 74 61 62 6c 65 2d 72 65 66 l (eq?-table-ref
98b0: 20 28 63 61 72 20 73 68 61 72 65 73 29 20 6f 62 (car shares) ob
98c0: 6a 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e j))). (if (an
98d0: 64 20 28 70 61 69 72 3f 20 63 65 6c 6c 29 20 28 d (pair? cell) (
98e0: 63 64 72 20 63 65 6c 6c 29 29 0a 20 20 20 20 20 cdr cell)).
98f0: 20 20 20 28 28 66 6d 74 2d 77 72 69 74 65 72 20 ((fmt-writer
9900: 73 74 29 20 28 67 65 6e 2d 73 68 61 72 65 64 2d st) (gen-shared-
9910: 72 65 66 20 28 63 61 72 20 63 65 6c 6c 29 20 22 ref (car cell) "
9920: 23 22 29 20 73 74 29 0a 20 20 20 20 20 20 20 20 #") st).
9930: 28 70 72 6f 63 20 28 6d 61 79 62 65 2d 67 65 6e (proc (maybe-gen
9940: 2d 73 68 61 72 65 64 2d 72 65 66 20 73 74 20 63 -shared-ref st c
9950: 65 6c 6c 20 73 68 61 72 65 73 29 29 29 29 29 0a ell shares))))).
9960: 0a 28 64 65 66 69 6e 65 20 28 63 61 6c 6c 2d 77 .(define (call-w
9970: 69 74 68 2d 73 68 61 72 65 64 2d 72 65 66 2f 63 ith-shared-ref/c
9980: 64 72 20 6f 62 6a 20 73 74 20 73 68 61 72 65 73 dr obj st shares
9990: 20 70 72 6f 63 20 73 65 70 29 0a 20 20 28 6c 65 proc sep). (le
99a0: 74 20 28 28 63 65 6c 6c 20 28 65 71 3f 2d 74 61 t ((cell (eq?-ta
99b0: 62 6c 65 2d 72 65 66 20 28 63 61 72 20 73 68 61 ble-ref (car sha
99c0: 72 65 73 29 20 6f 62 6a 29 29 0a 20 20 20 20 20 res) obj)).
99d0: 20 20 20 28 6f 75 74 70 75 74 20 28 66 6d 74 2d (output (fmt-
99e0: 77 72 69 74 65 72 20 73 74 29 29 29 0a 20 20 20 writer st))).
99f0: 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 28 28 61 (cond. ((a
9a00: 6e 64 20 28 70 61 69 72 3f 20 63 65 6c 6c 29 20 nd (pair? cell)
9a10: 28 63 64 72 20 63 65 6c 6c 29 29 0a 20 20 20 20 (cdr cell)).
9a20: 20 20 20 28 6f 75 74 70 75 74 20 28 67 65 6e 2d (output (gen-
9a30: 73 68 61 72 65 64 2d 72 65 66 20 28 63 61 72 20 shared-ref (car
9a40: 63 65 6c 6c 29 20 22 23 22 29 20 28 6f 75 74 70 cell) "#") (outp
9a50: 75 74 20 22 2e 20 22 20 28 73 65 70 20 73 74 29 ut ". " (sep st)
9a60: 29 29 29 0a 20 20 20 20 20 20 28 28 70 61 69 72 ))). ((pair
9a70: 3f 20 63 65 6c 6c 29 0a 20 20 20 20 20 20 20 28 ? cell). (
9a80: 6c 65 74 20 28 28 73 74 20 28 6d 61 79 62 65 2d let ((st (maybe-
9a90: 67 65 6e 2d 73 68 61 72 65 64 2d 72 65 66 20 28 gen-shared-ref (
9aa0: 6f 75 74 70 75 74 20 22 2e 20 22 20 28 73 65 70 output ". " (sep
9ab0: 20 73 74 29 29 20 63 65 6c 6c 20 73 68 61 72 65 st)) cell share
9ac0: 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 6f s))). (o
9ad0: 75 74 70 75 74 20 22 29 22 20 28 70 72 6f 63 20 utput ")" (proc
9ae0: 28 6f 75 74 70 75 74 20 22 28 22 20 73 74 29 29 (output "(" st))
9af0: 29 29 29 0a 20 20 20 20 20 20 28 65 6c 73 65 0a ))). (else.
9b00: 20 20 20 20 20 20 20 28 70 72 6f 63 20 28 73 65 (proc (se
9b10: 70 20 73 74 29 29 29 29 29 29 0a 0a 3b 3b 3b 3b p st))))))..;;;;
9b20: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
9b30: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
9b40: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
9b50: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
9b60: 3b 3b 3b 3b 0a 3b 3b 3b 20 73 65 78 70 20 66 6f ;;;;.;;; sexp fo
9b70: 72 6d 61 74 74 65 72 73 0a 0a 28 64 65 66 69 6e rmatters..(defin
9b80: 65 20 28 73 6c 61 73 68 69 66 69 65 64 20 73 74 e (slashified st
9b90: 72 20 2e 20 6f 29 0a 20 20 28 6c 65 74 2d 6f 70 r . o). (let-op
9ba0: 74 69 6f 6e 61 6c 73 2a 20 6f 20 28 28 71 75 6f tionals* o ((quo
9bb0: 74 20 23 5c 22 29 20 28 65 73 63 20 23 5c 5c 29 t #\") (esc #\\)
9bc0: 20 28 72 65 6e 61 6d 65 20 28 6c 61 6d 62 64 61 (rename (lambda
9bd0: 20 28 78 29 20 23 66 29 29 29 0a 20 20 20 20 28 (x) #f))). (
9be0: 6c 61 6d 62 64 61 20 28 73 74 29 0a 20 20 20 20 lambda (st).
9bf0: 20 20 28 6c 65 74 2a 20 28 28 6c 65 6e 20 28 73 (let* ((len (s
9c00: 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 73 74 72 tring-length str
9c10: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
9c20: 28 6f 75 74 70 75 74 20 28 66 6d 74 2d 77 72 69 (output (fmt-wri
9c30: 74 65 72 20 73 74 29 29 0a 20 20 20 20 20 20 20 ter st)).
9c40: 20 20 20 20 20 20 28 71 75 6f 74 2d 73 74 72 20 (quot-str
9c50: 28 73 74 72 69 6e 67 20 71 75 6f 74 29 29 0a 20 (string quot)).
9c60: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 73 63 (esc
9c70: 2d 73 74 72 20 28 69 66 20 28 63 68 61 72 3f 20 -str (if (char?
9c80: 65 73 63 29 20 28 73 74 72 69 6e 67 20 65 73 63 esc) (string esc
9c90: 29 20 28 6f 72 20 65 73 63 20 71 75 6f 74 2d 73 ) (or esc quot-s
9ca0: 74 72 29 29 29 29 0a 20 20 20 20 20 20 20 20 28 tr)))). (
9cb0: 6c 65 74 20 6c 70 20 28 28 69 20 30 29 20 28 6a let lp ((i 0) (j
9cc0: 20 30 29 20 28 73 74 20 73 74 29 29 0a 20 20 20 0) (st st)).
9cd0: 20 20 20 20 20 20 20 28 64 65 66 69 6e 65 20 28 (define (
9ce0: 63 6f 6c 6c 65 63 74 29 0a 20 20 20 20 20 20 20 collect).
9cf0: 20 20 20 20 20 28 69 66 20 28 3d 20 69 20 6a 29 (if (= i j)
9d00: 20 73 74 20 28 6f 75 74 70 75 74 20 28 73 75 62 st (output (sub
9d10: 73 74 72 69 6e 67 2f 73 68 61 72 65 64 20 73 74 string/shared st
9d20: 72 20 69 20 6a 29 20 73 74 29 29 29 0a 20 20 20 r i j) st))).
9d30: 20 20 20 20 20 20 20 28 69 66 20 28 3e 3d 20 6a (if (>= j
9d40: 20 6c 65 6e 29 0a 20 20 20 20 20 20 20 20 20 20 len).
9d50: 20 20 20 20 28 63 6f 6c 6c 65 63 74 29 0a 20 20 (collect).
9d60: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
9d70: 20 28 28 63 20 28 73 74 72 69 6e 67 2d 72 65 66 ((c (string-ref
9d80: 20 73 74 72 20 6a 29 29 29 0a 20 20 20 20 20 20 str j))).
9d90: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a (cond.
9da0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9db0: 20 20 28 28 6f 72 20 28 65 71 76 3f 20 63 20 71 ((or (eqv? c q
9dc0: 75 6f 74 29 20 28 65 71 76 3f 20 63 20 65 73 63 uot) (eqv? c esc
9dd0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
9de0: 20 20 20 20 20 20 28 6c 70 20 6a 20 28 2b 20 6a (lp j (+ j
9df0: 20 31 29 20 28 6f 75 74 70 75 74 20 65 73 63 2d 1) (output esc-
9e00: 73 74 72 20 28 63 6f 6c 6c 65 63 74 29 29 29 29 str (collect))))
9e10: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
9e20: 20 20 20 28 28 72 65 6e 61 6d 65 20 63 29 0a 20 ((rename c).
9e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9e40: 20 20 3d 3e 20 28 6c 61 6d 62 64 61 20 28 63 32 => (lambda (c2
9e50: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
9e60: 20 20 20 20 20 20 20 20 20 20 28 6c 70 20 28 2b (lp (+
9e70: 20 6a 20 31 29 0a 20 20 20 20 20 20 20 20 20 20 j 1).
9e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9e90: 20 20 28 2b 20 6a 20 31 29 0a 20 20 20 20 20 20 (+ j 1).
9ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9eb0: 20 20 20 20 20 20 28 6f 75 74 70 75 74 20 63 32 (output c2
9ec0: 20 28 6f 75 74 70 75 74 20 65 73 63 2d 73 74 72 (output esc-str
9ed0: 20 28 63 6f 6c 6c 65 63 74 29 29 29 29 29 29 0a (collect)))))).
9ee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9ef0: 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 20 20 (else.
9f00: 20 20 20 20 20 20 20 20 20 20 20 28 6c 70 20 69 (lp i
9f10: 20 28 2b 20 6a 20 31 29 20 73 74 29 29 29 29 29 (+ j 1) st)))))
9f20: 29 29 29 29 29 0a 0a 3b 3b 20 4f 6e 6c 79 20 73 )))))..;; Only s
9f30: 6c 61 73 68 69 66 79 20 69 66 20 74 68 65 72 65 lashify if there
9f40: 20 61 72 65 20 73 70 65 63 69 61 6c 20 63 68 61 are special cha
9f50: 72 61 63 74 65 72 73 2c 20 69 6e 20 77 68 69 63 racters, in whic
9f60: 68 20 63 61 73 65 20 61 6c 73 6f 0a 3b 3b 20 77 h case also.;; w
9f70: 72 61 70 20 69 6e 20 71 75 6f 74 65 73 2e 20 20 rap in quotes.
9f80: 46 6f 72 20 77 72 69 74 69 6e 67 20 73 79 6d 62 For writing symb
9f90: 6f 6c 73 20 69 6e 20 7c 2e 2e 2e 7c 20 65 73 63 ols in |...| esc
9fa0: 61 70 65 73 2c 20 6f 72 20 43 53 56 0a 3b 3b 20 apes, or CSV.;;
9fb0: 66 69 65 6c 64 73 2c 20 65 74 63 2e 20 20 54 68 fields, etc. Th
9fc0: 65 20 70 72 65 64 69 63 61 74 65 20 69 6e 64 69 e predicate indi
9fd0: 63 61 74 65 73 20 77 68 69 63 68 20 63 68 61 72 cates which char
9fe0: 61 63 74 65 72 73 20 63 61 75 73 65 0a 3b 3b 20 acters cause.;;
9ff0: 73 6c 61 73 68 69 66 69 63 61 74 69 6f 6e 20 2d slashification -
a000: 20 74 68 69 73 20 69 73 20 69 6e 20 61 64 64 69 this is in addi
a010: 74 69 6f 6e 20 74 6f 20 61 75 74 6f 6d 61 74 69 tion to automati
a020: 63 20 73 6c 61 73 68 69 66 79 69 6e 67 20 77 68 c slashifying wh
a030: 65 6e 0a 3b 3b 20 65 69 74 68 65 72 20 74 68 65 en.;; either the
a040: 20 71 75 6f 74 65 20 6f 72 20 65 73 63 61 70 65 quote or escape
a050: 20 63 68 61 72 20 69 73 20 70 72 65 73 65 6e 74 char is present
a060: 2e 0a 0a 28 64 65 66 69 6e 65 20 28 6d 61 79 62 ...(define (mayb
a070: 65 2d 73 6c 61 73 68 69 66 69 65 64 20 73 74 72 e-slashified str
a080: 20 70 72 65 64 20 2e 20 6f 29 0a 20 20 28 6c 65 pred . o). (le
a090: 74 2d 6f 70 74 69 6f 6e 61 6c 73 2a 20 6f 20 28 t-optionals* o (
a0a0: 28 71 75 6f 74 20 23 5c 22 29 20 28 65 73 63 20 (quot #\") (esc
a0b0: 23 5c 5c 29 20 28 72 65 6e 61 6d 65 20 28 6c 61 #\\) (rename (la
a0c0: 6d 62 64 61 20 28 78 29 20 23 66 29 29 29 0a 20 mbda (x) #f))).
a0d0: 20 20 20 28 64 65 66 69 6e 65 20 28 65 73 63 3f (define (esc?
a0e0: 20 63 29 20 28 6f 72 20 28 65 71 76 3f 20 63 20 c) (or (eqv? c
a0f0: 71 75 6f 74 29 20 28 65 71 76 3f 20 63 20 65 73 quot) (eqv? c es
a100: 63 29 20 28 72 65 6e 61 6d 65 20 63 29 20 28 70 c) (rename c) (p
a110: 72 65 64 20 63 29 29 29 0a 20 20 20 20 28 69 66 red c))). (if
a120: 20 28 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 73 (string-index s
a130: 74 72 20 65 73 63 3f 29 0a 20 20 20 20 20 20 20 tr esc?).
a140: 20 28 63 61 74 20 71 75 6f 74 20 28 73 6c 61 73 (cat quot (slas
a150: 68 69 66 69 65 64 20 73 74 72 20 71 75 6f 74 20 hified str quot
a160: 65 73 63 20 72 65 6e 61 6d 65 29 20 71 75 6f 74 esc rename) quot
a170: 29 0a 20 20 20 20 20 20 20 20 28 64 73 70 20 73 ). (dsp s
a180: 74 72 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 tr))))..(define
a190: 28 66 6d 74 2d 77 72 69 74 65 2d 73 74 72 69 6e (fmt-write-strin
a1a0: 67 20 73 74 72 29 0a 20 20 28 64 65 66 69 6e 65 g str). (define
a1b0: 20 28 72 65 6e 61 6d 65 20 63 29 0a 20 20 20 20 (rename c).
a1c0: 28 63 61 73 65 20 63 0a 20 20 20 20 20 20 28 28 (case c. ((
a1d0: 23 5c 6e 65 77 6c 69 6e 65 29 20 22 6e 22 29 0a #\newline) "n").
a1e0: 20 20 20 20 20 20 28 65 6c 73 65 20 23 66 29 29 (else #f))
a1f0: 29 0a 20 20 28 73 6c 61 73 68 69 66 69 65 64 20 ). (slashified
a200: 73 74 72 20 23 5c 22 20 23 5c 5c 20 72 65 6e 61 str #\" #\\ rena
a210: 6d 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 64 me))..(define (d
a220: 73 70 20 6f 62 6a 29 0a 20 20 28 63 6f 6e 64 0a sp obj). (cond.
a230: 20 20 20 20 28 28 70 72 6f 63 65 64 75 72 65 3f ((procedure?
a240: 20 6f 62 6a 29 20 6f 62 6a 29 0a 20 20 20 20 28 obj) obj). (
a250: 28 73 74 72 69 6e 67 3f 20 6f 62 6a 29 20 28 6c (string? obj) (l
a260: 61 6d 62 64 61 20 28 73 74 29 20 28 28 66 6d 74 ambda (st) ((fmt
a270: 2d 77 72 69 74 65 72 20 73 74 29 20 6f 62 6a 20 -writer st) obj
a280: 73 74 29 29 29 0a 20 20 20 20 28 28 63 68 61 72 st))). ((char
a290: 3f 20 6f 62 6a 29 20 28 64 73 70 20 28 73 74 72 ? obj) (dsp (str
a2a0: 69 6e 67 20 6f 62 6a 29 29 29 0a 20 20 20 20 28 ing obj))). (
a2b0: 65 6c 73 65 20 28 77 72 74 20 6f 62 6a 29 29 29 else (wrt obj)))
a2c0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 77 72 69 74 )..(define (writ
a2d0: 65 2d 77 69 74 68 2d 73 68 61 72 65 73 20 6f 62 e-with-shares ob
a2e0: 6a 20 73 68 61 72 65 73 29 0a 20 20 28 6c 61 6d j shares). (lam
a2f0: 62 64 61 20 28 73 74 29 0a 20 20 20 20 28 6c 65 bda (st). (le
a300: 74 2a 20 28 28 6f 75 74 70 75 74 20 28 66 6d 74 t* ((output (fmt
a310: 2d 77 72 69 74 65 72 20 73 74 29 29 0a 20 20 20 -writer st)).
a320: 20 20 20 20 20 20 20 20 28 77 72 2d 6e 75 6d 0a (wr-num.
a330: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
a340: 64 20 28 28 61 6e 64 20 28 3d 20 31 30 20 28 66 d ((and (= 10 (f
a350: 6d 74 2d 72 61 64 69 78 20 73 74 29 29 0a 20 20 mt-radix st)).
a360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a370: 20 20 20 20 20 20 28 6e 6f 74 20 28 66 6d 74 2d (not (fmt-
a380: 70 72 65 63 69 73 69 6f 6e 20 73 74 29 29 0a 20 precision st)).
a390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a3a0: 20 20 20 20 20 20 20 28 6e 6f 74 20 28 66 6d 74 (not (fmt
a3b0: 2d 64 65 63 69 6d 61 6c 2d 61 6c 69 67 6e 20 73 -decimal-align s
a3c0: 74 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 t))).
a3d0: 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 (lambda
a3e0: 28 6e 20 73 74 29 20 28 6f 75 74 70 75 74 20 28 (n st) (output (
a3f0: 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 6e number->string n
a400: 29 20 73 74 29 29 29 0a 20 20 20 20 20 20 20 20 ) st))).
a410: 20 20 20 20 20 20 20 20 20 20 28 28 61 73 73 76 ((assv
a420: 20 28 66 6d 74 2d 72 61 64 69 78 20 73 74 29 0a (fmt-radix st).
a430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a440: 20 20 20 20 20 20 20 20 20 27 28 28 31 36 20 2e '((16 .
a450: 20 22 23 78 22 29 20 28 31 30 20 2e 20 22 22 29 "#x") (10 . "")
a460: 20 28 38 20 2e 20 22 23 6f 22 29 20 28 32 20 2e (8 . "#o") (2 .
a470: 20 22 23 62 22 29 29 29 0a 20 20 20 20 20 20 20 "#b"))).
a480: 20 20 20 20 20 20 20 20 20 20 20 20 3d 3e 20 28 => (
a490: 6c 61 6d 62 64 61 20 28 63 65 6c 6c 29 0a 20 20 lambda (cell).
a4a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a4b0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 70 72 65 (let ((pre
a4c0: 66 69 78 20 28 63 64 72 20 63 65 6c 6c 29 29 29 fix (cdr cell)))
a4d0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a4e0: 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 (lamb
a4f0: 64 61 20 28 6e 20 73 74 29 20 28 28 6e 75 6d 20 da (n st) ((num
a500: 6e 29 20 28 6f 75 74 70 75 74 20 70 72 65 66 69 n) (output prefi
a510: 78 20 73 74 29 29 29 29 29 29 0a 20 20 20 20 20 x st)))))).
a520: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c (el
a530: 73 65 20 28 6c 61 6d 62 64 61 20 28 6e 20 73 74 se (lambda (n st
a540: 29 20 28 6f 75 74 70 75 74 20 28 6e 75 6d 62 65 ) (output (numbe
a550: 72 2d 3e 73 74 72 69 6e 67 20 6e 29 20 73 74 29 r->string n) st)
a560: 29 29 29 29 29 0a 20 20 20 20 20 20 28 6c 65 74 ))))). (let
a570: 20 77 72 20 28 28 6f 62 6a 20 6f 62 6a 29 20 28 wr ((obj obj) (
a580: 73 74 20 73 74 29 29 0a 20 20 20 20 20 20 20 20 st st)).
a590: 28 63 61 6c 6c 2d 77 69 74 68 2d 73 68 61 72 65 (call-with-share
a5a0: 64 2d 72 65 66 20 6f 62 6a 20 73 74 20 73 68 61 d-ref obj st sha
a5b0: 72 65 73 0a 20 20 20 20 20 20 20 20 20 20 28 6c res. (l
a5c0: 61 6d 62 64 61 20 28 73 74 29 0a 20 20 20 20 20 ambda (st).
a5d0: 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 (cond.
a5e0: 20 20 20 20 20 20 20 20 20 20 20 28 28 70 61 69 ((pai
a5f0: 72 3f 20 6f 62 6a 29 0a 20 20 20 20 20 20 20 20 r? obj).
a600: 20 20 20 20 20 20 20 28 6f 75 74 70 75 74 0a 20 (output.
a610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 "
a620: 29 22 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )".
a630: 20 20 20 28 6c 65 74 20 6c 70 20 28 28 6c 73 20 (let lp ((ls
a640: 6f 62 6a 29 0a 20 20 20 20 20 20 20 20 20 20 20 obj).
a650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
a660: 74 20 28 6f 75 74 70 75 74 20 22 28 22 20 73 74 t (output "(" st
a670: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
a680: 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 74 20 (let ((st
a690: 28 77 72 20 28 63 61 72 20 6c 73 29 20 73 74 29 (wr (car ls) st)
a6a0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
a6b0: 20 20 20 20 20 20 20 20 20 20 28 72 65 73 74 20 (rest
a6c0: 28 63 64 72 20 6c 73 29 29 29 0a 20 20 20 20 20 (cdr ls))).
a6d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
a6e0: 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 cond.
a6f0: 20 20 20 20 20 20 20 20 20 20 20 28 28 6e 75 6c ((nul
a700: 6c 3f 20 72 65 73 74 29 20 73 74 29 0a 20 20 20 l? rest) st).
a710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a720: 20 20 20 28 28 70 61 69 72 3f 20 72 65 73 74 29 ((pair? rest)
a730: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a740: 20 20 20 20 20 20 20 20 28 63 61 6c 6c 2d 77 69 (call-wi
a750: 74 68 2d 73 68 61 72 65 64 2d 72 65 66 2f 63 64 th-shared-ref/cd
a760: 72 20 72 65 73 74 20 73 74 20 73 68 61 72 65 73 r rest st shares
a770: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a780: 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 (lambd
a790: 61 20 28 73 74 29 20 28 6c 70 20 72 65 73 74 20 a (st) (lp rest
a7a0: 73 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 st)).
a7b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
a7c0: 73 70 20 22 20 22 29 29 29 0a 20 20 20 20 20 20 sp " "))).
a7d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a7e0: 28 65 6c 73 65 20 28 77 72 20 72 65 73 74 20 28 (else (wr rest (
a7f0: 6f 75 74 70 75 74 20 22 20 2e 20 22 20 73 74 29 output " . " st)
a800: 29 29 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 ))))))).
a810: 20 20 20 20 20 20 28 28 76 65 63 74 6f 72 3f 20 ((vector?
a820: 6f 62 6a 29 0a 20 20 20 20 20 20 20 20 20 20 20 obj).
a830: 20 20 20 20 28 6c 65 74 20 28 28 6c 65 6e 20 28 (let ((len (
a840: 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 6f 62 vector-length ob
a850: 6a 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 j))).
a860: 20 20 20 20 20 20 28 69 66 20 28 7a 65 72 6f 3f (if (zero?
a870: 20 6c 65 6e 29 0a 20 20 20 20 20 20 20 20 20 20 len).
a880: 20 20 20 20 20 20 20 20 20 20 20 28 6f 75 74 70 (outp
a890: 75 74 20 22 23 28 29 22 20 73 74 29 0a 20 20 20 ut "#()" st).
a8a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a8b0: 20 20 28 6c 65 74 20 6c 70 20 28 28 69 20 31 29 (let lp ((i 1)
a8c0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a8d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
a8e0: 73 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 st.
a8f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a900: 20 20 28 77 72 20 28 76 65 63 74 6f 72 2d 72 65 (wr (vector-re
a910: 66 20 6f 62 6a 20 30 29 0a 20 20 20 20 20 20 20 f obj 0).
a920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a930: 20 20 20 20 20 20 20 20 20 20 20 20 28 6f 75 74 (out
a940: 70 75 74 20 22 23 28 22 20 73 74 29 29 29 29 0a put "#(" st)))).
a950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a960: 20 20 20 20 20 20 20 28 69 66 20 28 3e 3d 20 69 (if (>= i
a970: 20 6c 65 6e 29 0a 20 20 20 20 20 20 20 20 20 20 len).
a980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a990: 20 28 6f 75 74 70 75 74 20 22 29 22 20 73 74 29 (output ")" st)
a9a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a9b0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 70 20 (lp
a9c0: 28 2b 20 69 20 31 29 0a 20 20 20 20 20 20 20 20 (+ i 1).
a9d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a9e0: 20 20 20 20 20 20 20 28 77 72 20 28 76 65 63 74 (wr (vect
a9f0: 6f 72 2d 72 65 66 20 6f 62 6a 20 69 29 0a 20 20 or-ref obj i).
aa00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aa10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aa20: 20 28 6f 75 74 70 75 74 20 22 20 22 20 73 74 29 (output " " st)
aa30: 29 29 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 ))))))).
aa40: 20 20 20 20 20 20 28 28 73 74 72 69 6e 67 3f 20 ((string?
aa50: 6f 62 6a 29 0a 20 20 20 20 20 20 20 20 20 20 20 obj).
aa60: 20 20 20 20 28 6f 75 74 70 75 74 20 22 5c 22 22 (output "\""
aa70: 20 28 28 66 6d 74 2d 77 72 69 74 65 2d 73 74 72 ((fmt-write-str
aa80: 69 6e 67 20 6f 62 6a 29 20 28 6f 75 74 70 75 74 ing obj) (output
aa90: 20 22 5c 22 22 20 73 74 29 29 29 29 0a 20 20 20 "\"" st)))).
aaa0: 20 20 20 20 20 20 20 20 20 20 20 28 28 6e 75 6d ((num
aab0: 62 65 72 3f 20 6f 62 6a 29 0a 20 20 20 20 20 20 ber? obj).
aac0: 20 20 20 20 20 20 20 20 20 28 77 72 2d 6e 75 6d (wr-num
aad0: 20 6f 62 6a 20 73 74 29 29 0a 20 20 20 20 20 20 obj st)).
aae0: 20 20 20 20 20 20 20 20 28 28 62 6f 6f 6c 65 61 ((boolea
aaf0: 6e 3f 20 6f 62 6a 29 0a 20 20 20 20 20 20 20 20 n? obj).
ab00: 20 20 20 20 20 20 20 28 6f 75 74 70 75 74 20 28 (output (
ab10: 69 66 20 6f 62 6a 20 22 23 74 22 20 22 23 66 22 if obj "#t" "#f"
ab20: 29 20 73 74 29 29 0a 20 20 20 20 20 20 20 20 20 ) st)).
ab30: 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 (else.
ab40: 20 20 20 20 20 20 20 20 20 20 28 6f 75 74 70 75 (outpu
ab50: 74 20 28 77 72 69 74 65 2d 74 6f 2d 73 74 72 69 t (write-to-stri
ab60: 6e 67 20 6f 62 6a 29 20 73 74 29 29 29 29 29 29 ng obj) st))))))
ab70: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 77 72 )))..(define (wr
ab80: 74 20 6f 62 6a 29 0a 20 20 28 77 72 69 74 65 2d t obj). (write-
ab90: 77 69 74 68 2d 73 68 61 72 65 73 20 6f 62 6a 20 with-shares obj
aba0: 28 63 6f 6e 73 20 28 6d 61 6b 65 2d 73 68 61 72 (cons (make-shar
abb0: 65 64 2d 72 65 66 2d 74 61 62 6c 65 20 6f 62 6a ed-ref-table obj
abc0: 29 20 30 29 29 29 0a 0a 3b 3b 20 74 68 65 20 6f ) 0)))..;; the o
abd0: 6e 6c 79 20 65 78 70 65 6e 73 69 76 65 20 70 61 nly expensive pa
abe0: 72 74 2c 20 69 6e 20 62 6f 74 68 20 74 69 6d 65 rt, in both time
abf0: 20 61 6e 64 20 6d 65 6d 6f 72 79 2c 20 6f 66 20 and memory, of
ac00: 68 61 6e 64 6c 69 6e 67 0a 3b 3b 20 73 68 61 72 handling.;; shar
ac10: 65 64 20 73 74 72 75 63 74 75 72 65 73 20 77 68 ed structures wh
ac20: 65 6e 20 77 72 69 74 69 6e 67 20 69 73 20 62 75 en writing is bu
ac30: 69 6c 64 69 6e 67 20 74 68 65 20 69 6e 69 74 69 ilding the initi
ac40: 61 6c 20 74 61 62 6c 65 2c 20 73 6f 0a 3b 3b 20 al table, so.;;
ac50: 66 6f 72 20 74 68 65 20 65 66 66 69 63 69 65 6e for the efficien
ac60: 74 20 76 65 72 73 69 6f 6e 20 77 65 20 6a 75 73 t version we jus
ac70: 74 20 73 6b 69 70 20 74 68 61 74 0a 0a 28 64 65 t skip that..(de
ac80: 66 69 6e 65 20 28 77 72 74 2f 75 6e 73 68 61 72 fine (wrt/unshar
ac90: 65 64 20 6f 62 6a 29 0a 20 20 28 77 72 69 74 65 ed obj). (write
aca0: 2d 77 69 74 68 2d 73 68 61 72 65 73 20 6f 62 6a -with-shares obj
acb0: 20 28 63 6f 6e 73 20 28 6d 61 6b 65 2d 65 71 3f (cons (make-eq?
acc0: 2d 74 61 62 6c 65 29 20 30 29 29 29 0a 0a -table) 0)))..