(defparameter *cardinal-ones*
  #(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"))

(defparameter *cardinal-tens*
  #(nil nil "twenty" "thirty" "forty"
        "fifty" "sixty" "seventy" "eighty" "ninety"))

(defparameter *cardinal-teens*
  #("ten" "eleven" "twelve" "thirteen" "fourteen"  ;;; RAD
    "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"))

(defparameter *cardinal-periods*
  #("" " thousand" " million" " billion" " trillion" " quadrillion"
    " quintillion" " sextillion" " septillion" " octillion" " nonillion"
    " decillion" " undecillion" " duodecillion" " tredecillion"
    " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion"
    " octodecillion" " novemdecillion" " vigintillion"))

(defparameter *ordinal-ones*
  #(nil "first" "second" "third" "fourth"
        "fifth" "sixth" "seventh" "eighth" "ninth"))

(defparameter *ordinal-tens*
  #(nil "tenth" "twentieth" "thirtieth" "fortieth"
        "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth"))

(defun format-print-small-cardinal (stream n)
  (multiple-value-bind (hundreds rem) (truncate n 100)
    (when (plusp hundreds)
      (write-string (svref *cardinal-ones* hundreds) stream)
      (write-string " hundred" stream)
      (when (plusp rem)
        (write-char #\space stream)))
    (when (plusp rem)
      (multiple-value-bind (tens ones) (truncate rem 10)
        (cond ((< 1 tens)
              (write-string (svref *cardinal-tens* tens) stream)
              (when (plusp ones)
                (write-char #\- stream)
                (write-string (svref *cardinal-ones* ones) stream)))
             ((= tens 1)
              (write-string (svref *cardinal-teens* ones) stream))
             ((plusp ones)
              (write-string (svref *cardinal-ones* ones) stream)))))))

(defun format-print-cardinal (stream n)
  (cond ((minusp n)
         (write-string "negative " stream)
         (format-print-cardinal-aux stream (- n) 0 n))
        ((zerop n)
         (write-string "zero" stream))
        (t
         (format-print-cardinal-aux stream n 0 n))))

(defun format-print-cardinal-aux (stream n period err)
  (multiple-value-bind (beyond here) (truncate n 1000)
    (unless (<= period 20)
      (error "number too large to print in English: ~:D" err))
    (unless (zerop beyond)
      (format-print-cardinal-aux stream beyond (1+ period) err))
    (unless (zerop here)
      (unless (zerop beyond)
        (write-char #\space stream))
      (format-print-small-cardinal stream here)
      (write-string (svref *cardinal-periods* period) stream))))

(defun format-print-ordinal (stream n)
  (when (minusp n)
    (write-string "negative " stream))
  (let ((number (abs n)))
    (multiple-value-bind (top bot) (truncate number 100)
      (unless (zerop top)
        (format-print-cardinal stream (- number bot)))
      (when (and (plusp top) (plusp bot))
        (write-char #\space stream))
      (multiple-value-bind (tens ones) (truncate bot 10)
        (cond ((= bot 12) (write-string "twelfth" stream))
              ((= tens 1)
               (write-string (svref *cardinal-teens* ones) stream);;;RAD
               (write-string "th" stream))
              ((and (zerop tens) (plusp ones))
               (write-string (svref *ordinal-ones* ones) stream))
              ((and (zerop ones)(plusp tens))
               (write-string (svref *ordinal-tens* tens) stream))
              ((plusp bot)
               (write-string (svref *cardinal-tens* tens) stream)
               (write-char #\- stream)
               (write-string (svref *ordinal-ones* ones) stream))
              ((plusp number)
               (write-string "th" stream))
              (t
               (write-string "zeroth" stream)))))))