format.scm

MSYS在windows下模拟了一个类unix的终端

					 (obj->str (car obj-list)
						   #t
						   (cons (car obj-list) visited))
					 " ")))
				 (else
				  (string-append
				   prefix
				   (obj->str (car obj-list)
					     #t
					     (cons (car obj-list) visited))
				   " . "
				   (obj->str (cdr obj-list)
					     #t
					     (cons (cdr obj-list) visited))))))
			 ")"))

	 ((vector? obj)
	  (string-append "#" (obj->str (vector->list obj) #t visited)))

	 (else				; only objects with an #<...> 
	  (format:iobj->str obj)))))	; representation should fall in here
  (obj->str obj slashify (list obj)))

;; format:iobj->str reveals the implementation dependent representation of 
;; #<...> objects with the use of display and call-with-output-string.
;; If format:read-proof is set to #t the resulting string is additionally 
;; set into string quotes.

(define format:read-proof #f)

(define (format:iobj->str iobj)
  (if (or format:read-proof
	  format:iobj-case-conv)
      (string-append 
       (if format:read-proof "\"" "")
       (if format:iobj-case-conv
	   (format:iobj-case-conv
	    (call-with-output-string (lambda (p) (display iobj p))))
	   (call-with-output-string (lambda (p) (display iobj p))))
       (if format:read-proof "\"" ""))
      (call-with-output-string (lambda (p) (display iobj p)))))


;; format:char->str converts a character into a slashified string as
;; done by `write'. The procedure is dependent on the integer
;; representation of characters and assumes a character number according to
;; the ASCII character set.

(define (format:char->str ch)
  (let ((int-rep (char->integer ch)))
    (if (< int-rep 0)			; if chars are [-128...+127]
	(set! int-rep (+ int-rep 256)))
    (string-append
     "#\\"
     (cond
      ((char=? ch #\newline) "newline")
      ((and (>= int-rep 0) (<= int-rep 32))
       (vector-ref format:ascii-non-printable-charnames int-rep))
      ((= int-rep 127) "del")
      ((>= int-rep 128)		; octal representation
       (if format:radix-pref
	   (let ((s (number->string int-rep 8)))
	     (substring s 2 (string-length s)))
	   (number->string int-rep 8)))
      (else (string ch))))))

(define format:space-ch (char->integer #\space))
(define format:zero-ch (char->integer #\0))

(define (format:par pars length index default name)
  (if (> length index)
      (let ((par (list-ref pars index)))
	(if par
	    (if name
		(if (< par 0)
		    (format:error 
		     "~s parameter must be a positive integer" name)
		    par)
		par)
	    default))
      default))

(define (format:out-obj-padded pad-left obj slashify pars)
  (if (null? pars)
      (format:out-str (format:obj->str obj slashify))
      (let ((l (length pars)))
	(let ((mincol (format:par pars l 0 0 "mincol"))
	      (colinc (format:par pars l 1 1 "colinc"))
	      (minpad (format:par pars l 2 0 "minpad"))
	      (padchar (integer->char
			(format:par pars l 3 format:space-ch #f)))
	      (objstr (format:obj->str obj slashify)))
	  (if (not pad-left)
	      (format:out-str objstr))
	  (do ((objstr-len (string-length objstr))
	       (i minpad (+ i colinc)))
	      ((>= (+ objstr-len i) mincol)
	       (format:out-fill i padchar)))
	  (if pad-left
	      (format:out-str objstr))))))

(define (format:out-num-padded modifier number pars radix)
  (if (not (integer? number)) (format:error "argument not an integer"))
  (let ((numstr (number->string number radix)))
    (if (and format:radix-pref (not (= radix 10)))
	(set! numstr (substring numstr 2 (string-length numstr))))
    (if (and (null? pars) (not modifier))
	(format:out-str numstr)
	(let ((l (length pars))
	      (numstr-len (string-length numstr)))
	  (let ((mincol (format:par pars l 0 #f "mincol"))
		(padchar (integer->char
			  (format:par pars l 1 format:space-ch #f)))
		(commachar (integer->char
			    (format:par pars l 2 (char->integer #\,) #f)))
		(commawidth (format:par pars l 3 3 "commawidth")))
	    (if mincol
		(let ((numlen numstr-len)) ; calc. the output len of number
		  (if (and (memq modifier '(at colon-at)) (> number 0))
		      (set! numlen (+ numlen 1)))
		  (if (memq modifier '(colon colon-at))
		      (set! numlen (+ (quotient (- numstr-len 
						   (if (< number 0) 2 1))
						commawidth)
				      numlen)))
		  (if (> mincol numlen)
		      (format:out-fill (- mincol numlen) padchar))))
	    (if (and (memq modifier '(at colon-at))
		     (> number 0))
		(format:out-char #\+))
	    (if (memq modifier '(colon colon-at)) ; insert comma character
		(let ((start (remainder numstr-len commawidth))
		      (ns (if (< number 0) 1 0)))
		  (format:out-substr numstr 0 start)
		  (do ((i start (+ i commawidth)))
		      ((>= i numstr-len))
		    (if (> i ns)
			(format:out-char commachar))
		    (format:out-substr numstr i (+ i commawidth))))
		(format:out-str numstr)))))))

(define (format:tabulate modifier pars)
  (let ((l (length pars)))
    (let ((colnum (format:par pars l 0 1 "colnum"))
	  (colinc (format:par pars l 1 1 "colinc"))
	  (padch (integer->char (format:par pars l 2 format:space-ch #f))))
      (case modifier
	((colon colon-at)
	 (format:error "unsupported modifier for ~~t"))
	((at)				; relative tabulation
	 (format:out-fill
	  (if (= colinc 0)
	      colnum			; colnum = colrel
	      (do ((c 0 (+ c colinc))
		   (col (+ format:output-col colnum)))
		  ((>= c col)
		   (- c format:output-col))))
	  padch))
	(else				; absolute tabulation
	 (format:out-fill
	  (cond
	   ((< format:output-col colnum)
	    (- colnum format:output-col))
	   ((= colinc 0)
	    0)
	   (else
	    (do ((c colnum (+ c colinc)))
		((>= c format:output-col)
		 (- c format:output-col)))))
	  padch))))))


;; roman numerals (from [e-mail]).

(define format:roman-alist
  '((1000 #\M) (500 #\D) (100 #\C) (50 #\L)
    (10 #\X) (5 #\V) (1 #\I)))

(define format:roman-boundary-values
  '(100 100 10 10 1 1 #f))

(define format:num->old-roman
  (lambda (n)
    (if (and (integer? n) (>= n 1))
	(let loop ((n n)
		   (romans format:roman-alist)
		   (s '()))
	  (if (null? romans) (list->string (reverse s))
	      (let ((roman-val (caar romans))
		    (roman-dgt (cadar romans)))
		(do ((q (quotient n roman-val) (- q 1))
		     (s s (cons roman-dgt s)))
		    ((= q 0)
		     (loop (remainder n roman-val)
		       (cdr romans) s))))))
	(format:error "only positive integers can be romanized"))))

(define format:num->roman
  (lambda (n)
    (if (and (integer? n) (> n 0))
	(let loop ((n n)
		   (romans format:roman-alist)
		   (boundaries format:roman-boundary-values)
		   (s '()))
	  (if (null? romans)
	      (list->string (reverse s))
	      (let ((roman-val (caar romans))
		    (roman-dgt (cadar romans))
		    (bdry (car boundaries)))
		(let loop2 ((q (quotient n roman-val))
			    (r (remainder n roman-val))
			    (s s))
		  (if (= q 0)
		      (if (and bdry (>= r (- roman-val bdry)))
			  (loop (remainder r bdry) (cdr romans)
			    (cdr boundaries)
			    (cons roman-dgt
			      (append
				(cdr (assv bdry romans))
				s)))
			  (loop r (cdr romans) (cdr boundaries) s))
		      (loop2 (- q 1) r (cons roman-dgt s)))))))
	(format:error "only positive integers can be romanized"))))

;; cardinals & ordinals (from [e-mail])

(define format:cardinal-ones-list
  '(#f "one" "two" "three" "four" "five"
     "six" "seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen"
     "fourteen" "fifteen" "sixteen" "seventeen" "eighteen"
     "nineteen"))

(define format:cardinal-tens-list
  '(#f #f "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty"
     "ninety"))

(define format:num->cardinal999
  (lambda (n)
    ;this procedure is inspired by the Bruno Haible's CLisp
    ;function format-small-cardinal, which converts numbers
    ;in the range 1 to 999, and is used for converting each
    ;thousand-block in a larger number
    (let* ((hundreds (quotient n 100))
	   (tens+ones (remainder n 100))
	   (tens (quotient tens+ones 10))
	   (ones (remainder tens+ones 10)))
      (append
	(if (> hundreds 0)
	    (append
	      (string->list
		(list-ref format:cardinal-ones-list hundreds))
	      (string->list" hundred")
	      (if (> tens+ones 0) '(#\space) '()))
	    '())
	(if (< tens+ones 20)
	    (if (> tens+ones 0)
		(string->list
		  (list-ref format:cardinal-ones-list tens+ones))
		'())
	    (append
	      (string->list
		(list-ref format:cardinal-tens-list tens))
	      (if (> ones 0)
		  (cons #\-
		    (string->list
		      (list-ref format:cardinal-ones-list ones)))
		  '())))))))

(define format:cardinal-thousand-block-list
  '("" " thousand" " million" " billion" " trillion" " quadrillion"
     " quintillion" " sextillion" " septillion" " octillion" " nonillion"
     " decillion" " undecillion" " duodecillion" " tredecillion"
     " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion"
     " octodecillion" " novemdecillion" " vigintillion"))

(define format:num->cardinal
  (lambda (n)
    (cond ((not (integer? n))
	   (format:error
	     "only integers can be converted to English cardinals"))
	  ((= n 0) "zero")
	  ((< n 0) (string-append "minus " (format:num->cardinal (- n))))
	  (else
	    (let ((power3-word-limit
		    (length format:cardinal-thousand-block-list)))
	      (let loop ((n n)
			 (power3 0)
			 (s '()))
		(if (= n 0)
		    (list->string s)
		    (let ((n-before-block (quotient n 1000))
			  (n-after-block (remainder n 1000)))
		      (loop n-before-block
			(+ power3 1)
			(if (> n-after-block 0)
			    (append
			      (if (> n-before-block 0)
				  (string->list ", ") '())
			      (format:num->cardinal999 n-after-block)
			      (if (< power3 power3-word-limit)
				  (string->list
				    (list-ref
				     format:cardinal-thousand-block-list
				     power3))
				  (append
				    (string->list " times ten to the ")
				    (string->list
				      (format:num->ordinal
					(* power3 3)))
				    (string->list " power")))
			      s)
			    s))))))))))

(define format:ordinal-ones-list
  '(#f "first" "second" "third" "fourth" "fifth"
     "sixth" "seventh" "eighth" "ninth" "tenth" "eleventh" "twelfth"
     "thirteenth" "fourteenth" "fifteenth" "sixteenth" "seventeenth"
     "eighteenth" "nineteenth"))

(define format:ordinal-tens-list
  '(#f #f "twentieth" "thirtieth" "fortieth" "fiftieth" "sixtieth"
     "seventieth" "eightieth" "ninetieth"))

(define format:num->ordinal
  (lambda (n)
    (cond ((not (integer? n))
	   (format:error
	     "only integers can be converted to English ordinals"))
	  ((= n 0) "zeroth")
	  ((< n 0) (string-append "minus " (format:num->ordinal (- n))))
	  (else
	    (let ((hundreds (quotient n 100))
		  (tens+ones (remainder n 100)))
	      (string-append
		(if (> hundreds 0)
		    (string-append
		      (format:num->cardinal (* hundreds 100))
		      (if (= tens+ones 0) "th" " "))
		    "")
		(if (= tens+ones 0) ""
		    (if (< tens+ones 20)
			(list-ref format:ordinal-ones-list tens+ones)
			(let ((tens (quotient tens+ones 10))
			      (ones (remainder tens+ones 10)))
			  (if (= ones 0)
			      (list-ref format:ordinal-tens-list tens)
			      (string-append
				(list-ref format:cardinal-tens-list tens)
				"-"
				(list-ref format:ordinal-ones-list ones))))
			))))))))

;; format fixed flonums (~F)

(define (format:out-fixed modifier number pars)
  (if (not (or (number? number) (string? number)))
      (format:error "argument is not a number or a number string"))

  (let ((l (length pars)))
    (let ((width (format:par pars l 0 #f "width"))
	  (digits (format:par pars l 1 #f "digits"))
	  (scale (format:par pars l 2 0 #f))
	  (overch (format:par pars l 3 #f #f))
	  (padch (format:par pars l 4 format:space-ch #f)))

    (if digits

	(begin				; fixed precision
	  (format:parse-float 
	   (if (string? number) number (number->string number)) #t scale)
	  (if (<= (- format:fn-len format:fn-dot) digits)
	      (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
	      (format:fn-round digits))
	  (if width
	      (let ((numlen (+ format:fn-len 1)))
		(if (or (not format:fn-pos?) (eq? modifier 'at))
		    (set! numlen (+ numlen 1)))
		(if (and (= format:fn-dot 0) (> width (+ digits 1)))
		    (set! numlen (+ numlen 1)))
		(if (< numlen width)
		    (format:out-fill (- width numlen) (integer->char padch)))
		(if (and overch (> numlen width))
		    (format:out-fill width (integer->char overch))
		    (format:fn-out modifier (> width (+ digits 1)))))
	      (format:fn-out modifier #t)))

	(begin				; free precision
	  (format:parse-float
	   (if (string? number) number (number->string number)) #t scale)
	  (format:fn-strip)
	  (if width
	      (let ((numlen (+ format:fn-len 1)))
		(if (or (not format:fn-pos?) (eq? modifier 'at))
		    (set! numlen (+ numlen 1)))
		(if (= format:fn-dot 0)
		    (set! numlen (+ numlen 1)))
		(if (< numlen width)
		    (format:out-fill (- width numlen) (integer->char padch)))
		(if (> numlen width)	; adjust precision if possible
		    (let ((dot-index (- numlen
					(- format:fn-len format:fn-dot))))
		      (if (> dot-index width)
			  (if overch	; numstr too big for required width
			      (format:out-fill width (integer->char overch))
			      (format:fn-out modifier #t))
			  (begin
			    (format:fn-round (- width dot-index))
			    (format:fn-out modifier #t))))
		    (format:fn-out modifier #t)))
	      (format:fn-out modifier #t)))))))

;; format exponential flonums (~E)

(define (format:out-expon modifier number pars)
  (if (not (or (number? number) (string? number)))
      (format:error "argument is not a number"))

  (let ((l (length pars)))
    (let ((width (format:par pars l 0 #f "width"))
	  (digits (format:par pars l 1 #f "digits"))
	  (edigits (format:par pars l 2 #f "exponent digits"))
	  (scale (format:par pars l 3 1 #f))
	  (overch (format:par pars l 4 #f #f))
	  (padch (format:par pars l 5 format:space-ch #f))
	  (expch (format:par pars l 6 #f #f)))
	 
    (if digits				; fixed precision

	(let ((digits (if (> scale 0)