;;; @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

(module numspell (write-number-as-english
		  write-number-as-short-scale-english
		  write-number-as-long-scale-english
		  number->english
		  number->short-scale-english
		  number->long-scale-english)
  (import scheme chicken)
  (use numbers)

;;; @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 (inexact->exact 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
                                               (inexact->exact nonhundreds))
                                   port)
                          (let-values (((tens ones)
                                        (split-integer nonhundreds 10)))
                            (display (vector-ref twenty-through-ninety
                                                 (inexact->exact (- tens 2)))
                                     port)
                            (or (zero? ones)
                                (begin
                                  (write-char #\- port)
                                  (display (vector-ref zero-through-nineteen
                                                       (inexact->exact 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))))

;;; @unnumberedsec History

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

)