;;;; fmt-mzscheme.scm -- MzScheme fmt extension
;;
;; Copyright (c) 2007 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt

(module fmt mzscheme
        (require (only (lib "1.ss" "srfi")
                       find
                       fold
                       length+
                       remove
                       filter
                       every)
                 (lib "6.ss" "srfi")
                 (only (lib "13.ss" "srfi")
                       substring/shared
                       string-index
                       string-index-right
                       string-count
                       string-concatenate
                       string-concatenate-reverse
                       string-tokenize
                       string-pad
                       string-prefix?
                       string-suffix?)
                 (lib "23.ss" "srfi")
                 "let-optionals.ss"
                 "mantissa.ss")
        (provide
         new-fmt-state
         fmt fmt-start fmt-if fmt-capture fmt-let fmt-bind
         fmt-ref fmt-set! fmt-add-properties! fmt-set-property!
         fmt-col fmt-set-col! fmt-row fmt-set-row!
         fmt-radix fmt-set-radix! fmt-precision fmt-set-precision!
         fmt-properties fmt-set-properties! fmt-width fmt-set-width!
         fmt-writer fmt-set-writer! fmt-port fmt-set-port!
         fmt-decimal-sep fmt-set-decimal-sep!
         copy-fmt-state
         fmt-file fmt-try-fit cat apply-cat nl fl nl-str
         join join/last join/dot join/prefix join/suffix join/range
         pad pad/right pad/both trim trim/left trim/both trim/length
         fit fit/left fit/both tab-to space-to wrt wrt/unshared dsp
         pretty pretty/unshared slashified maybe-slashified
         num num/si num/fit num/comma radix fix ellipses
         upcase downcase titlecase pad-char comma-char decimal-char
         with-width wrap-lines fold-lines justify
         make-string-fmt-transformer
         make-space make-nl-space display-to-string write-to-string
         fmt-columns columnar line-numbers
         )

(define (make-eq?-table) (make-hash-table))
(define hash-table-ref/default hash-table-get)
(define hash-table-set! hash-table-put!)
(define hash-table-walk hash-table-for-each)

        ;; -- insert fmt.scm here --

;;;; fmt.scm -- extensible formatting library
;;
;; Copyright (c) 2006-2007 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt

;; (require-extension (srfi 1 6 13 23 69))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; string utilities

(define (call-with-output-string proc)
  (let ((p (open-output-string)))
    (proc p)
    (get-output-string p)))

(define (write-to-string x)
  (call-with-output-string (lambda (p) (write x p))))

(define (display-to-string x)
  (if (string? x)
      x
      (call-with-output-string (lambda (p) (display x p)))))

(define nl-str
  (call-with-output-string newline))

(define (make-space n) (make-string n #\space))
(define (make-nl-space n) (string-append nl-str (make-string n #\space)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; list utilities

(define (take* ls n)   ; handles dotted lists and n > length
  (cond ((zero? n) '())
        ((pair? ls) (cons (car ls) (take* (cdr ls) (- n 1))))
        (else '())))

(define (drop* ls n)   ; may return the dot
  (cond ((zero? n) ls)
        ((pair? ls) (drop* (cdr ls) (- n 1)))
        (else ls)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; format state representation

;; Use a flexible representation optimized for common cases -
;; frequently accessed values are in fixed vector slots, with a
;; `properties' slot holding an alist for all other values.

(define *default-fmt-state*
  (vector 0 0 10 '() #\space #f 78 #f #f #f #f #f))

(define fmt-state? vector?)

(define (new-fmt-state . o)
  (let ((st (if (pair? o) (car o) (current-output-port))))
    (if (vector? st)
        st
        (fmt-set-writer!
         (fmt-set-port! (copy-fmt-state *default-fmt-state*) st)
         fmt-write))))

(define (copy-fmt-state st)
  (let* ((len (vector-length st))
         (res (make-vector len)))
    (do ((i 0 (+ i 1)))
        ((= i len))
      (vector-set! res i (vector-ref st i)))
    (fmt-set-properties! res (map (lambda (x) (cons (car x) (cdr x)))
                                  (fmt-properties res)))
    res))

(define (fmt-row st) (vector-ref st 0))
(define (fmt-col st) (vector-ref st 1))
(define (fmt-radix st) (vector-ref st 2))
(define (fmt-properties st) (vector-ref st 3))
(define (fmt-pad-char st) (vector-ref st 4))
(define (fmt-precision st) (vector-ref st 5))
(define (fmt-width st) (vector-ref st 6))
(define (fmt-writer st) (vector-ref st 7))
(define (fmt-port st) (vector-ref st 8))
(define (fmt-decimal-sep st) (vector-ref st 9))
(define (fmt-string-width st) (vector-ref st 10))
(define (fmt-ellipses st) (vector-ref st 11))

(define (fmt-set-row! st x) (vector-set! st 0 x) st)
(define (fmt-set-col! st x) (vector-set! st 1 x) st)
(define (fmt-set-radix! st x) (vector-set! st 2 x) st)
(define (fmt-set-properties! st x) (vector-set! st 3 x) st)
(define (fmt-set-pad-char! st x) (vector-set! st 4 x) st)
(define (fmt-set-precision! st x) (vector-set! st 5 x) st)
(define (fmt-set-width! st x) (vector-set! st 6 x) st)
(define (fmt-set-writer! st x) (vector-set! st 7 x) st)
(define (fmt-set-port! st x) (vector-set! st 8 x) st)
(define (fmt-set-decimal-sep! st x) (vector-set! st 9 x) st)
(define (fmt-set-string-width! st x) (vector-set! st 10 x) st)
(define (fmt-set-ellipses! st x) (vector-set! st 11 x) st)

(define (fmt-ref st key . o)
  (case key
    ((row) (fmt-row st))
    ((col) (fmt-col st))
    ((radix) (fmt-radix st))
    ((properties) (fmt-properties st))
    ((writer) (fmt-writer st))
    ((port) (fmt-port st))
    ((precision) (fmt-precision st))
    ((pad-char) (fmt-pad-char st))
    ((width) (fmt-width st))
    ((decimal-sep) (fmt-decimal-sep st))
    ((string-width) (fmt-string-width st))
    ((ellipses) (fmt-ellipses st))
    (else (cond ((assq key (fmt-properties st)) => cdr)
                ((pair? o) (car o))
                (else #f)))))

(define (fmt-set-property! st key val)
  (cond ((assq key (fmt-properties st))
         => (lambda (cell) (set-cdr! cell val) st))
        (else (fmt-set-properties!
               st
               (cons (cons key val) (fmt-properties st))))))

(define (fmt-set! st key val)
  (case key
    ((row) (fmt-set-row! st val))
    ((col) (fmt-set-col! st val))
    ((radix) (fmt-set-radix! st val))
    ((properties) (fmt-set-properties! st val))
    ((pad-char) (fmt-set-pad-char! st val))
    ((precision) (fmt-set-precision! st val))
    ((writer) (fmt-set-writer! st val))
    ((port) (fmt-set-port! st val))
    ((width) (fmt-set-width! st val))
    ((decimal-sep) (fmt-set-decimal-sep! st val))
    ((string-width) (fmt-set-string-width! st val))
    ((ellipses) (fmt-set-ellipses! st val))
    (else (fmt-set-property! st key val))))

(define (fmt-add-properties! st alist)
  (for-each (lambda (x) (fmt-set! st (car x) (cdr x))) alist)
  st)

(define (fmt-let key val . ls)
  (lambda (st)
    (let ((orig-val (fmt-ref st key)))
      (fmt-set! ((apply-cat ls) (fmt-set! st key val)) key orig-val))))

(define (fmt-bind key val . ls)
  (lambda (st) ((apply-cat ls) (fmt-set! st key val))))

(define (fix prec . ls) (fmt-let 'precision prec (apply-cat ls)))
(define (radix rad . ls) (fmt-let 'radix rad (apply-cat ls)))
(define (pad-char ch . ls) (fmt-let 'pad-char ch (apply-cat ls)))
(define (comma-char ch . ls) (fmt-let 'comma-char ch (apply-cat ls)))
(define (decimal-char ch . ls) (fmt-let 'decimal-sep ch (apply-cat ls)))
(define (with-width w . ls) (fmt-let 'width w (apply-cat ls)))
(define (ellipses ell . ls) (fmt-let 'ellipses ell (apply-cat ls)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; the basic interface

(define (fmt-start st initializer proc)
  (cond
    ((or (output-port? st) (fmt-state? st))
     (proc (initializer st))
     (if #f #f))
    ((eq? #t st)
     (proc (initializer (current-output-port)))
     (if #f #f))
    ((eq? #f st)
     (get-output-string
      (fmt-port (proc (initializer (open-output-string))))))
    (else (error "unknown format output" st))))

(define (fmt st . args)
  (fmt-start st new-fmt-state (apply-cat args)))

(define (fmt-update str st)
  (let ((len (string-length str))
        (nli (string-index-right str #\newline))
        (str-width (fmt-string-width st)))
    (if nli
        (let ((row (+ (fmt-row st) 1 (string-count str #\newline 0 nli))))
          (fmt-set-row!
           (fmt-set-col! st (if str-width
                                (str-width str (+ nli 1) len)
                                (- len (+ nli 1))))
           row))
        (fmt-set-col! st (if str-width
                             (str-width str 0 len)
                             (+ (fmt-col st) len))))))

(define (fmt-write str st)
  (display str (fmt-port st))
  (fmt-update str st))

(define (apply-cat procs)
  (lambda (st)
    (let loop ((ls procs) (st st))
      (if (null? ls)
          st
          (loop (cdr ls) ((dsp (car ls)) st))))))

(define (cat . ls) (apply-cat ls))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; control structures

(define (fmt-if check pass . o)
  (let ((fail (if (pair? o) (car o) (lambda (x) x))))
    (lambda (st) (if (check st) ((dsp pass) st) ((dsp fail) st)))))

(define (fmt-try-fit proc . fail)
  (if (null? fail)
      proc
      (lambda (orig-st)
        (let ((width (fmt-width orig-st))
              (buffer '()))
          (call-with-current-continuation
            (lambda (return)
              (define (output* str st)
                (let lp ((i 0) (col (fmt-col st)))
                  (let ((nli (string-index str #\newline i)))
                    (if nli
                        (if (> (+ (- nli i) col) width)
                            (return ((apply fmt-try-fit fail) orig-st))
                            (lp (+ nli 1) 0))
                        (let* ((len (string-length str))
                               (col (+ (- len i) col)))
                          (if (> col width)
                              (return ((apply fmt-try-fit fail) orig-st))
                              (begin
                                (set! buffer (cons str buffer))
                                (fmt-update str st))))))))
              (proc (fmt-set-port! (fmt-set-writer! (copy-fmt-state orig-st)
                                                    output*)
                                   (open-output-string)))
              ((fmt-writer orig-st)
               (string-concatenate-reverse buffer)
               orig-st)))))))

(define (fits-in-width gen width)
  (lambda (st)
    (let ((output (fmt-writer st))
          (port (open-output-string)))
      (call-with-current-continuation
        (lambda (return)
          (define (output* str st)
            (let ((st (fmt-update str st)))
              (if (> (fmt-col st) width)
                  (return #f)
                  (begin
                    (display str port)
                    st))))
          (gen (fmt-set-port! (fmt-set-writer! (copy-fmt-state st) output*)
                              port))
          (get-output-string port))))))

(define (fits-in-columns ls write width)
  (lambda (st)
    (let ((max-w (quotient width 2)))
      (let lp ((ls ls) (res '()) (widest 0))
        (cond
          ((pair? ls)
           (let ((str ((fits-in-width (write (car ls)) max-w) st)))
             (and str
                  (lp (cdr ls)
                      (cons str res)
                      (max (string-length str) widest)))))
          ((null? ls) (cons widest (reverse res)))
          (else #f))))))

(define (fmt-capture producer consumer)
  (lambda (st)
    (let ((port (open-output-string)))
      (producer (fmt-set-writer! (fmt-set-port! (copy-fmt-state st) port)
                                 fmt-write))
      ((consumer (get-output-string port)) st))))

(define (fmt-to-string producer)
  (fmt-capture producer (lambda (str) (lambda (st) str))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; standard formatters

(define (nl st)
  ((fmt-writer st) nl-str st))

;; output a newline iff we're not at the start of a fresh line
(define (fl st)
  (if (zero? (fmt-col st)) st (nl st)))

;; tab to a given tab-stop
(define (tab-to . o)
  (lambda (st)
    (let* ((tab-width (if (pair? o) (car o) 8))
           (rem (modulo (fmt-col st) tab-width)))
      (if (positive? rem)
          ((fmt-writer st)
           (make-string (- tab-width rem) (fmt-pad-char st))
           st)
          st))))

;; move to an explicit column
(define (space-to col)
  (lambda (st)
    (let ((width (- col (fmt-col st))))
      (if (positive? width)
          ((fmt-writer st) (make-string width (fmt-pad-char st)) st)
          st))))

(define (join fmt ls . o)
  (let ((sep (dsp (if (pair? o) (car o) " "))))
    (lambda (st)
      (if (null? ls)
          st
          (let lp ((ls (cdr ls))
                   (st ((fmt (car ls)) st)))
            (if (null? ls)
                st
                (lp (cdr ls) ((fmt (car ls)) (sep st)))))))))

(define (join/prefix fmt ls . o)
  (let ((sep (dsp (if (pair? o) (car o) " "))))
    (cat sep (join fmt ls sep))))
(define (join/suffix fmt ls . o)
  (let ((sep (dsp (if (pair? o) (car o) " "))))
    (cat (join fmt ls sep) sep)))

(define (join/last fmt fmt/last ls . o)
  (let ((sep (dsp (if (pair? o) (car o) " "))))
    (lambda (st)
      (cond
        ((null? ls)
         st)
        ((null? (cdr ls))
         ((fmt/last (car ls)) (sep st)))
        (else
         (let lp ((ls (cdr ls))
                  (st ((fmt (car ls)) st)))
           (if (null? (cdr ls))
               ((fmt/last (car ls)) (sep st))
               (lp (cdr ls) ((fmt (car ls)) (sep st))))))))))

(define (join/dot fmt fmt/dot ls . o)
  (let ((sep (dsp (if (pair? o) (car o) " "))))
    (lambda (st)
      (cond
        ((pair? ls)
         (let lp ((ls (cdr ls))
                  (st ((fmt (car ls)) st)))
           (cond
             ((null? ls) st)
             ((pair? ls) (lp (cdr ls) ((fmt (car ls)) (sep st))))
             (else ((fmt/dot ls) (sep st))))))
        ((null? ls) st)
        (else ((fmt/dot ls) st))))))

(define (join/range fmt start . o)
  (let-optionals* o ((end #f) (sep " "))
    (lambda (st)
      (let lp ((i (+ start 1)) (st ((fmt start) st)))
        (if (and end (>= i end))
            st
            (lp (+ i 1) ((fmt i) ((dsp sep) st))))))))

(define (pad/both width . ls)
  (fmt-capture
   (apply-cat ls)
   (lambda (str)
     (lambda (st)
       (let ((diff (- width ((or (fmt-string-width st) string-length) str)))
             (output (fmt-writer st)))
         (if (positive? diff)
             (let* ((diff/2 (quotient diff 2))
                    (left (make-string diff/2 (fmt-pad-char st)))
                    (right (if (even? diff)
                               left
                               (make-string (+ 1 diff/2) (fmt-pad-char st)))))
               (output right (output str (output left st))))
             (output str st)))))))

(define (pad/right width . ls)
  (lambda (st)
    (let* ((col (fmt-col st))
           (padder
            (lambda (st)
              (let ((diff (- width (- (fmt-col st) col))))
                (if (positive? diff)
                    ((fmt-writer st) (make-string diff (fmt-pad-char st)) st)
                    st)))))
      ((cat (apply-cat ls) padder) st))))

(define (pad width . ls)
  (fmt-capture
   (apply-cat ls)
   (lambda (str)
     (lambda (st)
       (let* ((str-width ((or (fmt-string-width st) string-length) str))
              (diff (- width str-width)))
         ((fmt-writer st)
          str
          (if (positive? diff)
              ((fmt-writer st) (make-string diff (fmt-pad-char st)) st)
              st)))))))

(define (trim/buffered width fmt proc)
  (fmt-capture
   fmt
   (lambda (str)
     (lambda (st)
       (let* ((str-width ((or (fmt-string-width st) string-length) str))
              (diff (- str-width width)))
         ((fmt-writer st)
          (if (positive? diff)
              (proc str str-width diff st)
              str)
          st))))))

(define (trim width . ls)
  (lambda (st)
    (let ((ell (fmt-ellipses st)))
      (if ell
          ((trim/buffered
            width
            (apply-cat ls)
            (lambda (str str-width diff st)
              (let* ((ell (if (char? ell) (string ell) ell))
                     (ell-len (string-length ell))
                     (diff (- (+ str-width ell-len) width)))
                (if (negative? diff)
                    ell
                    (string-append
                     (substring/shared str 0 (- (string-length str) diff))
                     ell)))))
           st)
          (call-with-current-continuation
            (lambda (return)
              (let ((output (fmt-writer st)))
                (define (output* str st)
                  (let* ((len ((or (fmt-string-width st) string-length) str))
                         (diff (- (+ (fmt-col st) len) width)))
                    (if (positive? diff)
                        (return
                         (output (substring/shared str 0 (- len diff)) st))
                        (output str st))))
                ((fmt-let 'writer output* (apply-cat ls)) st))))))))

(define (trim/length width . ls)
  (lambda (st)
    (call-with-current-continuation
      (lambda (return)
        (let ((output (fmt-writer st))
              (sum 0))
          (define (output* str st)
            (let ((len (string-length str)))
              (set! sum (+ sum len))
              (if (> sum width)
                  (return
                   (output (substring/shared str 0 (- len (- sum width))) st))
                  (output str st))))
          ((fmt-let 'writer output* (apply-cat ls)) st))))))

(define (trim/left width . ls)
  (trim/buffered
   width
   (apply-cat ls)
   (lambda (str str-width diff st)
     (let ((ell (fmt-ellipses st)))
       (if ell
           (let* ((ell (if (char? ell) (string ell) ell))
                  (ell-len (string-length ell))
                  (diff (- (+ str-width ell-len) width)))
             (if (negative? diff)
                 ell
                 (string-append ell (substring/shared str diff))))
           (substring/shared str diff))))))

(define (trim/both width . ls)
  (trim/buffered
   width
   (apply-cat ls)
   (lambda (str str-width diff st)
     (let ((ell (fmt-ellipses st)))
       (if ell
           (let* ((ell (if (char? ell) (string ell) ell))
                  (ell-len (string-length ell))
                  (diff (- (+ str-width ell-len ell-len) width))
                  (left (quotient diff 2))
                  (right (- (string-length str) (quotient (+ diff 1) 2))))
             (if (negative? diff)
                 ell
                 (string-append ell (substring/shared str left right) ell)))
           (substring/shared str
                             (quotient (+ diff 1) 2)
                             (- (string-length str) (quotient diff 2))))))))

(define (fit width . ls) (pad/right width (trim width (apply-cat ls))))
(define (fit/left width . ls) (pad width (trim/left width (apply-cat ls))))
(define (fit/both width . ls)
  (pad/both width (trim/both width (apply-cat ls))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; String-map formatters

(define (make-string-fmt-transformer proc)
  (lambda ls
    (lambda (st)
      (let ((base-writer (fmt-writer st)))
        ((fmt-let
          'writer (lambda (str st) (base-writer (proc str) st))
          (apply-cat ls))
         st)))))

(define upcase (make-string-fmt-transformer string-upcase))
(define downcase (make-string-fmt-transformer string-downcase))
(define titlecase (make-string-fmt-transformer string-titlecase))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Numeric formatting

(define *min-e* -1024)
(define *bot-f* (expt 2 52))
;;(define *top-f* (* 2 *bot-f*))

(define (integer-log a base)
  (if (zero? a)
    0
    (inexact->exact (ceiling (/ (log (+ a 1)) (log base))))))
(define (integer-length* a)
  (if (negative? a)
    (integer-log (- 1 a) 2)
    (integer-log a 2)))

(define invlog2of
  (let ((table (make-vector 37))
        (log2 (log 2)))
    (do ((b 2 (+ b 1)))
        ((= b 37))
      (vector-set! table b (/ log2 (log b))))
    (lambda (b)
      (if (<= 2 b 36)
        (vector-ref table b)
        (/ log2 (log b))))))

(define fast-expt
  (let ((table (make-vector 326)))
    (do ((k 0 (+ k 1)) (v 1 (* v 10)))
        ((= k 326))
      (vector-set! table k v))
    (lambda (b k)
      (if (and (= b 10) (<= 0 k 326))
        (vector-ref table (inexact->exact (truncate k)))
        (expt b k)))))

(define (mirror-of c)
  (case c ((#\() #\)) ((#\[) #\]) ((#\{) #\}) ((#\<) #\>) (else c)))

;; General algorithm based on "Printing Floating-Point Numbers Quickly
;; and Accurately" by Burger and Dybvig (FP-Printing-PLDI96.pdf).  The
;; code below will be hard to read out of that context until it's
;; cleaned up.

(define (num->string n st . opt)
  (call-with-output-string
    (lambda (port)
      (let-optionals* opt
          ((base (fmt-radix st))
           (digits (fmt-precision st))
           (sign? #f)
           (commify? #f)
           (comma-sep (and commify? (fmt-ref st 'comma-char #\,)))
           (decimal-sep (or (fmt-decimal-sep st)
                            (if (eqv? comma-sep #\.) #\, #\.)))
           (comma-rule (if (eq? commify? #t) 3 commify?)))

        (define (write-positive n)

          (let* ((m+e (mantissa+exponent n))
                 (f (car m+e))
                 (e (cadr m+e))
                 (inv-base (invlog2of base))
                 (round? (even? f))
                 (smaller (if round? <= <))
                 (bigger (if round? >= >)))

            (define (write-digit d)
              (let ((d (inexact->exact (truncate d))))
                (write-char
                 (cond ((< d 10)
                        (integer->char (+ d (char->integer #\0))))
                       ((< d 36)
                        (integer->char (+ (- d 10) (char->integer #\A))))
                       (else (error "invalid digit: " d)))
                 port)))

            (define (pad d i) ;; just pad 0's, not #'s
              (write-digit d)
              (let lp ((i (- i 1)))
                (cond
                  ((>= i 0)
                   (if (and commify? (positive? i)
                            (zero? (modulo i comma-rule)))
                       (display comma-sep port))
                   (if (= i (- digits 1))
                       (display decimal-sep port))
                   (write-char #\0 port)
                   (lp (- i 1))))))

            (define (pad-all d i)
              (write-digit d)
              (let lp ((i (- i 1)))
                (cond
                  ((> i 0)
                   (if (and commify? (zero? (modulo i comma-rule)))
                       (display comma-sep port))
                   (write-char #\0 port)
                   (lp (- i 1)))
                  ((and (= i 0) (inexact? n))
                   (display decimal-sep port)
                   (write-digit 0)))))

            (define (pad-sci d i k)
              (write-digit d)
              (write-char #\e port)
              (cond
                ((positive? k)
                 (write-char #\+ port)
                 (write (- k 1) port))
                (else
                 (write k port))))

            (define (scale r s m+ m- k f e)
              (let ((est (inexact->exact
                          (ceiling (- (* (+ e (integer-length* f) -1)
                                         (invlog2of base))
                                      1.0e-10)))))
                (if (not (negative? est))
                    (fixup r (* s (fast-expt base est)) m+ m- est)
                    (let ((skale (fast-expt base (- est))))
                      (fixup (* r skale) s
                             (* m+ skale) (* m- skale) est)))))

            (define (fixup r s m+ m- k)
              (if (bigger (+ r m+) s)
                  (lead r s m+ m- (+ k 1))
                  (lead (* r base) s (* m+ base) (* m- base) k)))

            (define (lead r s m+ m- k)
              (cond
                ;;((and (not digits) (> k 14))
                ;; (generate-sci r s m+ m- k))
                ;;((and (not digits) (< k -4))
                ;; (if (>= (/ r s) base)
                ;;     (generate-sci (/ r base) s (/ m+ base) (/ m- base) k)
                ;;     (generate-sci r s m+ m- k)))
                ((and (not digits) (or (> k 14) (< k -4)))
                 (write n port))     ; XXXX using native write for now
                (else
                 (cond
                   ((and (not (positive? k)) (not (zero? n)))
                    (write-char #\0 port)
                    (display decimal-sep port)
                    (let lp ((i 0))
                      (cond
                        ((> i k)
                         (write-char #\0 port)
                         (lp (- i 1)))))))
                 (if digits
                     (generate-fixed r s m+ m- k)
                     (generate-all r s m+ m- k)))))

            (define (generate-all r s m+ m- k)
              (let gen ((r r) (m+ m+) (m- m-) (i k))
                (cond ((= i k))
                      ((zero? i)
                       (display decimal-sep port))
                      ((and commify?
                            (positive? i) (zero? (modulo i comma-rule)))
                       (display comma-sep port)))
                (let ((d (quotient r s))
                      (r (remainder r s)))
                  (if (not (smaller r m-))
                      (cond
                        ((not (bigger (+ r m+) s))
                         (write-digit d)
                         (gen (* r base) (* m+ base) (* m- base) (- i 1)))
                        (else (pad-all (+ d 1) i)))
                      (if (not (bigger (+ r m+) s))
                          (pad-all d i)
                          (pad-all (if (< (* r 2) s) d (+ d 1)) i))))))

            (define (generate-fixed r s m+ m- k)
              (let ((i0 (- (+ k digits) 1)))
                (let gen ((r r) (m+ m+) (m- m-) (i i0))
                  (cond ((= i i0))
                        ((= i (- digits 1))
                         (display decimal-sep port))
                        ((and commify? (> i (- digits 1))
                              (zero? (modulo (- i (- digits 1)) comma-rule)))
                         (display comma-sep port)))
                  (let ((d (quotient r s))
                        (r (remainder r s)))
                    (if (zero? i)
                        (write-digit (if (< (* r 2) s) d (+ d 1)))
                        (if (smaller r m-)
                            (if (bigger (+ r m+) s)
                                (pad (if (< (* r 2) s) d (+ d 1)) i)
                                (pad d i))
                            (if (bigger (+ r m+) s)
                                (pad (+ d 1) i)
                                (begin
                                  (write-digit d)
                                  (gen (* r base) (* m+ base)
                                       (* m- base) (- i 1))))))))))

            (define (generate-sci r s m+ m- k)
              (let gen ((r r) (m+ m+) (m- m-) (i k))
                (cond ((= i (- k 1)) (display decimal-sep port)))
                (let ((d (quotient r s))
                      (r (remainder r s)))
                  (if (not (smaller r m-))
                      (cond
                        ((not (bigger (+ r m+) s))
                         (write-digit d)
                         (gen (* r base) (* m+ base) (* m- base) (- i 1)))
                        (else (pad-sci (+ d 1) i k)))
                      (if (not (bigger (+ r m+) s))
                          (pad-sci d i k)
                          (pad-sci (if (< (* r 2) s) d (+ d 1)) i k))))))

            (if (negative? e)
                (if (or (= e *min-e*) (not (= f *bot-f*)))
                    (scale (* f 2) (* (expt 2 (- e)) 2) 1 1 0 f e)
                    (scale (* f 2 2) (* (expt 2 (- 1 e)) 2) 2 1 0 f e))
                (if (= f *bot-f*)
                    (let ((be (expt 2 e)))
                      (scale (* f be 2) 2 be be 0 f e))
                    (let* ((be (expt 2 e)) (be1 (* be 2)))
                      (scale (* f be1 2) (* 2 2) be1 be 0 f e))))))

        (define (write-real n sign?)
          (cond
            ((negative? n)
             (if (char? sign?)
                 (begin (display sign? port) (write-positive (abs n))
                        (display (mirror-of sign?) port))
                 (begin (write-char #\- port) (write-positive (abs n)))))
            (else
             (if (and sign? (not (char? sign?)))
                 (write-char #\+ port))
             (write-positive n))))

        (let ((imag (imag-part n)))
          (cond
            ((zero? imag)
             (cond
               ((and (not digits) (exact? n) (not (integer? n)))
                (write-real (numerator n) sign?)
                (write-char #\/ port)
                (write-real (denominator n) #f))
               (else
                (write-real n sign?))))
            (else (write-real imag sign?)
                  (write-real (real-part n) #t)
                  (write-char #\i port))))))))

(define (num n . opt)
  (lambda (st) ((fmt-writer st) (apply num->string n st opt) st)))

(define (num/comma n . o)
  (lambda (st)
    (let-optionals* o
        ((base (fmt-radix st))
         (digits (fmt-precision st))
         (sign? #f)
         (comma-rule 3)
         (comma-sep (fmt-ref st 'comma-char #\,))
         (decimal-sep (or (fmt-decimal-sep st)
                          (if (eqv? comma-sep #\.) #\, #\.))))
      ((num n base digits sign? comma-rule comma-sep decimal-sep) st))))

;; SI suffix formatting, as used in --human-readable options to some
;; GNU commands (such as ls).  See
;;
;;   http://www.bipm.org/en/si/si_brochure/chapter3/prefixes.html
;;   http://physics.nist.gov/cuu/Units/binary.html
;;
;; Note: lowercase "k" for base 10, uppercase "K" for base 2

(define num/si
  (let* ((names10 '#("" "k" "M" "G" "T" "E" "P" "Z" "Y"))
         (names2 (list->vector
                  (cons ""
                        (cons "Ki" (map (lambda (s) (string-append s "i"))
                                        (cddr (vector->list names10))))))))
    (lambda (n . o)
      (let-optionals* o ((base 1024)
                         (suffix "")
                         (names (if (= base 1024) names2 names10)))
        (let* ((k (min (inexact->exact (floor (/ (log n) (log base))))
                       (vector-length names)))
               (n2 (/ (round (* (/ n (expt 1024 k)) 10)) 10)))
          (cat (if (integer? n2)
                   (number->string (inexact->exact n2))
                   (exact->inexact n2))
               (vector-ref names k)
               (if (zero? k) "" suffix)))))))

;; Force a number into a fixed width, print as #'s if doesn't fit.
;; Needs to be wrapped in a PAD if you want to expand to the width.

(define (num/fit width n . args)
  (fmt-capture
   (apply num n args)
   (lambda (str)
     (lambda (st)
       (if (> (string-length str) width)
           (let ((prec (if (and (pair? args) (pair? (cdr args)))
                           (cadr args)
                           (fmt-precision st))))
             (if prec
                 (let* ((decimal-sep
                         (or (fmt-ref st 'decimal-sep)
                             (if (eqv? #\. (fmt-ref st 'comma-sep)) #\, #\.)))
                        (diff (- width (+ prec
                                          (if (char? decimal-sep)
                                              1
                                              (string-length decimal-sep))))))
                   ((cat (if (positive? diff) (make-string diff #\#) "")
                         decimal-sep (make-string prec #\#))
                    st))
                 ((fmt-writer st) (make-string width #\#) st)))
           ((fmt-writer st) str st))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; shared structure utilities

(define (eq?-table-ref tab x) (hash-table-ref/default tab x #f))
(define (eq?-table-set! tab x v) (hash-table-set! tab x v))

;; XXXX extend for records and other container data types
(define (make-shared-ref-table obj)
  (let ((tab (make-eq?-table))
        (res (make-eq?-table))
        (index 0))
    (let walk ((obj obj))
      (cond
        ((eq?-table-ref tab obj)
         => (lambda (i) (eq?-table-set! tab obj (+ i 1))))
        ((not (or (symbol? obj) (number? obj) (char? obj)
                  (boolean? obj) (null? obj) (eof-object? obj)))
         (eq?-table-set! tab obj 1)
         (cond
           ((pair? obj)
            (walk (car obj))
            (walk (cdr obj)))
           ((vector? obj)
            (let ((len (vector-length obj)))
              (do ((i 0 (+ i 1))) ((>= i len))
                (walk (vector-ref obj i)))))))))
    (hash-table-walk
     tab
     (lambda (obj count)
       (if (> count 1)
           (begin
             (eq?-table-set! res obj (cons index #f))
             (set! index (+ index 1))))))
    res))

(define (gen-shared-ref i suffix)
  (string-append "#" (number->string i) suffix))

(define (maybe-gen-shared-ref st cell shares)
  (cond
    ((pair? cell)
     (set-car! cell (cdr shares))
     (set-cdr! cell #t)
     (set-cdr! shares (+ (cdr shares) 1))
     ((fmt-writer st) (gen-shared-ref (car cell) "=") st))
    (else st)))

(define (call-with-shared-ref obj st shares proc)
  (let ((cell (eq?-table-ref (car shares) obj)))
    (if (and (pair? cell) (cdr cell))
        ((fmt-writer st) (gen-shared-ref (car cell) "#") st)
        (proc (maybe-gen-shared-ref st cell shares)))))

(define (call-with-shared-ref/cdr obj st shares proc sep)
  (let ((cell (eq?-table-ref (car shares) obj))
        (output (fmt-writer st)))
    (cond
      ((and (pair? cell) (cdr cell))
       (output (gen-shared-ref (car cell) "#") (output ". " (sep st))))
      ((pair? cell)
       (let ((st (maybe-gen-shared-ref (output ". " (sep st)) cell shares)))
         (output ")" (proc (output "(" st)))))
      (else
       (proc (sep st))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; sexp formatters

(define (slashified str . o)
  (let-optionals* o ((quot #\") (esc #\\) (rename (lambda (x) #f)))
    (lambda (st)
      (let* ((len (string-length str))
             (output (fmt-writer st))
             (quot-str (string quot))
             (esc-str (if (char? esc) (string esc) (or esc quot-str))))
        (let lp ((i 0) (j 0) (st st))
          (define (collect)
            (if (= i j) st (output (substring/shared str i j) st)))
          (if (>= j len)
              (collect)
              (let ((c (string-ref str j)))
                (cond
                  ((or (eqv? c quot) (eqv? c esc))
                   (lp j (+ j 1) (output esc-str (collect))))
                  ((rename c)
                   => (lambda (c2)
                        (lp (+ j 1)
                            (+ j 1)
                            (output c2 (output esc-str (collect))))))
                  (else
                   (lp i (+ j 1) st))))))))))

;; Only slashify if there are special characters, in which case also
;; wrap in quotes.  For writing symbols in |...| escapes, or CSV
;; fields, etc.  The predicate indicates which characters cause
;; slashification - this is in addition to automatic slashifying when
;; either the quote or escape char is present.

(define (maybe-slashified str pred . o)
  (let-optionals* o ((quot #\") (esc #\\) (rename (lambda (x) #f)))
    (define (esc? c) (or (eqv? c quot) (eqv? c esc) (rename c) (pred c)))
    (if (string-index str esc?)
        (cat quot (slashified str quot esc rename) quot)
        (dsp str))))

(define (fmt-write-string str)
  (define (rename c)
    (case c
      ((#\newline) "n")
      (else #f)))
  (slashified str #\" #\\ rename))

(define (dsp obj)
  (cond
    ((procedure? obj) obj)
    ((string? obj) (lambda (st) ((fmt-writer st) obj st)))
    ((char? obj) (dsp (string obj)))
    (else (wrt obj))))

(define (write-with-shares obj shares)
  (lambda (st)
    (let* ((output (fmt-writer st))
           (wr-num
            (cond ((and (= 10 (fmt-radix st))
                        (not (fmt-precision st)))
                   (lambda (n st) (output (number->string n) st)))
                  ((assq (fmt-radix st)
                         '((16 . "#x") (10 . "") (8 . "#o") (2 . "#b")))
                   => (lambda (cell)
                        (let ((prefix (cdr cell)))
                          (lambda (n st) ((num n) (output prefix st))))))
                  (else (lambda (n st) (output (number->string n) st))))))
      (let wr ((obj obj) (st st))
        (call-with-shared-ref obj st shares
          (lambda (st)
            (cond
              ((pair? obj)
               (output
                ")"
                (let lp ((ls obj)
                         (st (output "(" st)))
                  (let ((st (wr (car ls) st))
                        (rest (cdr ls)))
                    (cond
                      ((null? rest) st)
                      ((pair? rest)
                       (call-with-shared-ref/cdr rest st shares
                         (lambda (st) (lp rest st))
                         (dsp " ")))
                      (else (wr rest (output " . " st))))))))
              ((vector? obj)
               (let ((len (vector-length obj)))
                 (if (zero? len)
                     (output "#()" st)
                     (let lp ((i 1)
                              (st
                               (wr (vector-ref obj 0)
                                   (output "#(" st))))
                       (if (>= i len)
                           (output ")" st)
                           (lp (+ i 1)
                               (wr (vector-ref obj i)
                                   (output " " st))))))))
              ((string? obj)
               (output "\"" ((fmt-write-string obj) (output "\"" st))))
              ((number? obj)
               (wr-num obj st))
              ((boolean? obj)
               (output (if obj "#t" "#f") st))
              (else
               (output (write-to-string obj) st)))))))))

(define (wrt obj)
  (write-with-shares obj (cons (make-shared-ref-table obj) 0)))

;; the only expensive part, in both time and memory, of handling
;; shared structures when writing is building the initial table, so
;; for the efficient version we just skip that

(define (wrt/unshared obj)
  (write-with-shares obj (cons (make-eq?-table) 0)))

;;;; fmt-pretty.scm -- pretty printing format combinator
;;
;; Copyright (c) 2006-2007 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; additional settings

(define (fmt-shares st) (fmt-ref st 'shares))
(define (fmt-set-shares! st x) (fmt-set! st 'shares x))
(define (fmt-copy-shares st)
  (fmt-set-shares! (copy-fmt-state st) (copy-shares (fmt-shares st))))

(define (copy-shares shares)
  (let ((tab (make-eq?-table)))
    (hash-table-walk
     (car shares)
     (lambda (obj x) (eq?-table-set! tab obj (cons (car x) (cdr x)))))
    (cons tab (cdr shares))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; utilities

(define (fmt-shared-write obj proc)
  (lambda (st)
    (let* ((shares (fmt-shares st))
           (cell (and shares (eq?-table-ref (car shares) obj))))
      (if (pair? cell)
          (cond
            ((cdr cell)
             ((fmt-writer st) (gen-shared-ref (car cell) "#") st))
            (else
             (set-car! cell (cdr shares))
             (set-cdr! cell #t)
             (set-cdr! shares (+ (cdr shares) 1))
             (proc ((fmt-writer st) (gen-shared-ref (car cell) "=") st))))
          (proc st)))))

(define (join/shares fmt ls . o)
  (let ((sep (dsp (if (pair? o) (car o) " "))))
    (lambda (st)
      (let* ((shares (fmt-shares st))
             (tab (car shares))
             (output (fmt-writer st)))
        (let lp ((ls ls) (st st))
          (let ((st ((fmt (car ls)) st))
                (rest (cdr ls)))
            (cond
              ((null? rest) st)
              ((pair? rest)
               (call-with-shared-ref/cdr rest st shares
                   (lambda (st) (lp rest st))
                 sep))
              (else ((fmt rest) (output ". " (sep st)))))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; pretty printing

(define (non-app? x)
  (if (pair? x)
      (non-app? (car x))
      (not (symbol? x))))

(define syntax-abbrevs
  '((quote . "'") (quasiquote . "`") (unquote . ",") (unquote-splicing . ",@")
    ))

(define (pp-let ls)
  (if (and (pair? (cdr ls)) (symbol? (cadr ls)))
      (pp-with-indent 2 ls)
      (pp-with-indent 1 ls)))

(define indent-rules
  `((lambda . 1) (define . 1)
    (let . ,pp-let) (loop . ,pp-let)
    (let* . 1) (letrec . 1) (letrec* . 1) (and-let* . 1) (let1 . 2)
    (let-values . 1) (let*-values . 1) (receive . 2) (parameterize . 1)
    (let-syntax . 1) (letrec-syntax . 1) (syntax-rules . 1) (syntax-case . 2)
    (match . 1) (match-let . 1) (match-let* . 1)
    (if . 3) (when . 1) (unless . 1) (case . 1) (while . 1) (until . 1)
    (do . 2) (dotimes . 1) (dolist . 1) (test . 1)
    (condition-case . 1) (guard . 1) (rec . 1)
    (call-with-current-continuation . 0)
    ))

(define indent-prefix-rules
  `(("with-" . -1) ("call-with-" . -1) ("define-" . 1))
  )

(define indent-suffix-rules
  `(("-case" . 1))
  )

(define (pp-indentation form)
  (let ((indent
         (cond
           ((assq (car form) indent-rules) => cdr)
           ((and (symbol? (car form))
                 (let ((str (symbol->string (car form))))
                   (or (find (lambda (rx) (string-prefix? (car rx) str))
                             indent-prefix-rules)
                       (find (lambda (rx) (string-suffix? (car rx) str))
                             indent-suffix-rules))))
            => cdr)
           (else #f))))
    (if (and (number? indent) (negative? indent))
        (max 0 (- (+ (length+ form) indent) 1))
        indent)))

(define (pp-with-indent indent-rule ls)
  (lambda (st)
    (let* ((col1 (fmt-col st))
           (st ((cat "(" (pp-object (car ls))) st))
           (col2 (fmt-col st))
           (fixed (take* (cdr ls) (or indent-rule 1)))
           (tail (drop* (cdr ls) (or indent-rule 1)))
           (st2 (fmt-copy-shares st))
           (first-line
            ((fmt-to-string (cat " " (join/shares pp-flat fixed " "))) st2))
           (default
             (let ((sep (make-nl-space (+ col1 1))))
               (cat sep (join/shares pp-object (cdr ls) sep) ")"))))
      (if (< (+ col2 (string-length first-line)) (fmt-width st2))
          ;; fixed values on first line
          (let ((sep (make-nl-space
                      (if indent-rule (+ col1 2) (+ col2 1)))))
            ((cat first-line
                  (if (> (length+ (cdr ls)) (or indent-rule 1))
                      (cat sep (join/shares pp-object tail sep))
                      "")
                  ")")
             st2))
          (if indent-rule ;;(and indent-rule (not (pair? (car ls))))
              ;; fixed values lined up, body indented two spaces
              ((fmt-try-fit
                (lambda (st)
                  ((cat
                    " "
                    (join/shares pp-object fixed (make-nl-space (+ col2 1)))
                    (if (pair? tail)
                        (let ((sep (make-nl-space (+ col1 2))))
                          (cat sep (join/shares pp-object tail sep)))
                        "")
                    ")")
                   (fmt-copy-shares st)))
                default)
               st)
              ;; all on separate lines
              (default st))))))

(define (pp-app ls)
  (let ((indent-rule (pp-indentation ls)))
    (if (procedure? indent-rule)
        (indent-rule ls)
        (pp-with-indent indent-rule ls))))

;; the elements may be shared, just checking the top level list
;; structure
(define (proper-non-shared-list? ls shares)
  (let ((tab (car shares)))
    (let lp ((ls ls))
      (or (null? ls)
          (and (pair? ls)
               (not (eq?-table-ref tab ls))
               (lp (cdr ls)))))))

(define (pp-flat x)
  (cond
    ((pair? x)
     (fmt-shared-write
      x
      (cond
        ((and (pair? (cdr x)) (null? (cddr x))
              (assq (car x) syntax-abbrevs))
         => (lambda (abbrev)
              (cat (cdr abbrev) (pp-flat (cadr x)))))
        (else
         (cat "(" (join/shares pp-flat x) ")")))))
    ((vector? x)
     (fmt-shared-write x (cat "#(" (join pp-flat (vector->list x)) ")")))
    (else (lambda (st) ((write-with-shares x (fmt-shares st)) st)))))

(define (pp-pair ls)
  (fmt-shared-write
   ls
   (cond
     ;; one element list, no lines to break
     ((null? (cdr ls))
      (cat "(" (pp-object (car ls)) ")"))
     ;; quote or other abbrev
     ((and (pair? (cdr ls)) (null? (cddr ls))
           (assq (car ls) syntax-abbrevs))
      => (lambda (abbrev)
           (cat (cdr abbrev) (pp-object (cadr ls)))))
     (else
      (fmt-try-fit
       (lambda (st) ((pp-flat ls) (fmt-copy-shares st)))
       (lambda (st)
         (if (and (non-app? ls)
                  (proper-non-shared-list? ls (fmt-shares st)))
             ((pp-data-list ls) st)
             ((pp-app ls) st))))))))

(define (pp-data-list ls)
  (lambda (st)
    (let* ((output (fmt-writer st))
           (st (output "(" st))
           (col (fmt-col st))
           (width (- (fmt-width st) col))
           (st2 (fmt-copy-shares st)))
      (cond
        ((and (pair? (cdr ls)) (pair? (cddr ls)) (pair? (cdddr ls))
              ((fits-in-columns ls pp-flat width) st2))
         => (lambda (ls)
              ;; at least four elements which can be broken into columns
              (let* ((prefix (make-nl-space (+ col 1)))
                     (widest (+ 1 (car ls)))
                     (columns (quotient width widest))) ; always >= 2
                (let lp ((ls (cdr ls)) (st st2) (i 1))
                  (cond
                    ((null? ls)
                     (output ")" st))
                    ((null? (cdr ls))
                     (output ")" (output (car ls) st)))
                    (else
                     (let ((st (output (car ls) st)))
                       (if (>= i columns)
                           (lp (cdr ls) (output prefix st) 1)
                           (let* ((pad (- widest (string-length (car ls))))
                                  (st (output (make-space pad) st)))
                             (lp (cdr ls) st (+ i 1)))))))))))
        (else
         ;; no room, print one per line
         ((cat (join pp-object ls (make-nl-space col)) ")") st))))))

(define (pp-vector vec)
  (fmt-shared-write vec (cat "#" (pp-data-list (vector->list vec)))))

(define (pp-object obj)
  (cond
    ((pair? obj) (pp-pair obj))
    ((vector? obj) (pp-vector obj))
    (else (lambda (st) ((write-with-shares obj (fmt-shares st)) st)))))

(define (pretty obj)
  (fmt-bind 'shares (cons (make-shared-ref-table obj) 0)
            (cat (pp-object obj) fl)))

(define (pretty/unshared obj)
  (fmt-bind 'shares (cons (make-eq?-table) 0) (cat (pp-object obj) fl)))

;;;; fmt-block.scm -- columnar formatting
;;
;; Copyright (c) 2006-2007 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Columnar formatting
;;
;; A line-oriented formatter.  Takes a list of
;;   (line-fmt1 gen-fmt1 line-fmt2 gen-fmt2 ...)
;; and formats each of the gen-fmt1 formats as columns, printed
;; side-by-side, each line allowing post-processing done by line-fmt1
;; (just use dsp if you want to display the lines verbatim).

;; Continuations come to the rescue to make this work properly,
;; letting us weave the output between different columns without
;; needing to build up intermediate strings.

(define (fmt-columns . ls)
  (lambda (orig-st)
    (call-with-current-continuation
      (lambda (return)
        (define (infinite? x)
          (and (pair? x) (pair? (cdr x)) (pair? (cddr x)) (caddr x)))
        (let ((q1 '())
              (q2 '())
              (remaining (length (remove infinite? ls))))
          (define (enq! proc) (set! q2 (cons proc q2)))
          (define (deq!) (let ((proc (car q1))) (set! q1 (cdr q1)) proc))
          (define (line-init!) (set! q1 (reverse q2)) (set! q2 '()))
          (define (line-done?) (null? q1))
          (define (next cont)
            (enq! cont)
            (if (line-done?) 
                (cond
                  ((not (positive? remaining))
                   (return orig-st))
                  (else                 ; newline
                   (set! orig-st (nl orig-st))
                   (line-init!)
                   ((deq!) #f)))
                ((deq!) #f)))
          (define (make-empty-col fmt)
            (define (blank *ignored*)
              (set! orig-st ((fmt "") orig-st)) ; empty output
              (next blank))    ; infinite loop, next terminates for us
            blank)
          (define (make-col st fmt gen)
            (let ((acc '()))            ; buffer incomplete lines
              (lambda (*ignored*)
                (define (output* str st)
                  (let lp ((i 0))
                    (let ((nli (string-index str #\newline i)))
                      (cond
                        (nli
                         (let ((line
                                (string-concatenate-reverse
                                 (cons (substring/shared str i nli) acc))))
                           (set! acc '())
                           (set! orig-st ((fmt line) orig-st))
                           (call-with-current-continuation next) 
                           (lp (+ nli 1))))
                        (else
                         (set! acc (cons (substring/shared str i) acc))))))
                  ;; update - don't output or the string port will fill up
                  (fmt-update str st))
                ;; gen threads through it's own state, ignore result
                (gen (fmt-set-writer! (copy-fmt-state st) output*))
                ;; reduce # of remaining columns
                (set! remaining (- remaining 1))
                ;; (maybe) loop with an empty column in place
                (if (not (positive? remaining))
                    (return orig-st)
                    (next (make-empty-col fmt))))))
          ;; queue up the initial formatters
          (for-each
           (lambda (col)
             (let ((st (fmt-set-port! (copy-fmt-state orig-st)
                                      (open-output-string))))
               (enq! (make-col st (car col) (cat (cadr col) fl)))))
           ls)
          (line-init!)
          ;; start
          ((deq!) #f))))))

(define (columnar . ls)
  (define (proportional-width? w) (and (number? w) (< 0 w 1)))
  (define (build-column ls)
    (let-optionals* ls ((fixed-width #f)
                        (width #f)
                        (last? #t)
                        (tail '())
                        (gen #f)
                        (prefix '())
                        (align 'left)
                        (infinite? #f))
      (define (scale-width st)
        (max 1 (inexact->exact
                (truncate (* width (- (fmt-width st) fixed-width))))))
      (define (affix x)
        (cond
          ((pair? tail)
           (lambda (str)
             (cat (string-concatenate prefix)
                  (x str)
                  (string-concatenate tail))))
          ((pair? prefix)
           (lambda (str) (cat (string-concatenate prefix) (x str))))
          (else x)))
      (list
       ;; line formatter
       (affix
        (if (and last? (not (pair? tail)) (eq? align 'left))
            dsp
            (if (proportional-width? width)
                (case align
                  ((right)
                   (lambda (str) (lambda (st) ((pad (scale-width st) str) st))))
                  ((center)
                   (lambda (str) (lambda (st) ((pad/both (scale-width st) str) st))))
                  (else
                   (lambda (str) (lambda (st) ((pad/right (scale-width st) str) st)))))
                (case align
                  ((right) (lambda (str) (pad width str)))
                  ((center) (lambda (str) (pad/both width str)))
                  (else (lambda (str) (pad/right width str)))))))
       ;; generator
       (if (< 0 width 1)
           (lambda (st) ((with-width (scale-width st) gen) st))
           (with-width width gen))
       infinite?
       )))
  (define (adjust-widths ls border-width)
    (let* ((fixed-ls
            (filter (lambda (x) (and (number? (car x)) (>= (car x) 1))) ls))
           (fixed-total (fold + border-width (map car fixed-ls)))
           (scaled-ls (filter (lambda (x) (proportional-width? (car x))) ls))
           (rest
            (/ (- 1 (fold + 0 (map car scaled-ls)))
               (- (length ls) (+ (length fixed-ls) (length scaled-ls)) ))))
      (if (negative? rest)
          (error "fractional widths must sum to less than 1"
                 (map car scaled-ls)))
      (map
       (lambda (col)
         (cons fixed-total
               (if (not (number? (car col))) (cons rest (cdr col)) col)))
       ls)))
  (define (finish ls border-width)
    (apply fmt-columns
           (map build-column (adjust-widths (reverse ls) border-width))))
  (let lp ((ls ls) (strs '()) (align 'left) (infinite? #f)
           (width #t) (border-width 0) (res '()))
    (cond
      ((null? ls)
       (if (pair? strs)
           (finish (cons (cons (caar res)
                               (cons #t (cons (append (reverse strs)
                                                      (caddar res))
                                              (cdddar res))))
                         (cdr res))
                   border-width)
           (finish (cons (cons (caar res) (cons #t (cddar res))) (cdr res))
                   border-width)))
      ((string? (car ls))
       (if (string-index (car ls) #\newline)
           (error "column string literals can't contain newlines")
           (lp (cdr ls) (cons (car ls) strs) align infinite?
               width (+ border-width (string-length (car ls))) res)))
      ((number? (car ls))
       (lp (cdr ls) strs align infinite? (car ls) border-width res))
      ((eq? (car ls) 'infinite)
       (lp (cdr ls) strs align #t width border-width res))
      ((symbol? (car ls))
       (lp (cdr ls) strs (car ls) infinite? width border-width res))
      ((procedure? (car ls))
       (lp (cdr ls) '() 'left #f #t border-width
           (cons (list width #f '() (car ls) (reverse strs) align infinite?)
                 res)))
      (else
       (error "invalid column" (car ls))))))

;; break lines only, don't join short lines or justify
(define (fold-lines . ls)
  (lambda (st)
    (define output (fmt-writer st))
    (define (kons-in-line str st)
      (let ((len (string-length str))
            (space (- (fmt-width st) (fmt-col st))))
        (cond
          ((or (<= len space) (not (positive? space)))
           (output str st))
          (else
           (kons-in-line
            (substring/shared str space len)
            (output nl-str
                    (output (substring/shared str 0 space) st)))))))
    ((fmt-let
      'writer
      (lambda (str st)
        (let lp ((str str) (st st))
          (let ((nli (string-index str #\newline)))
            (cond
              ((not nli)
               (kons-in-line str st))
              (else
               (lp (substring/shared str (+ nli 1))
                   (output nl-str
                           (kons-in-line
                            (substring/shared str 0 nli)
                            st))))))))
      (apply-cat ls))
     st)))

(define (wrap-fold-words seq knil max-width get-width line . o)
  (let* ((last-line (if (pair? o) (car o) line))
         (vec (if (pair? seq) (list->vector seq) seq))
         (len (vector-length vec))
         (len-1 (- len 1))
         (breaks (make-vector len #f))
         (penalties (make-vector len #f))
         (widths
          (list->vector
           (map get-width (if (pair? seq) seq (vector->list seq))))))
    (define (largest-fit i)
      (let lp ((j (+ i 1)) (width (vector-ref widths i)))
        (let ((width (+ width 1 (vector-ref widths j))))
          (cond
            ((>= width max-width) (- j 1))
            ((>= j len-1) len-1)
            (else (lp (+ j 1) width))))))
    (define (min-penalty! i)
      (cond
        ((>= i len-1) 0)
        ((vector-ref penalties i))
        (else
         (vector-set! penalties i (expt (+ max-width 1) 3))
         (let ((k (largest-fit i)))
           (let lp ((j i) (width 0))
             (if (<= j k)
                 (let* ((width (+ width (vector-ref widths j)))
                        (break-penalty
                         (+ (max 0 (expt (- max-width (+ width (- j i))) 3))
                            (min-penalty! (+ j 1)))))
                   (cond
                     ((< break-penalty (vector-ref penalties i))
                      (vector-set! breaks i j)
                      (vector-set! penalties i break-penalty)))
                   (lp (+ j 1) width)))))
         (if (>= (vector-ref breaks i) len-1)
             (vector-set! penalties i 0))
         (vector-ref penalties i))))
    (define (sub-list i j)
      (let lp ((i i) (res '()))
        (if (> i j)
            (reverse res)
            (lp (+ i 1) (cons (vector-ref vec i) res)))))
    ;; compute optimum breaks
    (vector-set! breaks len-1 len-1)
    (vector-set! penalties len-1 0)
    (min-penalty! 0)
    ;; fold
    (let lp ((i 0) (acc knil))
      (let ((break (vector-ref breaks i)))
        (if (>= break len-1)
            (last-line (sub-list i len-1) acc)
            (lp (+ break 1) (line (sub-list i break) acc)))))))

;; XXXX don't split, traverse the string manually and keep track of
;; sentence endings so we can insert two spaces
(define (wrap-fold str . o)
  (apply wrap-fold-words (string-tokenize str) o))

(define (wrap-lines . ls)
  (define (print-line ls st)
    (nl ((join dsp ls " ") st)))
  (define buffer '())
  (lambda (st)
    ((fmt-let
      'writer
      (lambda (str st) (set! buffer (cons str buffer)) st)
      (apply-cat ls))
     st)
    (wrap-fold (string-concatenate-reverse buffer)
               st (fmt-width st) string-length print-line)))

(define (justify . ls)
  (lambda (st)
    (let ((width (fmt-width st))
          (output (fmt-writer st))
          (buffer '()))
      (define (justify-line ls st)
        (if (null? ls)
            (nl st)
            (let* ((sum (fold (lambda (s n) (+ n (string-length s))) 0 ls))
                   (len (length ls))
                   (diff (max 0 (- width sum)))
                   (sep (make-string (quotient diff (- len 1)) #\space))
                   (rem (remainder diff (- len 1))))
              (output
               (call-with-output-string
                 (lambda (p)
                   (display (car ls) p)
                   (let lp ((ls (cdr ls)) (i 1))
                     (cond
                       ((pair? ls)
                        (display sep p)
                        (if (<= i rem) (write-char #\space p))
                        (display (car ls) p)
                        (lp (cdr ls) (+ i 1)))))
                   (newline p)))
               st))))
      (define (justify-last ls st)
        (nl ((join dsp ls " ") st)))
      ((fmt-let
        'writer
        (lambda (str st) (set! buffer (cons str buffer)) st)
        (apply-cat ls))
       st)
      (wrap-fold (string-concatenate-reverse buffer)
                 st width string-length justify-line justify-last))))

(define (fmt-file path)
  (lambda (st)
    (call-with-input-file path
      (lambda (p)
        (let lp ((st st))
          (let ((line (read-line p)))
            (if (eof-object? line)
                st
                (lp (nl ((dsp line) st))))))))))

(define (line-numbers . o)
  (let ((start (if (pair? o) (car o) 1)))
    (join/range dsp start #f nl-str)))

)