;;; @Package     numspell.scm
;;; @Subtitle    Spelling Numbers as English in Scheme
;;; @HomePage    http://www.neilvandyke.org/numspell-scm/
;;; @Author      Neil Van Dyke
;;; @AuthorEmail neil@@neilvandyke.org
;;; @Version     0.1
;;; @Date        2006-05-07

;; $Id: numspell.scm,v 1.28 2006-05-07 07:20:35 neil Exp $

;;; @legal
;;; Copyright @copyright{} 2006 Neil Van Dyke.  This program is Free Software;
;;; you can redistribute it and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software Foundation; either
;;; version 2.1 of the License, or (at your option) any later version.  This
;;; program is distributed in the hope that it will be useful, but without any
;;; warranty; without even the implied warranty of merchantability or fitness
;;; for a particular purpose.  See
;;; @indicateurl{http://www.gnu.org/copyleft/lesser.html} for details.  For
;;; other license options and consulting, contact the author.
;;; @end legal

(define-syntax %numspell:testeez
  (syntax-rules () ((_ x ...)
                    ;; (testeez x ...)
                    (error "Tests disabled.")
                    )))

;;; @section Introduction

;;; The @code{numspell.scm} library provides the ability to ``spell'' Scheme
;;; numbers in English.  This is useful for writing numbers on banking checks
;;; and other legal documents, as well as for speech generation.
;;;
;;; Most rational numbers in Scheme are presently supported.  For example:
;;;
;;; @lisp
;;; (number->english 123456)
;;; @result{} "one hundred twenty-three thousand four hundred fifty-six"
;;; (number->english (/ 4 -6))
;;; @result{} "negative two over three"
;;; (number->english (exact->inexact (/ 4 -6)))
;;; @result{} "negative zero point six six six six six six" ; @r{@i{approx.}}
;;; @end lisp
;;;
;;; The number names supported by @code{numspell.scm} are taken from a version
;;; of the @url{http://en.wikipedia.org/wiki/Names_of_large_numbers, Wikipedia
;;; ``Names of large numbers''} article.  Both
;;; @url{http://en.wikipedia.org/wiki/Long_and_short_scales, short and long
;;; scales} are supported, through different procedures, with short scale being
;;; the default.  For example:
;;;
;;; @lisp
;;; (number->english             (expt 10 15))
;;; @result{} "one quadrillion"
;;; (number->short-scale-english (expt 10 15))
;;; @result{} "one quadrillion"
;;; (number->long-scale-english  (expt 10 15))
;;; @result{} "one thousand billion"
;;; @end lisp
;;;
;;; Note: Some numbers, such as very large and very small non-integers printed
;;; by some Scheme implementations in exponential notation, are not supported
;;; by the current version of @code{numspell.scm}.
;;;
;;; @code{numspell.scm} requires R5RS, SRFI-6 (string ports), and SRFI-11
;;; (@code{let-values}).

;;; @section Interface

;;; The public interface consists of a few procedures.

(define-syntax %numspell: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 %numspell: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 %numspell: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"
    ))

;;; @defproc  write-number-as-english             num port
;;; @defprocx write-number-as-short-scale-english num port
;;; @defprocx write-number-as-long-scale-english  num port
;;;
;;; Spell number @var{num} to output port @var{port}.  If @var{num} cannot be
;;; spelt, an error is signaled.

(define (write-number-as-english num port)
  (write-number-as-short-scale-english num port))

(define (write-number-as-short-scale-english num port)
  (%numspell:spell-number num port %numspell:short-scale-english))

(define (write-number-as-long-scale-english num port)
  (%numspell:spell-number num port %numspell:long-scale-english))

(define (%numspell:spell-number num port scale)
  (cond
   ((not (number? num)) (error "not a number:" num))
   ((integer?     num ) (%numspell:spell-integer    num port scale))
   ((rational?    num ) (%numspell:spell-noninteger num port scale))
   (else (error "cannot spell number:" num))))

(define (%numspell: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)))
        (%numspell:spell-nonnegative-integer num port scale))))

(define (%numspell:spell-integer-substring str start end port scale)
  ;; Note: We could implement this more efficiently, at the cost of maintaining
  ;; two seperate algorithms (one that takes an integer, and one that takes a
  ;; string).
  (%numspell:spell-integer (string->number (substring str start end))
                           port
                           scale))

(define (%numspell: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)))
        (%numspell:spell-nonnegative-noninteger num port scale))))

(define %numspell: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 (num port scale)
      (let loop ((num   num)
                 (names scale))
        (let-values (((thousands nonthousands) (split-integer num 1000)))
          (or (zero? thousands) (loop thousands (cdr names)))
          (if (zero? nonthousands)
              (if (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 (%numspell: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)
                 (%numspell: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)
                           (%numspell: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)))))))
            ((#\. #\,)
             ;; Note: We permit comma as a point character, although we've not
             ;; yet heard of a Scheme implementation using a comma that way.
             (if (zero? i)
                 (display "zero" port)
                 (%numspell: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)))
                   (if (< 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)))))))

;;; @defproc  number->english             num
;;; @defprocx number->short-scale-english num
;;; @defprocx number->long-scale-english  num
;;;
;;; Yield a string that spells number @var{num}.  If @var{num} cannot be spelt,
;;; an error is signaled.


(define (number->english num)
  (number->short-scale-english num))

(define (number->short-scale-english num)
  (%numspell:call-with-output-string
   (lambda (port)
     (write-number-as-short-scale-english num port))))

(define (number->long-scale-english num)
  (%numspell:call-with-output-string
   (lambda (port)
     (write-number-as-long-scale-english num port))))

;;; @section Tests

;;; The @code{numspell.scm} test suite can be enabled by editing the source
;;; code file and loading @uref{http://www.neilvandyke.org/testeez/, Testeez}.

(define (%numspell:test)
  (%numspell:testeez
   "numspell.scm"
   ;;
   (test/equal "" (number->english 0) "zero")
   (test/equal "" (number->english 1) "one")
   (test/equal "" (number->english 2) "two")
   (test/equal "" (number->english 3) "three")
   (test/equal "" (number->english 4) "four")
   (test/equal "" (number->english 5) "five")
   (test/equal "" (number->english 6) "six")
   (test/equal "" (number->english 7) "seven")
   (test/equal "" (number->english 8) "eight")
   (test/equal "" (number->english 9) "nine")
   (test/equal "" (number->english 10) "ten")
   (test/equal "" (number->english 11) "eleven")
   (test/equal "" (number->english 12) "twelve")
   (test/equal "" (number->english 13) "thirteen")
   (test/equal "" (number->english 14) "fourteen")
   (test/equal "" (number->english 15) "fifteen")
   (test/equal "" (number->english 16) "sixteen")
   (test/equal "" (number->english 17) "seventeen")
   (test/equal "" (number->english 18) "eighteen")
   (test/equal "" (number->english 19) "nineteen")
   (test/equal "" (number->english 20) "twenty")
   (test/equal "" (number->english 21) "twenty-one")
   (test/equal "" (number->english 30) "thirty")
   (test/equal "" (number->english 40) "forty")
   (test/equal "" (number->english 50) "fifty")
   (test/equal "" (number->english 60) "sixty")
   (test/equal "" (number->english 70) "seventy")
   (test/equal "" (number->english 80) "eighty")
   (test/equal "" (number->english 90) "ninety")
   (test/equal "" (number->english 100) "one hundred")
   (test/equal "" (number->english 102) "one hundred two")
   (test/equal "" (number->english 1002) "one thousand two")
   (test/equal "" (number->english 10002) "ten thousand two")
   (test/equal "" (number->english 100002) "one hundred thousand two")
   (test/equal "" (number->english 1000002) "one million two")
   (test/equal "" (number->english 10000002) "ten million two")
   (test/equal "" (number->english 100000002) "one hundred million two")
   (test/equal "" (number->english 1000000002) "one billion two")
   (test/equal "" (number->english 1000000000002) "one trillion two")
   ;;
   (test/equal "" (number->english 100020003000) "one hundred billion twenty million three thousand")
   ;;
   (test/equal ""
               (number->english 123)
               "one hundred twenty-three")
   (test/equal ""
               (number->english 1234)
               "one thousand two hundred thirty-four")
   (test/equal ""
               (number->english 12345)
               "twelve thousand three hundred forty-five")
   (test/equal ""
               (number->english 123456)
               "one hundred twenty-three thousand four hundred fifty-six")
   (test/equal
    ""
    (number->english 1234567)
    "one million two hundred thirty-four thousand five hundred sixty-seven")
   ;;
   (test/equal
    ""
    (number->english 123456789012345678901234567890)
    "one hundred twenty-three octillion four hundred fifty-six septillion seven hundred eighty-nine sextillion twelve quintillion three hundred forty-five quadrillion six hundred seventy-eight trillion nine hundred one billion two hundred thirty-four million five hundred sixty-seven thousand eight hundred ninety")
   ;;
   (test/equal ""
               (number->english 1/3)
               "one over three")
   ;;
   (test/equal ""
               (number->english 123.0123)
               "one hundred twenty-three point zero one two three")
   ;;

   (test-define ""
                f
                (lambda (n)
                  (let ((x (expt 10 n)))
                    (list (number->short-scale-english x)
                          (number->long-scale-english  x)))))

   (test/equal "" (f 3)  '("one thousand"    "one thousand"))
   (test/equal "" (f 6)  '("one million"     "one million"))
   (test/equal "" (f 9)  '("one billion"     "one thousand million"))
   (test/equal "" (f 12) '("one trillion"    "one billion"))
   (test/equal "" (f 15) '("one quadrillion" "one thousand billion"))
   (test/equal "" (f 18) '("one quintillion" "one trillion"))

   ;;

   (test/equal "" (number->english -1) "negative one")

   ))

;;; @unnumberedsec History

;;; @table @asis
;;;
;;; @item Version 0.1 --- 2006-05-07
;;; Initial release
;;;
;;; @end table