Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-22 07:09:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

updating (chibi show) with srfi changes

Browse source
This commit is contained in:
Alex Shinn 2017-11-08 22:56:40 +09:00
parent bc3fa73ec4
commit 80c69291ba
8 changed files with 596 additions and 218 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

202
lib/chibi/show-test.sld
View file

@ -1,7 +1,9 @@
(define-library (chibi show-test) (define-library (chibi show-test)
(export run-tests) (export run-tests)
(import (scheme base) (scheme read) (chibi test) (import (scheme base) (scheme char) (scheme read)
(chibi show) (chibi show base) (chibi show pretty)) (chibi test)
(chibi show) (chibi show base)
(chibi show column) (chibi show pretty))
(begin (begin
(define-syntax test-pretty (define-syntax test-pretty
(syntax-rules () (syntax-rules ()
@ -144,6 +146,29 @@
(test "3.14+2.00i" (test "3.14+2.00i"
(show #f (with ((precision 2)) (string->number "3.14159+2i")))))) (show #f (with ((precision 2)) (string->number "3.14159+2i"))))))
(test "608" (show #f (numeric/si 608)))
(test "3.9Ki" (show #f (numeric/si 3986)))
(test "4kB" (show #f (numeric/si 3986 1000) "B"))
(test "1.2Mm" (show #f (numeric/si 1.23e6 1000) "m"))
(test "123km" (show #f (numeric/si 1.23e5 1000) "m"))
(test "12.3km" (show #f (numeric/si 1.23e4 1000) "m"))
(test "1.2km" (show #f (numeric/si 1.23e3 1000) "m"))
(test "123m" (show #f (numeric/si 1.23e2 1000) "m"))
(test "12.3m" (show #f (numeric/si 1.23e1 1000) "m"))
(test "1.2m" (show #f (numeric/si 1.23 1000) "m"))
(test "123mm" (show #f (numeric/si 0.123 1000) "m"))
(test "12.3mm" (show #f (numeric/si 1.23e-2 1000) "m")) ;?
(test "1.2mm" (show #f (numeric/si 1.23e-3 1000) "m"))
(test "123µm" (show #f (numeric/si 1.23e-4 1000) "m")) ;?
(test "12.3µm" (show #f (numeric/si 1.23e-5 1000) "m")) ;?
(test "1.2µm" (show #f (numeric/si 1.23e-6 1000) "m"))
(test "1,234,567" (show #f (numeric/comma 1234567)))
(test "1.23" (show #f (numeric/fitted 4 1.2345 10 2)))
(test "1.00" (show #f (numeric/fitted 4 1 10 2)))
(test "#.##" (show #f (numeric/fitted 4 12.345 10 2)))
;; padding/trimming ;; padding/trimming
(test "abc " (show #f (padded 5 "abc"))) (test "abc " (show #f (padded 5 "abc")))
@ -253,6 +278,14 @@
'(lions tigers . bears) '(lions tigers . bears)
", "))) ", ")))
;; escaping
(test "hi, bob!" (show #f (escaped "hi, bob!")))
(test "hi, \\\"bob!\\\"" (show #f (escaped "hi, \"bob!\"")))
(test "bob" (show #f (maybe-escaped "bob" char-whitespace?)))
(test "\"hi, bob!\""
(show #f (maybe-escaped "hi, bob!" char-whitespace?)))
;; shared structures ;; shared structures
(test "#0=(1 . #0#)" (test "#0=(1 . #0#)"
@ -317,15 +350,15 @@
wubbleflubbery)\n") wubbleflubbery)\n")
(test-pretty (test-pretty
"#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 "#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25
26 27 28 29 30 31 32 33 34 35 36 37)\n") 26 27 28 29 30 31 32 33 34 35 36 37)\n")
(test-pretty (test-pretty
"(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 "(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25
26 27 28 29 30 31 32 33 34 35 36 37)\n") 26 27 28 29 30 31 32 33 34 35 36 37)\n")
(test-pretty (test-pretty
"(#(0 1) #(2 3) #(4 5) #(6 7) #(8 9) #(10 11) #(12 13) #(14 15) "(#(0 1) #(2 3) #(4 5) #(6 7) #(8 9) #(10 11) #(12 13) #(14 15)
#(16 17) #(18 19))\n") #(16 17) #(18 19))\n")
(test-pretty (test-pretty
@ -389,4 +422,163 @@
(ones ',ones)) (ones ',ones))
(append zeros ones)))))) (append zeros ones))))))
;; columns
(test "abc\ndef\n"
(show #f (show-columns (list displayed "abc\ndef\n"))))
(test "abc123\ndef456\n"
(show #f (show-columns (list displayed "abc\ndef\n")
(list displayed "123\n456\n"))))
(test "abc123\ndef456\n"
(show #f (show-columns (list displayed "abc\ndef\n")
(list displayed "123\n456"))))
(test "abc123\ndef456\n"
(show #f (show-columns (list displayed "abc\ndef")
(list displayed "123\n456\n"))))
(test "abc123\ndef456\nghi789\n"
(show #f (show-columns (list displayed "abc\ndef\nghi\n")
(list displayed "123\n456\n789\n"))))
(test "abc123wuv\ndef456xyz\n"
(show #f (show-columns (list displayed "abc\ndef\n")
(list displayed "123\n456\n")
(list displayed "wuv\nxyz\n"))))
(test "abc 123\ndef 456\n"
(show #f (show-columns (list (lambda (x) (padded/right 5 x))
"abc\ndef\n")
(list displayed "123\n456\n"))))
(test "ABC 123\nDEF 456\n"
(show #f (show-columns (list (lambda (x) (upcased (padded/right 5 x)))
"abc\ndef\n")
(list displayed "123\n456\n"))))
(test "ABC 123\nDEF 456\n"
(show #f (show-columns (list (lambda (x) (padded/right 5 (upcased x)))
"abc\ndef\n")
(list displayed "123\n456\n"))))
(test "hello\nworld\n"
(show #f (with ((width 8)) (wrapped "hello world"))))
(test "\n" (show #f (wrapped " ")))
(test
"The quick
brown fox
jumped
over the
lazy dog
"
(show #f
(with ((width 10))
(justified "The quick brown fox jumped over the lazy dog"))))
(test
"The fundamental list iterator.
Applies KONS to each element of
LS and the result of the previous
application, beginning with KNIL.
With KONS as CONS and KNIL as '(),
equivalent to REVERSE.
"
(show #f
(with ((width 36))
(wrapped "The fundamental list iterator. Applies KONS to each element of LS and the result of the previous application, beginning with KNIL. With KONS as CONS and KNIL as '(), equivalent to REVERSE."))))
(test
"(define (fold kons knil ls)
(let lp ((ls ls) (acc knil))
(if (null? ls)
acc
(lp (cdr ls)
(kons (car ls) acc)))))
"
(show #f
(with ((width 36))
(pretty '(define (fold kons knil ls)
(let lp ((ls ls) (acc knil))
(if (null? ls)
acc
(lp (cdr ls)
(kons (car ls) acc)))))))))
'(test
"(define (fold kons knil ls) ; The fundamental list iterator.
(let lp ((ls ls) (acc knil)) ; Applies KONS to each element of
(if (null? ls) ; LS and the result of the previous
acc ; application, beginning with KNIL.
(lp (cdr ls) ; With KONS as CONS and KNIL as '(),
(kons (car ls) acc))))) ; equivalent to REVERSE.
"
(show #f
(show-columns
(list
(lambda (x) (padded/right 36 x))
(with ((width 36))
(pretty '(define (fold kons knil ls)
(let lp ((ls ls) (acc knil))
(if (null? ls)
acc
(lp (cdr ls)
(kons (car ls) acc))))))))
(list
(lambda (x) (each " ; " x))
(with ((width 36))
(wrapped "The fundamental list iterator. Applies KONS to each element of LS and the result of the previous application, beginning with KNIL. With KONS as CONS and KNIL as '(), equivalent to REVERSE."))))))
'(test
"(define (fold kons knil ls) ; The fundamental list iterator.
(let lp ((ls ls) (acc knil)) ; Applies KONS to each element of
(if (null? ls) ; LS and the result of the previous
acc ; application, beginning with KNIL.
(lp (cdr ls) ; With KONS as CONS and KNIL as '(),
(kons (car ls) acc))))) ; equivalent to REVERSE.
"
(show #f (with ((width 76))
(columnar
(pretty '(define (fold kons knil ls)
(let lp ((ls ls) (acc knil))
(if (null? ls)
acc
(lp (cdr ls)
(kons (car ls) acc))))))
" ; "
(wrapped "The fundamental list iterator. Applies KONS to each element of LS and the result of the previous application, beginning with KNIL. With KONS as CONS and KNIL as '(), equivalent to REVERSE.")))))
(test
"- Item 1: The text here is
indented according
to the space \"Item
1\" takes, and one
does not known what
goes here.
"
(show #f (columnar 9 (each "- Item 1:") " " (with ((width 20)) (wrapped "The text here is indented according to the space \"Item 1\" takes, and one does not known what goes here.")))))
(test
"- Item 1: The text here is
indented according
to the space \"Item
1\" takes, and one
does not known what
goes here.
"
(show #f (columnar 9 (each "- Item 1:\n") " " (with ((width 20)) (wrapped "The text here is indented according to the space \"Item 1\" takes, and one does not known what goes here.")))))
(test
"- Item 1: The-text-here-is----------------------------------------------------
--------- indented-according--------------------------------------------------
--------- to-the-space-\"Item--------------------------------------------------
--------- 1\"-takes,-and-one---------------------------------------------------
--------- does-not-known-what-------------------------------------------------
--------- goes-here.----------------------------------------------------------
"
(show #f (with ((pad-char #\-)) (columnar 9 (each "- Item 1:\n") " " (with ((width 20)) (wrapped "The text here is indented according to the space \"Item 1\" takes, and one does not known what goes here."))))))
(test
"a | 123
bc | 45
def | 6
"
(show #f (with ((width 20))
(tabular (each "a\nbc\ndef\n") " | "
(each "123\n45\n6\n")))))
(test-end)))) (test-end))))

5
lib/chibi/show.sld
View file

@ -2,8 +2,9 @@
(define-library (chibi show) (define-library (chibi show)
(export (export
show fn fn-fork with update! each each-in-list call-with-output show fn fn-fork with update! each each-in-list call-with-output
displayed written written-shared written-simply numeric nothing displayed written written-shared written-simply
nl fl space-to tab-to numeric numeric/comma numeric/si numeric/fitted
nothing nl fl space-to tab-to escaped maybe-escaped
padded padded/left padded/right padded/both padded padded/left padded/right padded/both
trimmed trimmed/left trimmed/right trimmed/both trimmed/lazy trimmed trimmed/left trimmed/right trimmed/both trimmed/lazy
fitted fitted/left fitted/right fitted/both fitted fitted/left fitted/right fitted/both

19
lib/chibi/show/base.sld
View file

@ -3,10 +3,29 @@
(export (export
show fn fn-fork with update! each each-in-list call-with-output show fn fn-fork with update! each each-in-list call-with-output
displayed written written-shared written-simply numeric nothing displayed written written-shared written-simply numeric nothing
escaped maybe-escaped numeric/si numeric/fitted numeric/comma
;; internal ;; internal
output-default extract-shared-objects write-to-string write-with-shares output-default extract-shared-objects write-to-string write-with-shares
call-with-shared-ref call-with-shared-ref/cdr) call-with-shared-ref call-with-shared-ref/cdr)
(import (scheme base) (scheme write) (scheme complex) (scheme inexact) (import (scheme base) (scheme write) (scheme complex) (scheme inexact)
(srfi 1) (srfi 69) (chibi string) (chibi monad environment)) (srfi 1) (srfi 69) (chibi string) (chibi monad environment))
(cond-expand
(chibi
(import (only (chibi) let-optionals*)))
(else
(begin
(define-syntax let-optionals*
(syntax-rules ()
((let-optionals* opt-ls () . body)
(begin . body))
((let-optionals* (op . args) vars . body)
(let ((tmp (op . args)))
(let-optionals* tmp vars . body)))
((let-optionals* tmp ((var default) . rest) . body)
(let ((var (if (pair? tmp) (car tmp) default))
(tmp2 (if (pair? tmp) (cdr tmp) '())))
(let-optionals* tmp2 rest . body)))
((let-optionals* tmp tail . body)
(let ((tail tmp)) . body)))))))
(include "base.scm") (include "base.scm")
(include "write.scm")) (include "write.scm"))

83
lib/chibi/show/column.scm
View file

@ -2,6 +2,20 @@
;; Copyright (c) 2006-2017 Alex Shinn. All rights reserved. ;; Copyright (c) 2006-2017 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt ;; BSD-style license: http://synthcode.com/license.txt
(define (string-split-words str separator?)
(let ((start (string-cursor-start str))
(end (string-cursor-end str)))
(let lp ((sc start) (res '()))
(cond
((string-cursor>=? sc end)
(reverse res))
(else
(let ((sc2 (string-index str separator? sc)))
(lp (string-cursor-next str sc2)
(if (string-cursor=? sc sc2)
res
(cons (substring/cursors str sc sc2) res)))))))))
(define (call-with-output-generator producer consumer) (define (call-with-output-generator producer consumer)
(fn () (fn ()
(let ((out (open-output-string)) (let ((out (open-output-string))
@ -12,10 +26,18 @@
(define (output* str) (define (output* str)
(fn (row col string-width) (fn (row col string-width)
(list-queue-add-back! queue str) (list-queue-add-back! queue str)
(call-with-current-continuation (each
(lambda (cc) (let ((nl-index
(set! resume cc) (string-index-right str (lambda (ch) (eqv? ch #\newline)))))
(return nothing))) (if (string-cursor>? nl-index (string-cursor-start str))
(update!
(row (+ row (string-count str (lambda (ch) (eqv? ch #\newline)))))
(col (string-width str (string-cursor->index str nl-index))))
(update! (col (+ col (string-width str))))))
(call-with-current-continuation
(lambda (cc)
(set! resume cc)
(return nothing))))
nothing)) nothing))
(define (generate) (define (generate)
(if (and resume (list-queue-empty? queue)) (if (and resume (list-queue-empty? queue))
@ -27,13 +49,13 @@
eof eof
(list-queue-remove-front! queue))) (list-queue-remove-front! queue)))
(fn-fork (fn () (with ((port out) (output output*)) (fn-fork (fn () (with ((port out) (output output*))
(call-with-current-continuation (call-with-current-continuation
(lambda (cc) (lambda (cc)
(set! return cc) (set! return cc)
(each producer (each producer
(fn (output) (fn (output)
(set! resume #f) (set! resume #f)
(fn () (return nothing) nothing))))))) (fn () (return nothing) nothing)))))))
(consumer generate))))) (consumer generate)))))
(define (call-with-output-generators producers consumer) (define (call-with-output-generators producers consumer)
@ -320,6 +342,10 @@
(fn () (lp (string-cursor-next str nli)))))))))))) (fn () (lp (string-cursor-next str nli))))))))))))
(each-in-list ls)))) (each-in-list ls))))
;; `seq' is a list or vector of pre-tokenized words. `line' is called
;; on each wrapped line and the accumulator, starting with `knil'.
;; The optional `last-line' is used instead on the last line of the
;; paragraph.
(define (wrap-fold-words seq knil max-width get-width line . o) (define (wrap-fold-words seq knil max-width get-width line . o)
(let* ((last-line (if (pair? o) (car o) line)) (let* ((last-line (if (pair? o) (car o) line))
(vec (if (list? seq) (list->vector seq) seq)) (vec (if (list? seq) (list->vector seq) seq))
@ -380,21 +406,21 @@
(last-line (sub-list i len-1) acc) (last-line (sub-list i len-1) acc)
(lp (+ break 1) (line (sub-list i break) acc))))))))) (lp (+ break 1) (line (sub-list i break) acc)))))))))
;; XXXX don't split, traverse the string manually and keep track of (define (wrapped/list ls)
;; sentence endings so we can insert two spaces (fn (width string-width pad-char)
(define (wrap-fold str . o) (joined/suffix
(apply wrap-fold-words (string-split str " ") o)) (lambda (ls) (joined displayed ls pad-char))
(reverse
(wrap-fold-words ls '() width (or string-width string-length) cons))
"\n")))
(define (wrapped . ls) (define (wrapped . ls)
(call-with-output (call-with-output
(each-in-list ls) (each-in-list ls)
(lambda (str) (lambda (str)
(fn (width string-width pad-char) (fn (word-separator?)
(joined/suffix (wrapped/list
(lambda (ls) (joined displayed ls pad-char)) (string-split-words str (or word-separator? char-whitespace?)))))))
(reverse
(wrap-fold str '() width (or string-width string-length) cons))
"\n")))))
(define (justified . ls) (define (justified . ls)
(fn (output width string-width) (fn (output width string-width)
@ -427,11 +453,16 @@
(call-with-output (call-with-output
(each-in-list ls) (each-in-list ls)
(lambda (str) (lambda (str)
(joined/last (fn (word-separator?)
justify-line (joined/last
justify-last justify-line
(reverse (wrap-fold str '() width string-width cons)) justify-last
"\n"))))) (reverse
(wrap-fold-words
(string-split-words str (or word-separator? char-whitespace?))
'() width (or string-width string-length)
cons))
"\n"))))))
(define (from-file path) (define (from-file path)
(fn () (fn ()

3
lib/chibi/show/column.sld
View file

@ -6,5 +6,6 @@
(export (export
call-with-output-generator call-with-output-generators call-with-output-generator call-with-output-generators
string->line-generator string->line-generator
columnar tabular wrapped wrapped/char justified line-numbers from-file) tabular columnar show-columns wrapped wrapped/list wrapped/char
justified line-numbers from-file)
(include "column.scm")) (include "column.scm"))

4
lib/chibi/show/pretty.scm
View file

@ -42,7 +42,7 @@
(string-find str pred (string-index->cursor str i)))) (string-find str pred (string-index->cursor str i))))
(define (try-fitted2 proc fail) (define (try-fitted2 proc fail)
(fn (width string-width output) (fn (width output)
(let ((out (open-output-string))) (let ((out (open-output-string)))
(call-with-current-continuation (call-with-current-continuation
(lambda (abort) (lambda (abort)
@ -53,7 +53,7 @@
(fn (col) (fn (col)
(let lp ((i 0) (col col)) (let lp ((i 0) (col col))
(let ((nli (string-find/index str #\newline i)) (let ((nli (string-find/index str #\newline i))
(len (string-width str))) (len (string-length str)))
(if (< nli len) (if (< nli len)
(if (> (+ (- nli i) col) width) (if (> (+ (- nli i) col) width)
(abort fail) (abort fail)

2
lib/chibi/show/show.scm
View file

@ -1,5 +1,5 @@
;; show.scm -- additional combinator formatters ;; show.scm -- additional combinator formatters
;; Copyright (c) 2013 Alex Shinn. All rights reserved. ;; Copyright (c) 2013-2017 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt ;; BSD-style license: http://synthcode.com/license.txt
;;> A library of procedures for formatting Scheme objects to text in ;;> A library of procedures for formatting Scheme objects to text in

496
lib/chibi/show/write.scm
View file

@ -30,6 +30,64 @@
(if (pair? rule) (cdr rule) rule) (if (pair? rule) (cdr rule) rule)
(cons sep (cons (substring str i2 i) res))))))) (cons sep (cons (substring str i2 i) res)))))))
;;> Outputs the string str, escaping any quote or escape characters.
;;> If esc-ch, which defaults to #\\, is #f, escapes only the
;;> quote-ch, which defaults to #\", by doubling it, as in SQL strings
;;> and CSV values. If renamer is provided, it should be a procedure
;;> of one character which maps that character to its escape value,
;;> e.g. #\newline => #\n, or #f if there is no escape value.
(define (escaped fmt . o)
(let-optionals* o ((quot #\")
(esc #\\)
(rename (lambda (x) #f)))
(let ((quot-str (if (char? quot) (string quot) quot))
(esc-str (if (char? esc) (string esc) esc)))
(fn (output)
(define (output* str)
(let ((start (string-cursor-start str))
(end (string-cursor-end str)))
(let lp ((i start) (j start))
(define (collect)
(if (eq? i j) "" (substring-cursor str i j)))
(if (string-cursor>=? j end)
(output (collect))
(let ((c (string-cursor-ref str j))
(j2 (string-cursor-next str j)))
(cond
((or (eqv? c quot) (eqv? c esc))
(each (output (collect))
(output esc-str)
(fn () (lp j j2))))
((rename c)
=> (lambda (c2)
(each (output (collect))
(output esc-str)
(output (if (char? c2) (string c2) c2))
(fn () (lp j2 j2)))))
(else
(lp i j2))))))))
(with ((output output*))
fmt)))))
;;> Only escape 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-escaped fmt 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)))
(call-with-output
fmt
(lambda (str)
(if (string-cursor<? (string-find str esc?) (string-cursor-end str))
(each quot (escaped str quot esc rename) quot)
(displayed str))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; numeric formatting ;; numeric formatting
@ -47,189 +105,265 @@
;; special cases, so the below is a simplification which tries to rely ;; special cases, so the below is a simplification which tries to rely
;; on number->string for common cases. ;; on number->string for common cases.
(define (numeric n) (define unspec (list 'unspecified))
(fn (radix precision decimal-sep decimal-align comma-rule comma-sep sign-rule)
(let ((dec-sep (or decimal-sep (if (eqv? comma-sep #\.) #\, #\.)))) (define-syntax default
;; General formatting utilities. (syntax-rules ()
(define (get-scale q) ((default var dflt) (if (eq? var unspec) dflt var))))
(expt radix (- (integer-log q radix) 1)))
(define (char-digit d) (define (numeric n . o)
(cond ((char? d) d) (let-optionals* o ((rad unspec) (prec unspec) (sgn unspec)
((< d 10) (integer->char (+ d (char->integer #\0)))) (comma unspec) (commasep unspec) (decsep unspec))
(else (integer->char (+ (- d 10) (char->integer #\a)))))) (fn (radix precision sign-rule
(define (digit-value ch) comma-rule comma-sep decimal-sep decimal-align)
(let ((res (- (char->integer ch) (char->integer #\0)))) (let ((radix (default rad radix))
(if (<= 0 res 9) (precision (default prec precision))
res (sign-rule (default sgn sign-rule))
ch))) (comma-rule (default comma comma-rule))
(define (round-up ls) (comma-sep (default comma-sep commasep))
(let lp ((ls ls) (res '())) (dec-sep (default decsep
(cond (or decimal-sep (if (eqv? comma-sep #\.) #\, #\.)))))
((null? ls) ;; General formatting utilities.
(cons 1 res)) (define (get-scale q)
((not (number? (car ls))) (expt radix (- (integer-log q radix) 1)))
(lp (cdr ls) (cons (car ls) res))) (define (char-digit d)
((= (car ls) (- radix 1)) (cond ((char? d) d)
(lp (cdr ls) (cons 0 res))) ((< d 10) (integer->char (+ d (char->integer #\0))))
(else (else (integer->char (+ (- d 10) (char->integer #\a))))))
(append (reverse res) (cons (+ 1 (car ls)) (cdr ls))))))) (define (digit-value ch)
(define (maybe-round n d ls) (let ((res (- (char->integer ch) (char->integer #\0))))
(let* ((q (quotient n d)) (if (<= 0 res 9)
(digit (* 2 (if (>= q radix) (quotient q (get-scale q)) q)))) res
(if (or (> digit radix) ch)))
(and (= digit radix) (define (round-up ls)
(let ((prev (find integer? ls))) (let lp ((ls ls) (res '()))
(and prev (odd? prev)))))
(round-up ls)
ls)))
(define (maybe-trim-zeros i res)
(if (and (not precision) (positive? i))
(let lp ((res res))
(cond
((and (pair? res) (eqv? 0 (car res))) (lp (cdr res)))
((and (pair? res) (eqv? dec-sep (car res))) (cdr res))
(else res)))
res))
;; General slow loop to generate digits one at a time, for
;; non-standard radixes or writing rationals with a fixed
;; precision.
(define (gen-general n)
(let* ((p (exact n))
(n (numerator p))
(d (denominator p)))
(let lp ((n n)
(i (- (integer-log p radix)))
(res '()))
(cond (cond
;; Use a fixed precision if specified, otherwise generate ((null? ls)
;; 15 decimals. (cons 1 res))
((if precision (< i precision) (< i 16)) ((not (number? (car ls)))
(let ((res (if (zero? i) (lp (cdr ls) (cons (car ls) res)))
(cons dec-sep (if (null? res) (cons 0 res) res)) ((= (car ls) (- radix 1))
res)) (lp (cdr ls) (cons 0 res)))
(q (quotient n d))) (else
(append (reverse res) (cons (+ 1 (car ls)) (cdr ls)))))))
(define (maybe-round n d ls)
(let* ((q (quotient n d))
(digit (* 2 (if (>= q radix) (quotient q (get-scale q)) q))))
(if (or (> digit radix)
(and (= digit radix)
(let ((prev (find integer? ls)))
(and prev (odd? prev)))))
(round-up ls)
ls)))
(define (maybe-trim-zeros i res)
(if (and (not precision) (positive? i))
(let lp ((res res))
(cond (cond
((>= q radix) ((and (pair? res) (eqv? 0 (car res))) (lp (cdr res)))
(let* ((scale (get-scale q)) ((and (pair? res) (eqv? dec-sep (car res))) (cdr res))
(digit (quotient q scale)) (else res)))
(n2 (- n (* d digit scale)))) res))
(lp n2 (+ i 1) (cons digit res)))) ;; General slow loop to generate digits one at a time, for
(else ;; non-standard radixes or writing rationals with a fixed
(lp (* (remainder n d) radix) ;; precision.
(+ i 1) (define (gen-general n)
(cons q res)))))) (let* ((p (exact n))
(else (n (numerator p))
(list->string (d (denominator p)))
(map char-digit (let lp ((n n)
(reverse (maybe-round n d (maybe-trim-zeros i res)))))))))) (i (- (integer-log p radix)))
;; Generate a fixed precision decimal result by post-editing the (res '()))
;; result of string->number. (cond
(define (gen-fixed n) ;; Use a fixed precision if specified, otherwise generate
(cond ;; 15 decimals.
((and (eqv? radix 10) (or (integer? n) (inexact? n))) ((if precision (< i precision) (< i 16))
(let* ((s (number->string n)) (let ((res (if (zero? i)
(end (string-cursor-end s)) (cons dec-sep (if (null? res) (cons 0 res) res))
(dec (string-find s #\.)) res))
(digits (- (string-cursor->index s end) (q (quotient n d)))
(string-cursor->index s dec)))) (cond
(cond ((>= q radix)
((string-cursor<? (string-find s #\e) end) (let* ((scale (get-scale q))
(gen-general n)) (digit (quotient q scale))
((string-cursor=? dec end) (n2 (- n (* d digit scale))))
(string-append s "." (make-string precision #\0))) (lp n2 (+ i 1) (cons digit res))))
((<= digits precision) (else
(string-append s (make-string (- precision digits -1) #\0))) (lp (* (remainder n d) radix)
(else (+ i 1)
(let* ((last (cons q res))))))
(string-cursor-back s end (- digits precision 1))) (else
(res (substring-cursor s (string-cursor-start s) last))) (list->string
(if (and (map char-digit
(string-cursor<? last end) (reverse (maybe-round n d (maybe-trim-zeros i res))))))))))
(let ((next (digit-value (string-cursor-ref s last)))) ;; Generate a fixed precision decimal result by post-editing the
(or (> next 5) ;; result of string->number.
(and (= next 5) (define (gen-fixed n)
(string-cursor>? last (string-cursor-start s)) (cond
(odd? (digit-value ((and (eqv? radix 10) (or (integer? n) (inexact? n)))
(string-cursor-ref (let* ((s (number->string n))
s (string-cursor-prev last 1)))))))) (end (string-cursor-end s))
(list->string (dec (string-find s #\.))
(reverse (digits (- (string-cursor->index s end)
(map char-digit (string-cursor->index s dec))))
(round-up (cond
(reverse (map digit-value (string->list res))))))) ((string-cursor<? (string-find s #\e) end)
res)))))) (gen-general n))
(else ((string-cursor=? dec end)
(gen-general n)))) (string-append s "." (make-string precision #\0)))
;; Generate any unsigned real number. ((<= digits precision)
(define (gen-positive-real n) (string-append s (make-string (- precision digits -1) #\0)))
(cond (else
(precision (let* ((last
(gen-fixed n)) (string-cursor-back s end (- digits precision 1)))
((and (exact? n) (not (integer? n))) (res (substring-cursor s (string-cursor-start s) last)))
(string-append (number->string (numerator n) radix) (if (and
"/" (string-cursor<? last end)
(number->string (denominator n) radix))) (let ((next (digit-value (string-cursor-ref s last))))
((memv radix (if (exact? n) '(2 8 10 16) '(10))) (or (> next 5)
(number->string n)) (and (= next 5)
(else (string-cursor>? last (string-cursor-start s))
(gen-general n)))) (odd? (digit-value
;; Insert commas according to the current comma-rule. (string-cursor-ref
(define (insert-commas str) s (string-cursor-prev s last))))))))
(let* ((dec-pos (string-find str dec-sep)) (list->string
(left (substring-cursor str (string-cursor-start str) dec-pos)) (reverse
(right (substring-cursor str dec-pos)) (map char-digit
(sep (cond ((char? comma-sep) (string comma-sep)) (round-up
((string? comma-sep) comma-sep) (reverse (map digit-value (string->list res)))))))
((eqv? #\, dec-sep) ".") res))))))
(else ",")))) (else
(string-append (gen-general n))))
(string-intersperse-right left sep comma-rule) ;; Generate any unsigned real number.
right))) (define (gen-positive-real n)
;; Post-process a positive real number with decimal char fixup (cond
;; and commas as needed. (precision
(define (wrap-comma n) (gen-fixed n))
(let* ((s0 (gen-positive-real n)) ((and (exact? n) (not (integer? n)))
(s1 (if (and (char? dec-sep) (string-append (number->string (numerator n) radix)
(not (eqv? #\. dec-sep))) "/"
(string-replace-all s0 #\. dec-sep) (number->string (denominator n) radix)))
s0))) ((memv radix (if (exact? n) '(2 8 10 16) '(10)))
(if comma-rule (insert-commas s1) s1))) (number->string n))
;; Wrap the sign of a real number, forcing a + prefix or using (else
;; parentheses (n) for negatives according to sign-rule. (gen-general n))))
(define (wrap-sign n sign-rule) ;; Insert commas according to the current comma-rule.
(cond (define (insert-commas str)
((negative? n) (let* ((dec-pos (string-find str dec-sep))
(if (char? sign-rule) (left (substring-cursor str (string-cursor-start str) dec-pos))
(string-append (string sign-rule) (right (substring-cursor str dec-pos))
(wrap-comma (abs n)) (sep (cond ((char? comma-sep) (string comma-sep))
(string (char-mirror sign-rule))) ((string? comma-sep) comma-sep)
(string-append "-" (wrap-comma (abs n))))) ((eqv? #\, dec-sep) ".")
((eq? #t sign-rule) (else ","))))
(string-append "+" (wrap-comma n))) (string-append
(else (string-intersperse-right left sep comma-rule)
(wrap-comma n)))) right)))
;; Format a single real number with padding as necessary. ;; Post-process a positive real number with decimal char fixup
(define (format n sign-rule) ;; and commas as needed.
(let ((s (wrap-sign n sign-rule))) (define (wrap-comma n)
(let* ((dec-pos (if decimal-align (let* ((s0 (gen-positive-real n))
(string-cursor->index s (string-find s dec-sep)) (s1 (if (and (char? dec-sep)
0)) (not (eqv? #\. dec-sep)))
(diff (- (or decimal-align 0) dec-pos 1))) (string-replace-all s0 #\. dec-sep)
(if (positive? diff) s0)))
(string-append (make-string diff #\space) s) (if comma-rule (insert-commas s1) s1)))
s)))) ;; Wrap the sign of a real number, forcing a + prefix or using
;; Write any number. ;; parentheses (n) for negatives according to sign-rule.
(define (write-complex n) (define (wrap-sign n sign-rule)
(cond (cond
((and radix (not (and (integer? radix) (<= 2 radix 36)))) ((negative? n)
(error "invalid radix for numeric formatting" radix)) (if (char? sign-rule)
((zero? (imag-part n)) (string-append (string sign-rule)
(displayed (format (real-part n) sign-rule))) (wrap-comma (abs n))
(else (string (char-mirror sign-rule)))
(each (format (real-part n) sign-rule) (string-append "-" (wrap-comma (abs n)))))
(format (imag-part n) #t) ((eq? #t sign-rule)
"i")))) (string-append "+" (wrap-comma n)))
(write-complex n)))) (else
(wrap-comma n))))
;; Format a single real number with padding as necessary.
(define (format n sign-rule)
(let ((s (wrap-sign n sign-rule)))
(let* ((dec-pos (if decimal-align
(string-cursor->index s (string-find s dec-sep))
0))
(diff (- (or decimal-align 0) dec-pos 1)))
(if (positive? diff)
(string-append (make-string diff #\space) s)
s))))
;; Write any number.
(define (write-complex n)
(cond
((and radix (not (and (integer? radix) (<= 2 radix 36))))
(error "invalid radix for numeric formatting" radix))
((zero? (imag-part n))
(displayed (format (real-part n) sign-rule)))
(else
(each (format (real-part n) sign-rule)
(format (imag-part n) #t)
"i"))))
(write-complex n)))))
(define numeric/si
(let* ((names10 '#("" "k" "M" "G" "T" "E" "P" "Z" "Y"))
(names-10 '#("" "m" "µ" "n" "p" "f" "a" "z" "y"))
(names2 (list->vector
(cons ""
(cons "Ki" (map (lambda (s) (string-append s "i"))
(cddr (vector->list names10)))))))
(names-2 (list->vector
(cons ""
(map (lambda (s) (string-append s "i"))
(cdr (vector->list names-10)))))))
(define (round-to n k)
(/ (round (* n k)) k))
(lambda (n . o)
(let-optionals* o ((base 1024)
(separator ""))
(let* ((log-n (log n))
(names (if (negative? log-n)
(if (= base 1024) names-2 names-10)
(if (= base 1024) names2 names10)))
(k (min (exact ((if (negative? log-n) ceiling floor)
(/ (abs log-n) (log base))))
(vector-length names)))
(n2 (round-to (/ n (expt base (if (negative? log-n) (- k) k)))
10)))
(each (if (integer? n2)
(number->string (exact n2))
(inexact n2))
(if (zero? k) "" separator)
(vector-ref names k)))))))
;; Force a number into a fixed width, print as #'s if doesn't fit.
;; Needs to be wrapped in PADDED if you want to expand to the width.
(define (numeric/fitted width n . args)
(call-with-output
(apply numeric n args)
(lambda (str)
(if (> (string-length str) width)
(fn (precision decimal-sep comma-sep)
(let ((prec (if (and (pair? args) (pair? (cdr args)))
(cadr args)
precision)))
(if prec
(let* ((dec-sep
(or decimal-sep
(if (eqv? #\. comma-sep) #\, #\.)))
(diff (- width (+ prec
(if (char? dec-sep)
1
(string-length dec-sep))))))
(each (if (positive? diff) (make-string diff #\#) "")
dec-sep (make-string prec #\#)))
(displayed (make-string width #\#)))))
(displayed str)))))
(define (numeric/comma n . o)
(fn (comma-rule)
(with ((comma-rule (or comma-rule 3)))
(apply numeric n o))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; shared structure utilities ;;; shared structure utilities