From d85d956c274c8efb7e3d3caf36f5a476c51e5610 Mon Sep 17 00:00:00 2001 From: Chongkai Zhu Date: Fri, 9 Mar 2007 07:20:45 +0000 Subject: [PATCH] SRFI 54 svn: r5761 --- collects/srfi/54.ss | 4 + collects/srfi/54/cat.ss | 408 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 412 insertions(+) create mode 100644 collects/srfi/54.ss create mode 100644 collects/srfi/54/cat.ss diff --git a/collects/srfi/54.ss b/collects/srfi/54.ss new file mode 100644 index 0000000000..56675b7e30 --- /dev/null +++ b/collects/srfi/54.ss @@ -0,0 +1,4 @@ +;; module loader for SRFI-54 +(module |54| mzscheme + (require (lib "cat.ss" "srfi" "54")) + (provide (all-from (lib "cat.ss" "srfi" "54")))) diff --git a/collects/srfi/54/cat.ss b/collects/srfi/54/cat.ss new file mode 100644 index 0000000000..af2019c88d --- /dev/null +++ b/collects/srfi/54/cat.ss @@ -0,0 +1,408 @@ +(module cat mzscheme + (require (lib "6.ss" "srfi") + (lib "23.ss" "srfi")) + (provide cat) + (define-syntax alet-cat* + (syntax-rules () + ((alet-cat* z (a . e) bd ...) + (let ((y z)) + (%alet-cat* y (a . e) bd ...))))) + + (define-syntax %alet-cat* + (syntax-rules () + ((%alet-cat* z ((n d t ...)) bd ...) + (let ((n (if (null? z) + d + (if (null? (cdr z)) + (wow-cat-end z n t ...) + (error "cat: too many arguments" (cdr z)))))) + bd ...)) + ((%alet-cat* z ((n d t ...) . e) bd ...) + (let ((n (if (null? z) + d + (wow-cat! z n d t ...)))) + (%alet-cat* z e bd ...))) + ((%alet-cat* z e bd ...) + (let ((e z)) bd ...)))) + + (define-syntax wow-cat! + (syntax-rules () + ((wow-cat! z n d) + (let ((n (car z))) + (set! z (cdr z)) + n)) + ((wow-cat! z n d t) + (let ((n (car z))) + (if t + (begin (set! z (cdr z)) n) + (let lp ((head (list n)) (tail (cdr z))) + (if (null? tail) + d + (let ((n (car tail))) + (if t + (begin (set! z (append (reverse head) (cdr + tail))) n) + (lp (cons n head) (cdr tail))))))))) + ((wow-cat! z n d t ts) + (let ((n (car z))) + (if t + (begin (set! z (cdr z)) ts) + (let lp ((head (list n)) (tail (cdr z))) + (if (null? tail) + d + (let ((n (car tail))) + (if t + (begin (set! z (append (reverse head) (cdr + tail))) ts) + (lp (cons n head) (cdr tail))))))))) + ((wow-cat! z n d t ts fs) + (let ((n (car z))) + (if t + (begin (set! z (cdr z)) ts) + (begin (set! z (cdr z)) fs)))))) + + (define-syntax wow-cat-end + (syntax-rules () + ((wow-cat-end z n) + (car z)) + ((wow-cat-end z n t) + (let ((n (car z))) + (if t n (error "cat: too many argument" z)))) + ((wow-cat-end z n t ts) + (let ((n (car z))) + (if t ts (error "cat: too many argument" z)))) + ((wow-cat-end z n t ts fs) + (let ((n (car z))) + (if t ts fs))))) + + (define (str-index str char) ; to avoid srfi-13 + (let ((len (string-length str))) + (let lp ((n 0)) + (and (< n len) + (if (char=? char (string-ref str n)) + n + (lp (+ n 1))))))) + + (define (every? pred ls) ; to avoid srfi-1 + (let lp ((ls ls)) + (or (null? ls) + (and (pred (car ls)) + (lp (cdr ls)))))) + + (define (part pred ls) ; to avoid srfi-1 & + call-with-values + (let lp ((ls ls) (true '()) (false '())) + (cond + ((null? ls) (cons (reverse true) (reverse false))) + ((pred (car ls)) (lp (cdr ls) (cons (car ls) true) false)) + (else (lp (cdr ls) true (cons (car ls) false)))))) + + (define (e-mold num pre) + (let* ((str (number->string (exact->inexact num))) + (e-index (str-index str #\e))) + (if e-index + (string-append (mold (substring str 0 e-index) pre) + (substring str e-index (string-length str))) + (mold str pre)))) + + (define (mold str pre) + (let ((ind (str-index str #\.))) + (if ind + (let ((d-len (- (string-length str) (+ ind 1)))) + (cond + ((= d-len pre) str) + ((< d-len pre) (string-append str (make-string (- pre d-len) + #\0))) + ;;((charstring (/ (round (* (string->number str) com)) + ;; com)))) + ((or (charchar + (+ 1 (char->integer + chr))) + (lp (- index 1) #f))) + (cons chr (lp (- index 1) + raise)))))))))) + (if minus (cons #\- char-list) char-list)))) + (else + (substring str 0 (+ 1 ind pre))))) + (string-append str "." (make-string pre #\0))))) + + (define (separate str sep num opt) + (let* ((len (string-length str)) + (pos (if opt + (let ((pos (remainder (if (eq? opt 'minus) (- len 1) + len) + num))) + (if (= 0 pos) num pos)) + num))) + (apply string-append + (let loop ((ini 0) + (pos (if (eq? opt 'minus) (+ pos 1) pos))) + (if (< pos len) + (cons (substring str ini pos) + (cons sep (loop pos (+ pos num)))) + (list (substring str ini len))))))) + + (define (cat object . rest) + (let* ((str-rest (part string? rest)) + (str-list (car str-rest)) + (rest-list (cdr str-rest))) + (if (null? rest-list) + (apply string-append + (cond + ((number? object) (number->string object)) + ((string? object) object) + ((char? object) (string object)) + ((boolean? object) (if object "#t" "#f")) + (else + (get-output-string + (let ((str-port (open-output-string))) + (write object str-port) + str-port)))) + str-list) + (alet-cat* rest-list + ((width 0 (and (integer? width) (exact? width))) + (port #f (or (boolean? port) (output-port? port)) + (if (eq? port #t) (current-output-port) port)) + (char #\space (char? char)) + (converter #f (and (pair? converter) + (procedure? (car converter)) + (procedure? (cdr converter)))) + (precision #f (and (integer? precision) + (inexact? precision))) + (sign #f (eq? 'sign sign)) + (radix 'decimal + (memq radix '(decimal octal binary hexadecimal))) + (exactness #f (memq exactness '(exact inexact))) + (separator #f (and (list? separator) + (< 0 (length separator) 3) + (char? (car separator)) + (or (null? (cdr separator)) + (let ((n (cadr separator))) + (and (integer? n) (exact? n) + (< 0 n)))))) + (writer #f (procedure? writer)) + (pipe #f (and (list? pipe) + (not (null? pipe)) + (every? procedure? pipe))) + (take #f (and (list? take) + (< 0 (length take) 3) + (every? (lambda (x) + (and (integer? x) (exact? x))) + take)))) + (let* ((str + (cond + ((and converter + ((car converter) object)) + (let* ((str ((cdr converter) object)) + (pad (- (abs width) (string-length str)))) + (cond + ((<= pad 0) str) + ((< 0 width) (string-append (make-string pad + char) str)) + (else (string-append str (make-string pad + char)))))) + ((number? object) + (and (not (eq? radix 'decimal)) precision + (error "cat: non-decimal cannot have a decimal +point")) + (and precision (< precision 0) (eq? exactness + 'exact) + (error "cat: exact number cannot have a decimal +point without exact sign")) + (let* ((exact-sign (and precision + (<= 0 precision) + (or (eq? exactness 'exact) + (and (exact? object) + (not (eq? exactness + + 'inexact)))) + "#e")) + (inexact-sign (and (not (eq? radix 'decimal)) + (or (and (inexact? object) + (not (eq? + exactness + + 'exact))) + (eq? exactness + 'inexact)) + "#i")) + (radix-sign (cdr (assq radix + '((decimal . #f) + (octal . "#o") + (binary . "#b") + (hexadecimal . + "#x"))))) + (plus-sign (and sign (< 0 (real-part object)) + "+")) + (exactness-sign (or exact-sign inexact-sign)) + (str + (if precision + (let ((precision (inexact->exact + (abs precision))) + (imag (imag-part object))) + (if (= 0 imag) + (e-mold object precision) + (string-append + (e-mold (real-part object) + precision) + (if (< 0 imag) "+" "") + (e-mold imag precision) + "i"))) + (number->string + (cond + (inexact-sign (inexact->exact object)) + (exactness + (if (eq? exactness 'exact) + (inexact->exact object) + (exact->inexact object))) + (else object)) + (cdr (assq radix '((decimal . 10) + (octal . 8) + (binary . 2) + (hexadecimal . + 16))))))) + (str + (if (and separator + (not (or (and (eq? radix 'decimal) + (str-index str #\e)) + (str-index str #\i) + (str-index str #\/)))) + (let ((sep (string (car separator))) + (num (if (null? (cdr separator)) + 3 (cadr separator))) + (dot-index (str-index str #\.))) + (if dot-index + (string-append + (separate (substring str 0 + dot-index) + sep num (if (< object + 0) + 'minus #t)) + "." + (separate (substring + str (+ 1 dot-index) + (string-length str)) + sep num #f)) + (separate str sep num (if (< + object 0) + 'minus + #t)))) + str)) + (pad (- (abs width) + (+ (string-length str) + (if exactness-sign 2 0) + (if radix-sign 2 0) + (if plus-sign 1 0)))) + (pad (if (< 0 pad) pad 0))) + (if (< 0 width) + (if (char-numeric? char) + (if (< (real-part object) 0) + (string-append (or exactness-sign "") + (or radix-sign "") + "-" + (make-string pad char) + (substring str 1 + + (string-length + str))) + (string-append (or exactness-sign "") + (or radix-sign "") + (or plus-sign "") + (make-string pad char) + str)) + (string-append (make-string pad char) + (or exactness-sign "") + (or radix-sign "") + (or plus-sign "") + str)) + (string-append (or exactness-sign "") + (or radix-sign "") + (or plus-sign "") + str + (make-string pad char))))) + (else + (let* ((str (cond + (writer (get-output-string + (let ((str-port + (open-output-string))) + (writer object str-port) + str-port))) + ((string? object) object) + ((char? object) (string object)) + ((boolean? object) (if object "#t" + "#f")) + (else (get-output-string + (let ((str-port + (open-output-string))) + (write object str-port) + str-port))))) + (str (if pipe + (let loop ((str ((car pipe) str)) + (fns (cdr pipe))) + (if (null? fns) + str + (loop ((car fns) str) + (cdr fns)))) + str)) + (str + (if take + (let ((left (car take)) + (right (if (null? (cdr take)) + 0 (cadr take))) + (len (string-length str))) + (define (substr str beg end) + (let ((end (cond + ((< end 0) 0) + ((< len end) len) + (else end))) + (beg (cond + ((< beg 0) 0) + ((< len beg) len) + (else beg)))) + (if (and (= beg 0) (= end len)) + str + (substring str beg end)))) + (string-append + (if (< left 0) + (substr str (abs left) len) + (substr str 0 left)) + (if (< right 0) + (substr str 0 (+ len right)) + (substr str (- len right) len)))) + str)) + (pad (- (abs width) (string-length str)))) + (cond + ((<= pad 0) str) + ((< 0 width) (string-append (make-string pad + char) str)) + (else (string-append str (make-string pad + char)))))))) + (str (apply string-append str str-list))) + (and port (display str port)) + str))))) + )