From 80c69291babe5c7ebbba7eab70410c58c06ca54e Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Wed, 8 Nov 2017 22:56:40 +0900 Subject: [PATCH] updating (chibi show) with srfi changes --- lib/chibi/show-test.sld | 202 +++++++++++++++- lib/chibi/show.sld | 5 +- lib/chibi/show/base.sld | 19 ++ lib/chibi/show/column.scm | 83 +++++-- lib/chibi/show/column.sld | 3 +- lib/chibi/show/pretty.scm | 4 +- lib/chibi/show/show.scm | 2 +- lib/chibi/show/write.scm | 496 ++++++++++++++++++++++++-------------- 8 files changed, 596 insertions(+), 218 deletions(-) diff --git a/lib/chibi/show-test.sld b/lib/chibi/show-test.sld index b53545f8..ecbc679e 100644 --- a/lib/chibi/show-test.sld +++ b/lib/chibi/show-test.sld @@ -1,7 +1,9 @@ (define-library (chibi show-test) (export run-tests) - (import (scheme base) (scheme read) (chibi test) - (chibi show) (chibi show base) (chibi show pretty)) + (import (scheme base) (scheme char) (scheme read) + (chibi test) + (chibi show) (chibi show base) + (chibi show column) (chibi show pretty)) (begin (define-syntax test-pretty (syntax-rules () @@ -144,6 +146,29 @@ (test "3.14+2.00i" (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 (test "abc " (show #f (padded 5 "abc"))) @@ -253,6 +278,14 @@ '(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 (test "#0=(1 . #0#)" @@ -317,15 +350,15 @@ wubbleflubbery)\n") (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") (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") (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") (test-pretty @@ -389,4 +422,163 @@ (ones ',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)))) diff --git a/lib/chibi/show.sld b/lib/chibi/show.sld index 207e15a5..fb882276 100644 --- a/lib/chibi/show.sld +++ b/lib/chibi/show.sld @@ -2,8 +2,9 @@ (define-library (chibi show) (export show fn fn-fork with update! each each-in-list call-with-output - displayed written written-shared written-simply numeric nothing - nl fl space-to tab-to + displayed written written-shared written-simply + numeric numeric/comma numeric/si numeric/fitted + nothing nl fl space-to tab-to escaped maybe-escaped padded padded/left padded/right padded/both trimmed trimmed/left trimmed/right trimmed/both trimmed/lazy fitted fitted/left fitted/right fitted/both diff --git a/lib/chibi/show/base.sld b/lib/chibi/show/base.sld index c56d236e..6cf08564 100644 --- a/lib/chibi/show/base.sld +++ b/lib/chibi/show/base.sld @@ -3,10 +3,29 @@ (export show fn fn-fork with update! each each-in-list call-with-output displayed written written-shared written-simply numeric nothing + escaped maybe-escaped numeric/si numeric/fitted numeric/comma ;; internal output-default extract-shared-objects write-to-string write-with-shares call-with-shared-ref call-with-shared-ref/cdr) (import (scheme base) (scheme write) (scheme complex) (scheme inexact) (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 "write.scm")) diff --git a/lib/chibi/show/column.scm b/lib/chibi/show/column.scm index adf23fc7..82d60d5a 100644 --- a/lib/chibi/show/column.scm +++ b/lib/chibi/show/column.scm @@ -2,6 +2,20 @@ ;; Copyright (c) 2006-2017 Alex Shinn. All rights reserved. ;; 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) (fn () (let ((out (open-output-string)) @@ -12,10 +26,18 @@ (define (output* str) (fn (row col string-width) (list-queue-add-back! queue str) - (call-with-current-continuation - (lambda (cc) - (set! resume cc) - (return nothing))) + (each + (let ((nl-index + (string-index-right str (lambda (ch) (eqv? ch #\newline))))) + (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)) (define (generate) (if (and resume (list-queue-empty? queue)) @@ -27,13 +49,13 @@ eof (list-queue-remove-front! queue))) (fn-fork (fn () (with ((port out) (output output*)) - (call-with-current-continuation - (lambda (cc) - (set! return cc) - (each producer - (fn (output) - (set! resume #f) - (fn () (return nothing) nothing))))))) + (call-with-current-continuation + (lambda (cc) + (set! return cc) + (each producer + (fn (output) + (set! resume #f) + (fn () (return nothing) nothing))))))) (consumer generate))))) (define (call-with-output-generators producers consumer) @@ -320,6 +342,10 @@ (fn () (lp (string-cursor-next str nli)))))))))))) (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) (let* ((last-line (if (pair? o) (car o) line)) (vec (if (list? seq) (list->vector seq) seq)) @@ -380,21 +406,21 @@ (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-split str " ") o)) +(define (wrapped/list ls) + (fn (width string-width pad-char) + (joined/suffix + (lambda (ls) (joined displayed ls pad-char)) + (reverse + (wrap-fold-words ls '() width (or string-width string-length) cons)) + "\n"))) (define (wrapped . ls) (call-with-output (each-in-list ls) (lambda (str) - (fn (width string-width pad-char) - (joined/suffix - (lambda (ls) (joined displayed ls pad-char)) - (reverse - (wrap-fold str '() width (or string-width string-length) cons)) - "\n"))))) + (fn (word-separator?) + (wrapped/list + (string-split-words str (or word-separator? char-whitespace?))))))) (define (justified . ls) (fn (output width string-width) @@ -427,11 +453,16 @@ (call-with-output (each-in-list ls) (lambda (str) - (joined/last - justify-line - justify-last - (reverse (wrap-fold str '() width string-width cons)) - "\n"))))) + (fn (word-separator?) + (joined/last + justify-line + justify-last + (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) (fn () diff --git a/lib/chibi/show/column.sld b/lib/chibi/show/column.sld index 7c6c3ebd..f217dd27 100644 --- a/lib/chibi/show/column.sld +++ b/lib/chibi/show/column.sld @@ -6,5 +6,6 @@ (export call-with-output-generator call-with-output-generators 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")) diff --git a/lib/chibi/show/pretty.scm b/lib/chibi/show/pretty.scm index 394d9f57..fd507546 100644 --- a/lib/chibi/show/pretty.scm +++ b/lib/chibi/show/pretty.scm @@ -42,7 +42,7 @@ (string-find str pred (string-index->cursor str i)))) (define (try-fitted2 proc fail) - (fn (width string-width output) + (fn (width output) (let ((out (open-output-string))) (call-with-current-continuation (lambda (abort) @@ -53,7 +53,7 @@ (fn (col) (let lp ((i 0) (col col)) (let ((nli (string-find/index str #\newline i)) - (len (string-width str))) + (len (string-length str))) (if (< nli len) (if (> (+ (- nli i) col) width) (abort fail) diff --git a/lib/chibi/show/show.scm b/lib/chibi/show/show.scm index 2a51e0f9..f373405a 100644 --- a/lib/chibi/show/show.scm +++ b/lib/chibi/show/show.scm @@ -1,5 +1,5 @@ ;; 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 ;;> A library of procedures for formatting Scheme objects to text in diff --git a/lib/chibi/show/write.scm b/lib/chibi/show/write.scm index 0eb74da8..14931854 100644 --- a/lib/chibi/show/write.scm +++ b/lib/chibi/show/write.scm @@ -30,6 +30,64 @@ (if (pair? rule) (cdr rule) rule) (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-cursorstring for common cases. -(define (numeric n) - (fn (radix precision decimal-sep decimal-align comma-rule comma-sep sign-rule) - (let ((dec-sep (or decimal-sep (if (eqv? comma-sep #\.) #\, #\.)))) - ;; General formatting utilities. - (define (get-scale q) - (expt radix (- (integer-log q radix) 1))) - (define (char-digit d) - (cond ((char? d) d) - ((< d 10) (integer->char (+ d (char->integer #\0)))) - (else (integer->char (+ (- d 10) (char->integer #\a)))))) - (define (digit-value ch) - (let ((res (- (char->integer ch) (char->integer #\0)))) - (if (<= 0 res 9) - res - ch))) - (define (round-up ls) - (let lp ((ls ls) (res '())) - (cond - ((null? ls) - (cons 1 res)) - ((not (number? (car ls))) - (lp (cdr ls) (cons (car ls) res))) - ((= (car ls) (- radix 1)) - (lp (cdr ls) (cons 0 res))) - (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 - ((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 '())) +(define unspec (list 'unspecified)) + +(define-syntax default + (syntax-rules () + ((default var dflt) (if (eq? var unspec) dflt var)))) + +(define (numeric n . o) + (let-optionals* o ((rad unspec) (prec unspec) (sgn unspec) + (comma unspec) (commasep unspec) (decsep unspec)) + (fn (radix precision sign-rule + comma-rule comma-sep decimal-sep decimal-align) + (let ((radix (default rad radix)) + (precision (default prec precision)) + (sign-rule (default sgn sign-rule)) + (comma-rule (default comma comma-rule)) + (comma-sep (default comma-sep commasep)) + (dec-sep (default decsep + (or decimal-sep (if (eqv? comma-sep #\.) #\, #\.))))) + ;; General formatting utilities. + (define (get-scale q) + (expt radix (- (integer-log q radix) 1))) + (define (char-digit d) + (cond ((char? d) d) + ((< d 10) (integer->char (+ d (char->integer #\0)))) + (else (integer->char (+ (- d 10) (char->integer #\a)))))) + (define (digit-value ch) + (let ((res (- (char->integer ch) (char->integer #\0)))) + (if (<= 0 res 9) + res + ch))) + (define (round-up ls) + (let lp ((ls ls) (res '())) (cond - ;; Use a fixed precision if specified, otherwise generate - ;; 15 decimals. - ((if precision (< i precision) (< i 16)) - (let ((res (if (zero? i) - (cons dec-sep (if (null? res) (cons 0 res) res)) - res)) - (q (quotient n d))) + ((null? ls) + (cons 1 res)) + ((not (number? (car ls))) + (lp (cdr ls) (cons (car ls) res))) + ((= (car ls) (- radix 1)) + (lp (cdr ls) (cons 0 res))) + (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 - ((>= q radix) - (let* ((scale (get-scale q)) - (digit (quotient q scale)) - (n2 (- n (* d digit scale)))) - (lp n2 (+ i 1) (cons digit res)))) - (else - (lp (* (remainder n d) radix) - (+ i 1) - (cons q res)))))) - (else - (list->string - (map char-digit - (reverse (maybe-round n d (maybe-trim-zeros i res)))))))))) - ;; Generate a fixed precision decimal result by post-editing the - ;; result of string->number. - (define (gen-fixed n) - (cond - ((and (eqv? radix 10) (or (integer? n) (inexact? n))) - (let* ((s (number->string n)) - (end (string-cursor-end s)) - (dec (string-find s #\.)) - (digits (- (string-cursor->index s end) - (string-cursor->index s dec)))) - (cond - ((string-cursor next 5) - (and (= next 5) - (string-cursor>? last (string-cursor-start s)) - (odd? (digit-value - (string-cursor-ref - s (string-cursor-prev last 1)))))))) - (list->string - (reverse - (map char-digit - (round-up - (reverse (map digit-value (string->list res))))))) - res)))))) - (else - (gen-general n)))) - ;; Generate any unsigned real number. - (define (gen-positive-real n) - (cond - (precision - (gen-fixed n)) - ((and (exact? n) (not (integer? n))) - (string-append (number->string (numerator n) radix) - "/" - (number->string (denominator n) radix))) - ((memv radix (if (exact? n) '(2 8 10 16) '(10))) - (number->string n)) - (else - (gen-general n)))) - ;; Insert commas according to the current comma-rule. - (define (insert-commas str) - (let* ((dec-pos (string-find str dec-sep)) - (left (substring-cursor str (string-cursor-start str) dec-pos)) - (right (substring-cursor str dec-pos)) - (sep (cond ((char? comma-sep) (string comma-sep)) - ((string? comma-sep) comma-sep) - ((eqv? #\, dec-sep) ".") - (else ",")))) - (string-append - (string-intersperse-right left sep comma-rule) - right))) - ;; Post-process a positive real number with decimal char fixup - ;; and commas as needed. - (define (wrap-comma n) - (let* ((s0 (gen-positive-real n)) - (s1 (if (and (char? dec-sep) - (not (eqv? #\. dec-sep))) - (string-replace-all s0 #\. dec-sep) - s0))) - (if comma-rule (insert-commas s1) s1))) - ;; Wrap the sign of a real number, forcing a + prefix or using - ;; parentheses (n) for negatives according to sign-rule. - (define (wrap-sign n sign-rule) - (cond - ((negative? n) - (if (char? sign-rule) - (string-append (string sign-rule) - (wrap-comma (abs n)) - (string (char-mirror sign-rule))) - (string-append "-" (wrap-comma (abs n))))) - ((eq? #t sign-rule) - (string-append "+" (wrap-comma 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)))) + ((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 + ;; Use a fixed precision if specified, otherwise generate + ;; 15 decimals. + ((if precision (< i precision) (< i 16)) + (let ((res (if (zero? i) + (cons dec-sep (if (null? res) (cons 0 res) res)) + res)) + (q (quotient n d))) + (cond + ((>= q radix) + (let* ((scale (get-scale q)) + (digit (quotient q scale)) + (n2 (- n (* d digit scale)))) + (lp n2 (+ i 1) (cons digit res)))) + (else + (lp (* (remainder n d) radix) + (+ i 1) + (cons q res)))))) + (else + (list->string + (map char-digit + (reverse (maybe-round n d (maybe-trim-zeros i res)))))))))) + ;; Generate a fixed precision decimal result by post-editing the + ;; result of string->number. + (define (gen-fixed n) + (cond + ((and (eqv? radix 10) (or (integer? n) (inexact? n))) + (let* ((s (number->string n)) + (end (string-cursor-end s)) + (dec (string-find s #\.)) + (digits (- (string-cursor->index s end) + (string-cursor->index s dec)))) + (cond + ((string-cursor next 5) + (and (= next 5) + (string-cursor>? last (string-cursor-start s)) + (odd? (digit-value + (string-cursor-ref + s (string-cursor-prev s last)))))))) + (list->string + (reverse + (map char-digit + (round-up + (reverse (map digit-value (string->list res))))))) + res)))))) + (else + (gen-general n)))) + ;; Generate any unsigned real number. + (define (gen-positive-real n) + (cond + (precision + (gen-fixed n)) + ((and (exact? n) (not (integer? n))) + (string-append (number->string (numerator n) radix) + "/" + (number->string (denominator n) radix))) + ((memv radix (if (exact? n) '(2 8 10 16) '(10))) + (number->string n)) + (else + (gen-general n)))) + ;; Insert commas according to the current comma-rule. + (define (insert-commas str) + (let* ((dec-pos (string-find str dec-sep)) + (left (substring-cursor str (string-cursor-start str) dec-pos)) + (right (substring-cursor str dec-pos)) + (sep (cond ((char? comma-sep) (string comma-sep)) + ((string? comma-sep) comma-sep) + ((eqv? #\, dec-sep) ".") + (else ",")))) + (string-append + (string-intersperse-right left sep comma-rule) + right))) + ;; Post-process a positive real number with decimal char fixup + ;; and commas as needed. + (define (wrap-comma n) + (let* ((s0 (gen-positive-real n)) + (s1 (if (and (char? dec-sep) + (not (eqv? #\. dec-sep))) + (string-replace-all s0 #\. dec-sep) + s0))) + (if comma-rule (insert-commas s1) s1))) + ;; Wrap the sign of a real number, forcing a + prefix or using + ;; parentheses (n) for negatives according to sign-rule. + (define (wrap-sign n sign-rule) + (cond + ((negative? n) + (if (char? sign-rule) + (string-append (string sign-rule) + (wrap-comma (abs n)) + (string (char-mirror sign-rule))) + (string-append "-" (wrap-comma (abs n))))) + ((eq? #t sign-rule) + (string-append "+" (wrap-comma 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