Hello,
The speed of the CAT procedure of current SRFI seems to be more or less slow
partly because the procedure makes use of the complex REST-VALUES of SRFI-51.
I think if a more efficient accessary procedure is substituted for the
REST-VALUES in the current reference implementation, the CAT will has the much
more rapid speed (compared with FORMAT(CL)). How about this?
The following is the reference implementaton using an accessary procedure and
simple speed tests.
;; accessary procedure
(define (cat-values rest-list default-list . predicate-list)
;; The default-list and predicate-list should have the same number of
;; elements. It is not checked for speed.
(apply values
(let loop ((rest rest-list)
(default default-list)
(predicate predicate-list))
(if (null? rest)
default
(if (null? default)
(error "cat-values: bad optional arguments" rest)
(let ((arg (car rest)))
(if ((car predicate) arg)
(cons arg (loop (cdr rest)
(cdr default)
(cdr predicate)))
(let lp ((rest (cdr rest))
(head (list arg)))
(if (null? rest)
(cons (car default) (loop (reverse head)
(cdr default)
(cdr predicate)))
(let ((r (car rest)))
(if ((car predicate) r)
(cons r (loop (append (reverse head)
(cdr rest))
(cdr default)
(cdr predicate)))
(lp (cdr rest) (cons r head)))))))))))))
(define (cat object . rest)
(receive (str-list rest-list) (partition string? 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)
(receive (width port char converter precision sign radix exactness
separator writer pipe take)
(cat-values rest-list
'(0 #f #\space #f #f #f decimal #f #f #f #f #f)
(lambda (x) (and (integer? x) (exact? x)))
(lambda (x) (or (boolean? x) (output-port? x)))
char?
(lambda (x) (and (pair? x)
(procedure? (car x))
(procedure? (cdr x))))
(lambda (x) (and (integer? x) (inexact? x)))
(lambda (x) (eq? x 'sign))
(lambda (x)
(memq x '(decimal octal binary hexadecimal)))
(lambda (x) (memq x '(exact inexact)))
(lambda (x) (and (list? x)
(< 0 (length x) 3)
(char? (car x))
(or (null? (cdr x))
(let ((n (cadr x)))
(and (integer? n)
(exact? n)
(< 0 n))))))
procedure?
(lambda (x) (and (list? x)
(not (null? x))
(every procedure? x)))
(lambda (x) (and (list? x)
(< 0 (length x) 3)
(every (lambda (x)
(and (integer? x)
(exact? x)))
x))))
(let ((port (if (eq? port #t) (current-output-port) port))
(str
(apply
string-append
(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)) "+")))
(let* ((exactness-sign (or exact-sign inexact-sign))
(str
(if precision
(let ((precision
(inexact->exact (abs precision)))
(imag (imag-part object)))
(define (e-mold num pre)
(let* ((str (number->string
(exact->inexact num)))
(e-index (string-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 (string-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)))
((or (char<? #\5 (string-ref str (+ 1 ind pre)))
(and (char=? #\5 (string-ref str (+ 1 ind pre)))
(or (< (+ 1 pre) d-len)
(memv (string-ref str (+ ind (if (= 0 pre) -1 pre)))
'(#\1 #\3 #\5 #\7 #\9)))))
(apply string
(let* ((minus (char=? #\- (string-ref str 0)))
(str (substring str (if minus 1 0) (+ 1 ind pre)))
(char-list
(reverse
(let lp ((index (- (string-length str) 1))
(raise #t))
(if (= -1 index)
(if raise '(#\1) '())
(let ((chr (string-ref str index)))
(if (char=? #\. chr)
(cons chr (lp (- index 1) raise))
(if raise
(if (char=? #\9 chr)
(cons #\0 (lp (- index 1) raise))
(cons (integer->char
(+ 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)))))
(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)
(string-index str #\e))
(string-index str #\i)
(string-index str #\/))))
(let ((sep (string (car separator)))
(num (if (null? (cdr separator))
3 (cadr separator)))
(dot-index (string-index str #\.)))
(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)))))))
(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-list)))
(and port (display str port))
str)))))))
A simple speed test in Scheme48:
> ,time (for-each (lambda (x) (format "~d~a~a~aend" x "a" #\a 'a)) (make-list 10000 123))
Run time: 6.17 seconds; Elapsed time: 6.18 seconds
> ,time (for-each (lambda (x) (cat x (cat "a") (cat #\a) (cat 'a) "end")) (make-list 10000 123))
Run time: 4.33 seconds; Elapsed time: 4.33 seconds
> ,time (for-each (lambda (x) (format "~10d~10a~10a~10aend" x "a" #\a 'a)) (make-list 10000 123))
Run time: 12.18 seconds; Elapsed time: 12.20 seconds
> ,time (for-each (lambda (x) (cat x 10 (cat "a" 10) (cat #\a 10) (cat 'a 10) "end")) (make-list 10000 123))
Run time: 7.85 seconds; Elapsed time: 7.86 seconds
> ,time (for-each (lambda (x) (format "~10dinteger~10astr~10achar~10aend" x "a" #\a 'a)) (make-list 10000 123))
Run time: 12.71 seconds; Elapsed time: 12.74 seconds
> ,time (for-each (lambda (x) (cat x 10 "integer" (cat "a" 10 "str") (cat #\a 10"char") (cat 'a 10 "end"))) (make-list 10000 123))
Run time: 8.42 seconds; Elapsed time: 8.44 seconds
> ,time (for-each (lambda (x) (format "~10d~10s~10s~10aend" x "a" #\a 'a)) (make-list 10000 123))
Run time: 13.12 seconds; Elapsed time: 13.13 seconds
> ,time (for-each (lambda (x) (cat x 10 (cat "a" 10 write) (cat #\a 10 write) (cat 'a 10) "end")) (make-list 10000 123))
Run time: 14.77 seconds; Elapsed time: 14.77 seconds
> ,time (for-each (lambda (x) (format "~s" x)) (make-list 10000 "abc"))
Run time: 4.23 seconds; Elapsed time: 4.24 seconds
> ,time (for-each (lambda (x) (cat x write)) (make-list 10000 "abc"))
Run time: 4.02 seconds; Elapsed time: 4.02 seconds
> ,time (for-each (lambda (x) (format "~10s" x)) (make-list 10000 "abc"))
Run time: 5.64 seconds; Elapsed time: 5.65 seconds
> ,time (for-each (lambda (x) (cat x 10 write)) (make-list 10000 "abc"))
Run time: 4.38 seconds; Elapsed time: 4.38 seconds
> ,time (for-each (lambda (x) (format "~a" x)) (make-list 10000 '("abc" sym 123 #\a (list))))
Run time: 8.69 seconds; Elapsed time: 8.71 seconds
> ,time (for-each (lambda (x) (cat x)) (make-list 10000 '("abc" sym 123 #\a (list))))
Run time: 4.73 seconds; Elapsed time: 5.10 seconds
> ,time (for-each (lambda (x) (format "~10,3f" x)) (make-list 10000 123))
Run time: 7.12 seconds; Elapsed time: 7.13 seconds
> ,time (for-each (lambda (x) (cat x 10 3.)) (make-list 10000 123))
Run time: 3.75 seconds; Elapsed time: 3.75 seconds
> ,time (for-each (lambda (x) (format "~9,3I" x)) (make-list 10000 1.23+2.34i))
Run time: 8.45 seconds; Elapsed time: 8.47 seconds
> ,time (for-each (lambda (x) (cat x 9 1.)) (make-list 10000 1.23+2.34i))
Run time: 5.20 seconds; Elapsed time: 5.21 seconds
> ,time (for-each (lambda (x) (format "~:D" x)) (make-list 10000 123456789123))
Run time: 4.88 seconds; Elapsed time: 4.90 seconds
> ,time (for-each (lambda (x) (cat x '(#\,))) (make-list 10000 123456789123))
Run time: 4.72 seconds; Elapsed time: 4.71 seconds
Thanks.
-- Joo ChurlSoo
