#lang scheme/base
(define-syntax %call-with-output-string
(syntax-rules ()
((_ PROC)
(let ((port (open-output-string)))
(PROC port)
(let ((str (get-output-string port)))
(close-output-port port)
str)))))
(define %short-scale-english
'(#f
"thousand"
"million"
"billion"
"trillion"
"quadrillion"
"quintillion"
"sextillion"
"septillion"
"octillion"
"nonillion"
"decillion"
"undecillion"
"deuodecillion"
"tredecillion"
"quattuordecillion"
"quindecillion"
"sexdecillion"
"septendecillion"
"octodecillion"
"novemdecillion"
"vigintillion"
))
(define %long-scale-english
'(#f
"thousand"
"million" "thousand million"
"billion" "thousand billion"
"trillion" "thousand trillion"
"quadrillion" "thousand quadrillion"
"quintillion" "thousand quintillion"
"sextillion" "thousand sextillion"
"septillion" "thousand septillion"
"octillion" "thousand octillion"
"nonillion" "thousand nonillion"
"decillion" "thousand decillion"
"undecillion" "thousand undecillion"
"deuodecillion" "thousand deuodecillion"
"tredecillion" "thousand tredecillion"
"quattuordecillion" "thousand quattuordecillion"
"quindecillion" "thousand quindecillion"
"sexdecillion" "thousand sexdecillion"
"septendecillion" "thousand septendecillion"
"octodecillion" "thousand octodecillion"
"novemdecillion" "thousand novemdecillion"
"vigintillion" "thousand vigintillion"
))
(define (write-number-as-english num port)
(write-number-as-short-scale-english num port))
(define (write-number-as-short-scale-english num port)
(%spell-number num port %short-scale-english))
(define (write-number-as-long-scale-english num port)
(%spell-number num port %long-scale-english))
(define (%spell-number num port scale)
(cond
((not (number? num)) (error "not a number:" num))
((integer? num ) (%spell-integer num port scale))
((rational? num ) (%spell-noninteger num port scale))
(else (error "cannot spell number:" num))))
(define (%spell-integer num port scale)
(or (integer? num) (error "not an integer:" num))
(let spell ((num num))
(if (< num 0)
(begin (display "negative " port)
(spell (- num)))
(%spell-nonnegative-integer num port scale))))
(define (%spell-integer-substring str start end port scale)
(%spell-integer (string->number (substring str start end))
port
scale))
(define (%spell-noninteger num port scale)
(or (and (number? num) (rational? num)) (error "not a rational number:" num))
(let spell ((num num))
(if (< num 0)
(begin (display "negative " port)
(spell (- num)))
(%spell-nonnegative-noninteger num port scale))))
(define %spell-nonnegative-integer
(letrec ((split-integer
(lambda (num divisor)
(let ((first (truncate (/ num divisor))))
(values first (- num (* first divisor))))))
(zero-through-nineteen
'#("zero" "one" "two" "three" "four" "five" "six" "seven" "eight"
"nine" "ten" "eleven" "twelve" "thirteen" "fourteen" "fifteen"
"sixteen" "seventeen" "eighteen" "nineteen"))
(twenty-through-ninety
'#("twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty"
"ninety")))
(lambda (orig-num port scale)
(let loop ((num orig-num)
(names scale))
(let-values (((thousands nonthousands) (split-integer num 1000)))
(or (zero? thousands)
(if (null? names)
(error "scale names exhausted for:" orig-num)
(loop thousands (cdr names))))
(if (zero? nonthousands)
(and (zero? thousands)
(display "zero" port))
(let-values (((hundreds nonhundreds)
(split-integer nonthousands 100)))
(or (zero? hundreds)
(begin
(or (zero? thousands)
(write-char #\space port))
(display (vector-ref zero-through-nineteen hundreds)
port)
(display " hundred" port)))
(or (zero? nonhundreds)
(begin
(or (and (zero? thousands) (zero? hundreds))
(write-char #\space port))
(if (< nonhundreds 20)
(display (vector-ref zero-through-nineteen
nonhundreds)
port)
(let-values (((tens ones)
(split-integer nonhundreds 10)))
(display (vector-ref twenty-through-ninety
(- tens 2))
port)
(or (zero? ones)
(begin
(write-char #\- port)
(display (vector-ref zero-through-nineteen
ones)
port)))))))
(cond ((car names) => (lambda (scale)
(write-char #\space port)
(display scale port)))))))))))
(define (%spell-nonnegative-noninteger num port scale)
(or (and (number? num) (rational? num))
(error "wrong kind of number:" num))
(let* ((str (number->string num))
(len (string-length str)))
(let loop-for-point ((i 0))
(if (= i len)
(error "number string empty:" num str)
(case (string-ref str i)
((#\/)
(if (zero? i)
(display "zero" port)
(%spell-integer-substring str 0 i port scale))
(let ((start (+ 1 i)))
(let loop-for-decimal-digits ((i start))
(if (= i len)
(if (= start i)
(error "number string empty after slash:" num str)
(begin
(display " over " port)
(%spell-integer-substring
str start i port scale)))
(case (string-ref str i)
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(loop-for-decimal-digits (+ 1 i)))
(else
(error
"number string has unknown character after slash:"
num str i)))))))
((#\. #\,)
(if (zero? i)
(display "zero" port)
(%spell-integer-substring str 0 i port scale))
(display " point" port)
(if (= (+ 1 i) len)
(display " zero" port)
(let loop-for-decimal-digits ((i (+ 1 i)))
(and (< i len)
(begin
(display
(case (string-ref str i)
((#\0) " zero")
((#\1) " one")
((#\2) " two")
((#\3) " three")
((#\4) " four")
((#\5) " five")
((#\6) " six")
((#\7) " seven")
((#\8) " eight")
((#\9) " nine")
(else
(error "cannot spell number with string:"
num str)))
port)
(loop-for-decimal-digits (+ 1 i)))))))
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(loop-for-point (+ 1 i)))
(else (error "cannot spell number with string:" num str)))))))
(define (number->english num)
(number->short-scale-english num))
(define (number->short-scale-english num)
(%call-with-output-string
(lambda (port)
(write-number-as-short-scale-english num port))))
(define (number->long-scale-english num)
(%call-with-output-string
(lambda (port)
(write-number-as-long-scale-english num port))))
(provide
number->english
number->long-scale-english
number->short-scale-english
write-number-as-english
write-number-as-long-scale-english
write-number-as-short-scale-english)