extra/math/text/english/english.factor

   1 ! Copyright (c) 2007, 2008 Aaron Schaefer.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: combinators.short-circuit grouping kernel math math.parser
   4 math.text.utils namespaces sequences ;
   5 IN: math.text.english
   6
   7 <PRIVATE
   8
   9 : small-numbers ( n -- str )
  10     {
  11         "zero" "one" "two" "three" "four" "five" "six"
  12         "seven" "eight" "nine" "ten" "eleven" "twelve"
  13         "thirteen" "fourteen" "fifteen" "sixteen" "seventeen"
  14         "eighteen" "nineteen"
  15     } nth ;
  16
  17 : tens ( n -- str )
  18     {
  19         f f "twenty" "thirty" "forty" "fifty" "sixty"
  20         "seventy" "eighty" "ninety"
  21     } nth ;
  22
  23 : scale-numbers ( n -- str )  ! up to 10^99
  24     {
  25         f "thousand" "million" "billion" "trillion" "quadrillion"
  26         "quintillion" "sextillion" "septillion" "octillion"
  27         "nonillion" "decillion" "undecillion" "duodecillion"
  28         "tredecillion" "quattuordecillion" "quindecillion"
  29         "sexdecillion" "septendecillion" "octodecillion" "novemdecillion"
  30         "vigintillion" "unvigintillion" "duovigintillion" "trevigintillion"
  31         "quattuorvigintillion" "quinvigintillion" "sexvigintillion"
  32         "septvigintillion" "octovigintillion" "novemvigintillion"
  33         "trigintillion" "untrigintillion" "duotrigintillion"
  34     } nth ;
  35
  36 SYMBOL: and-needed?
  37 : set-conjunction ( seq -- )
  38     first { [ 100 < ] [ 0 > ] } 1&& and-needed? set ;
  39
  40 : negative-text ( n -- str )
  41     0 < "negative " "" ? ;
  42
  43 : hundreds-place ( n -- str )
  44     100 /mod over 0 = [
  45         2drop ""
  46     ] [
  47         [ small-numbers " hundred" append ] dip
  48         0 = [ " and " append ] unless
  49     ] if ;
  50
  51 : tens-place ( n -- str )
  52     100 mod dup 20 >= [
  53         10 /mod [ tens ] dip
  54         dup 0 = [ drop ] [ small-numbers "-" glue ] if
  55     ] [
  56         dup 0 = [ drop "" ] [ small-numbers ] if
  57     ] if ;
  58
  59 : 3digits>text ( n -- str )
  60     [ hundreds-place ] [ tens-place ] bi append ;
  61
  62 : text-with-scale ( index seq -- str )
  63     [ nth 3digits>text ] [ drop scale-numbers ] 2bi
  64     [ " " glue ] unless-empty ;
  65
  66 : append-with-conjunction ( str1 str2 -- newstr )
  67     over length 0 = [
  68         nip
  69     ] [
  70         swap and-needed? get " and " ", " ?
  71         glue and-needed? off
  72     ] if ;
  73
  74 : (recombine) ( str index seq -- newstr )
  75     2dup nth 0 = [
  76         2drop
  77     ] [
  78         text-with-scale append-with-conjunction
  79     ] if ;
  80
  81 : recombine ( seq -- str )
  82     dup length 1 = [
  83         first 3digits>text
  84     ] [
  85         [ set-conjunction "" ] [ length ] [ ] tri
  86         [ (recombine) ] curry each
  87     ] if ;
  88
  89 : (number>text) ( n -- str )
  90     [ negative-text ] [ abs 3 digit-groups recombine ] bi append ;
  91
  92 PRIVATE>
  93
  94 : number>text ( n -- str )
  95     dup zero? [ small-numbers ] [ [ (number>text) ] with-scope ] if ;
  96