Title Formatting (Converting All Types of Object to A String) Author Joo ChurlSoo Abstract The SRFI introduces three procedures; one formatter procedure and two general purpose procedures. The formatter procedure is the CAT procedure that converts any object to a string. It takes one object as the first argument and accepts a variable number of optional arguments, unlike the procedure called FORMAT. One of the two general procedures is the CONCAT procedure with a variable number of arguments that concatenates the arguments after converting them to strings. The other is the PRINT procedure with a variable number of arguments that prints those arguments on current output port. Rationale It is difficult to gain a complete consensus for the design of a generic formatting procedure that performs a variety of necessary functions in addition to essential functions provided in C's PRINTF and Common lisp's FORMAT. One of such ways would be to devise a free (and/or floating) sequence method that easily handles optional arguments, in contrast to the conventional fixed sequence method, in order to obtain a handy optional and functional interface. With the concept of free sequencing, the CAT procedure is then defined, not to process optional arguments with default values, but to process default values with optional arguments. Issues In converting a number to a string, it has not been tried to uniformly express the exactness of a number in all implementations as each implementation supports a varying degree of numerical types in R5RS. The CAT procedure makes it possible for the user to prefix exact sign to the resulting string as well as not to prefix it to the resulting string as conventionally used, when an exact number is made to have a decimal point, or an inexact number is converted to an exact number that has a decimal point. Specification (CAT [[] [] [] [] [] [] [] [] [] [] [] [] [] ...]) * : effective for all types of . : effective only for the number type of . : effective for all types except the number type of . * is any scheme object. * is an exact integer whose absolute value specifies the width of the resulting string. When the resulting string has fewer characters than the absolute value of , it is placed rightmost with the rest being padded with s, if is positive, or it is placed leftmost with the rest being padded with s, if is negative. On the other hand, when the resulting string has more characters than the absolute value of , the is ignored. The default value is 0. * is a padding character. The default value is #\space. * is a pair whose car value is a predicate procedure that checks whether satisfies it, and cdr value is a procedure that takes the as the first argument with or without a variable number of optional arguments and returns a string. When satisfies the predicate procedure, all optional arguments are ineffective except , , and s. * is a symbol: exact or inexact. * is a symbol: binary, decimal, octal, or hexadecimal. The default value is decimal. * is an inexact integer whose absolute value specifies the number of decimal digits after a decimal point. If is a non-negative integer, an exact sign (#e) is prefixed to the resulting string as needed. * If is a symbol that takes the form of 'sign, and is a positive number without a positive sign, the positive sign is prefixed to the resulting string. * is a list whose first element is a character serving as a separator and second element is a positive exact integer. If the integer is n, the resulting string is separated in every n-characters of the resulting string. When the integer is omitted, the default value is 3. * is a procedure of two arguments; and a string port. It writes to the string port. The default value of is varied according to the type of . When is a self-evaluating constant, it becomes equivalent to DISPLAY procedure, otherwise, it becomes WRITE procedure. If you want any objects to be displayed in your own way, you have to define your own . Otherwise, they are displayed simply in their evaluated forms. * is a list which is composed of one or more procedures. Each procedure takes at least one string argument and returns a string. One procedure connects with another as a pipe. * is a list whose elements are two exact integers; n and m, and the absolute values of n and m are N and M, respectively. First, the resulting string takes from the left n-characters, if it is non-negative, or all the characters but N-characters, if negative. Second, it takes from the right m-characters, if it is non-negative, or all the characters but M-characters, if negative. Then, it concatenates two set of characters taken. * is a list whose first element is an exact integer that overrides , second being a character that overrides , and the last being strings that override s. The character and strings can be omitted. If omitted, the default values of the character and strings are and s, respectively. * is a string that is appended to the resulting string. The order of all optional arguments does not matter. The CAT procedure processes optional arguments in the following order; , , , , , , , , for the number type of , or in the following order; , , , , , , , for all other types. (CONCAT [] ...) (PRINT [] ...) * is any scheme object. CONCAT concatenates s after converting them to strings and PRINT prints s on current output port. When is a self-evaluating constant, they use DISPLAY procedure, otherwise, use WRITE procedure. Examples (cat 129.995 -10 2.) "130.00 " (cat 129.995 2. 10) " 130.00" (cat 129.995 2. 'exact) "#e130.00" (cat 129 -2.) "129.00" (cat 129 2.) "#e129.00" (cat 129 10 2. #\0) "#e00129.00" (cat 129 10 2. #\9 'sign) "#e+9129.00" (cat 129 10 2. #\* 'sign) "*#e+129.00" (cat 1/3) "1/3" (cat 1/3 10 2.) " #e0.33" (cat 1/3 10 -2.) " 0.33" (cat 129.995 10 '(#\, 2)) " 1,29.99,5" (cat 129995 10 '(#\,) 'sign) " +129,995" (cat (cat 129.995 0.) '(0 -1)) "130" (cat (cat 129.995) '(3 0)) "129" (cat 99.5 10 'sign 'octal 'exact) " +307/2" (cat (sqrt -5) 10 2.) "0.00+2.24i" (cat 3.14159e12 10 2. 'sign) " +3.14e12" (cat #x123 'octal 'sign) "+443" (cat "#o" (cat #x123 'octal 'sign)) "#o+443" (cat #x123 -10 2. 'sign #\*) "#e+291.00*" (cat "string" -10) "string " (cat "string" 10 (list string-upcase)) " STRING" (cat "string" 10 (list string-upcase) '(-2 0)) " RING" (cat "string" 10 `(,string-titlecase) '(2 3)) " Sting" (cat "string" 10 #\* `(,string-upcase ,(cut substring <> 1 5))) "******TRIN" (cat "string" 10 `(,string-reverse ,string-upcase) '(1 4)) " GIRTS" (cat #\a 10) " a" (cat 'symbol 10) " symbol" (cat '#(12 #\a "str" sym '(a))) "#(12 #\\a \"str\" sym '(a))" (cat '(12 #\a "str" sym '(a))) "(12 #\\a \"str\" sym '(a))" (concat '(12 #\a "str" sym '(a))) "(12 #\\a \"str\" sym '(a))" (print '(12 #\a "str" sym '(a))) (12 #\a "str" sym '(a)) (cat 123 " " (cat #\a) " str " (cat "string" write) " " (cat 'symbol)) "123 a str \"string\" symbol" (concat 123 " " #\a " str " (cat "string" write) " " 'symbol) "123 a str \"string\" symbol" (print 123 " " #\a " str " (cat "string" write) " " 'symbol) 123 a str "string" symbol (define-record-type :example (make-example num str) example? (num get-num set-num!) (str get-str set-str!)) (define ex (make-example 123 "string")) (define (record->string object) (concat (get-num object) "-" (get-str object))) (define (record-writer object string-port) (if (example? object) (begin (display (get-num object) string-port) (display "-" string-port) (display (get-str object) string-port)) ((or (and (or (string? object) (char? object) (boolean? object)) display) write) object string-port))) ex '#{:example} (cat ex) "#{:example}" (cat ex 20 record-writer) " 123-string" (cat ex 20 record-writer `(,(cut string-delete char-set:digit <>) ,string-upcase ,string-reverse) '(0 -1) #\-) "--------------GNIRTS" (cat "string" 20 record-writer (list string-upcase) '(2 3) #\-) "---------------STING" (cat 12 20 record-writer 3.) " #e12.000" (cat ex 20 (cons example? record->string)) " 123-string" (cat ex 20 (cons example? record->string) `(,(cut string-delete char-set:digit <>) ,string-upcase ,string-reverse) '(0 -1) #\-) "----------123-string" (cat "string" 20 (cons example? record->string) (list string-upcase) '(2 3) #\-) "---------------STING" (cat 12 20 (cons example? record->string) -3.) " 12.000" (define item '("plus" "minus" "net")) (define item-values '(234 -123 111)) (define mixed-item '("plus" 234 "minus" -123 "net" 111)) (define item-alist '(("plus" 234) ("minus" -123) ("net" 111))) (apply print (map (lambda (x y) (cat x 5 ":" (cat y 10 "\n"))) item item-values)) plus: 234 minus: -123 net: 111 (apply print (map (lambda (x) (cat (car x) 5 ":" (cat (cadr x) 10 "\n"))) item-alist)) plus: 234 minus: -123 net: 111 (apply print (map (cut cat <> 10 "\n" '(5 #\space ":")) mixed-item)) plus: 234 minus: -123 net: 111 (define (simple-ordinal-suffix num) (let ((last-two (string->number (cat (cat num) '(0 2)))) (last-one (string->number (cat (cat num) '(0 1))))) (cond ((or (= last-two 11) (= last-two 12) (= last-two 13)) "th") ((= last-one 1) "st") ((= last-one 2) "nd") ((= last-one 3) "rd") (else "th")))) (define (predicate num) (and (exact? num) (integer? num))) (define (str-suffix num) (concat num (simple-ordinal-suffix num))) (define (suffix num) (if (and (integer? num) (exact? num)) (simple-ordinal-suffix num) "")) (define a 2) (define b 12) (define c 22) (cat a (suffix a)) "2nd" (cat b (suffix b)) "12th" (cat c (suffix c)) "22nd" (cat 12.5 (suffix 12.5)) "12.5" (cat (+ a 1) (cons predicate str-suffix)) "3rd" (cat (+ b 1) (cons predicate str-suffix)) "13th" (cat (+ c 1) (cons predicate str-suffix)) "23rd" (cat 12.5 (cons predicate str-suffix)) "12.5" Implementation The implementation below requires SRFI-1 (List library), SRFI-6 (Basic string ports), SRFI-8 (Receive), SRFI-13 (String library), and SRFI-51 (Handling rest list). (define (concat . objects) (get-output-string (let ((string-port (open-output-string))) (for-each (lambda (object) ((or (and (or (number? object) (string? object) (char? object) (boolean? object)) display) write) object string-port)) objects) string-port))) (define (print . objects) (for-each (lambda (object) ((or (and (or (number? object) (string? object) (char? object) (boolean? object)) display) write) object)) objects)) (define (cat object . rest) (receive (width char converter exactness radix precision sign separator writer pipe take override . str-list) (rest-values rest #f (cons 0 (lambda (x) (and (integer? x) (exact? x)))) (cons #\space char?) (cons #f (lambda (x) (and (pair? x) (procedure? (car x)) (procedure? (cdr x))))) (cons #f (lambda (x) (memq x '(exact inexact)))) (list 'decimal 'binary 'octal 'hexadecimal) (cons #f (lambda (x) (and (integer? x) (inexact? x)))) (cons #f (lambda (x) (eq? x 'sign))) (cons #f (lambda (x) (and (list? x) (< 0 (length x) 3) (char? (car x)) (or (null? (cdr x)) (and (integer? (cadr x)) (exact? (cadr x)) (< 0 (cadr x))))))) (cons #f procedure?) (cons #f (lambda (x) (and (list? x) (not (null? x)) (every procedure? x)))) (cons #f (lambda (x) (and (list? x) (= (length x) 2) (every (lambda (x) (and (integer? x) (exact? x))) x)))) (cons #f (lambda (x) (and (list? x) (not (null? x)) (and (integer? (car x)) (exact? (car x))) (or (null? (cdr x)) (and (char? (cadr x)) (every string? (cddr x)))))))) (arg-or "cat: bad argument" str-list (not (every string? str-list))) (cond ((and converter ((car converter) object)) (let* ((str ((cdr converter) object)) (pad (- (abs width) (string-length str)))) (apply string-append (cond ((<= pad 0) str) ((< 0 width) (string-append (make-string pad char) str)) (else (string-append str (make-string pad char)))) str-list))) ((number? object) (arg-ors ("cat: non-decimal cannot be inexact" radix (and (memq radix '(binary octal hexadecimal)) (or precision (and (inexact? object) (not (eq? exactness 'exact))) (eq? exactness 'inexact)))) ("cat: cannot be expressed without exact sign" precision (and precision (< precision 0) (eq? exactness 'exact)))) (let* ((exact-sign (and precision (<= 0 precision) (or (eq? exactness 'exact) (and (exact? object) (not (eq? exactness 'inexact)))))) (str (number->string (if (or (not precision) (<= 0 precision)) (if exact-sign (if (exact? object) (exact->inexact object) object) (if exactness (if (eq? exactness 'exact) (if (inexact? object) (inexact->exact object) object) (if (exact? object) (exact->inexact object) object)) object)) (if exactness (if (eq? exactness 'exact) (if (inexact? object) (inexact->exact object) object) (if (exact? object) (exact->inexact object) object)) (if (and precision (exact? object)) (exact->inexact object) object))) (cdr (assq radix '((decimal . 10) (binary . 2) (octal . 8) (hexadecimal . 16)))))) (str (if precision (let ((precision (inexact->exact (abs precision))) (e-index (or (string-index str #\e) (string-index str #\E))) (+-index (or (string-index str #\+ 1) (string-index str #\- 1)))) (define (mold str pre) (let ((len (string-length str)) (index (string-index str #\.))) (if index (let ((d-len (- len (+ index 1)))) (if (<= d-len pre) (string-append str (make-string (- pre d-len) #\0)) (mold (number->string (let ((num (string->number (substring str 0 (+ (if (= pre 0) 0 1) index pre))))) ((if (< num 0) - +) num (if (< 4 (string->number (string (string-ref str (+ 1 index pre))))) (expt 0.1 pre) 0)))) pre))) (string-append str "." (make-string pre #\0))))) (cond (e-index (string-append (mold (substring str 0 e-index) precision) (substring str e-index (string-length str)))) (+-index (string-append (mold (substring str 0 +-index) precision) (string (string-ref str +-index)) (mold (substring str (+ 1 +-index) (- (string-length str) 1)) precision) (string (string-ref str (- (string-length str) 1))))) (else (mold str precision)))) str)) (str (if (and (< 0 (real-part object)) (not (eqv? #\+ (string-ref str 0))) sign) (string-append "+" str) str)) (str (if exact-sign (string-append "#e" str) str)) (str (if (and separator (not (or (string-index str #\e) (string-index str #\i) (string-index str #\/)))) (let ((sep-str (string (car separator))) (sep-num (if (null? (cdr separator)) 3 (cadr separator))) (+-sign (and (or (eqv? #\- (string-ref str 0)) (eqv? #\+ (string-ref str 0))) (string (string-ref str 0))))) (define (list->alist slist n) (if (< (length slist) n) (if (null? slist) '() (list slist)) (receive (n-list rest) (split-at slist n) (cons n-list (list->alist rest n))))) (let* ((str (if +-sign (substring str 1 (string-length str)) str)) (dot-index (string-index str #\.)) (predot-str-list (map reverse-list->string (reverse (list->alist (reverse (string->list (if dot-index (substring str 0 dot-index) str))) sep-num)))) (postdot-str-list (map list->string (list->alist (string->list (if dot-index (substring str (+ 1 dot-index) (string-length str)) "")) sep-num)))) (string-append (or +-sign "") (string-join predot-str-list sep-str) (if dot-index "." "") (string-join postdot-str-list sep-str)))) str)) (len (string-length str)) (pad (- (abs width) len))) (apply string-append (cond ((<= pad 0) str) ((< 0 width) (cond ((and (char-numeric? char) exact-sign) (if (or (eqv? #\+ (string-ref str 2)) (eqv? #\- (string-ref str 2))) (string-append (substring str 0 3) (make-string pad char) (substring str 3 len)) (string-append (substring str 0 2) (make-string pad char) (substring str 2 len)))) ((and (char-numeric? char) (or (eqv? #\+ (string-ref str 0)) (eqv? #\- (string-ref str 0)))) (string-append (substring str 0 1) (make-string pad char) (substring str 1 len))) (else (string-append (make-string pad char) str)))) (else (string-append str (make-string pad char)))) str-list))) (else (let* ((str (get-output-string (let ((str-port (open-output-string))) ((or writer (and (or (string? object) (char? object) (boolean? object)) display) write) object str-port) str-port))) (str (if pipe (let loop ((str ((car pipe) str)) (procs (cdr pipe))) (if (null? procs) str (loop ((car procs) str) (cdr procs)))) str)) (str (if take (let ((left (car take)) (right (cadr take)) (len (string-length str))) (string-append (if (< left 0) (string-drop str (if (< (abs left) len) (abs left) len)) (string-take str (if (< left len) left len))) (if (< right 0) (string-drop-right str (if (< (abs right) len) (abs right) len)) (string-take-right str (if (< right len) right len))))) str)) (width (if override (car override) width)) (char (if (and override (not (null? (cdr override)))) (cadr override) char)) (pad (- (abs width) (string-length str))) (str-list (if (and override (not (null? (cdr override))) (not (null? (cddr override)))) (cddr override) str-list))) (apply string-append (cond ((<= pad 0) str) ((< 0 width) (string-append (make-string pad char) str)) (else (string-append str (make-string pad char)))) str-list)))))) References [Print] Mark Feeley: Format strings are wrong. Posting in relation to [SRFI 48] on 25-Nov-2003. http://srfi.schemers.org/srfi-48/mail-archive/msg00000.html Copyright Copyright (C) Joo ChurlSoo (2004). All Rights Reserved. This document and translations of it may be copied and furnished to others, and derivative works that comment on or otherwise explain it or assist in its implementation may be prepared, copied, published and distributed, in whole or in part, without restriction of any kind, provided that the above copyright notice and this paragraph are included on all such copies and derivative works. However, this document itself may not be modified in any way, such as by removing the copyright notice or references to the Scheme Request For Implementation process or editors, except as needed for the purpose of developing SRFIs in which case the procedures for copyrights defined in the SRFI process must be followed, or as required to translate it into languages other than English. The limited permissions granted above are perpetual and will not be revoked by the authors or their successors or assigns. This document and the information contained herein is provided on an "AS IS" basis and THE AUTHOR AND THE SRFI EDITORS DISCLAIM ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE INFORMATION HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.