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 namespaces
   4     sequences ;
   5 IN: math.text.english
   6
   7 <PRIVATE
   8
   9 : small-numbers ( n -- str )
  10     { "Zero" "One" "Two" "Three" "Four" "Five" "Six" "Seven" "Eight" "Nine"
  11     "Ten" "Eleven" "Twelve" "Thirteen" "Fourteen" "Fifteen" "Sixteen"
  12     "Seventeen" "Eighteen" "Nineteen" } nth ;
  13
  14 : tens ( n -- str )
  15     { f f "Twenty" "Thirty" "Forty" "Fifty" "Sixty" "Seventy" "Eighty" "Ninety" } nth ;
  16
  17 : scale-numbers ( n -- str )  ! up to 10^99
  18     { f "Thousand" "Million" "Billion" "Trillion" "Quadrillion" "Quintillion"
  19     "Sextillion" "Septillion" "Octillion" "Nonillion" "Decillion" "Undecillion"
  20     "Duodecillion" "Tredecillion" "Quattuordecillion" "Quindecillion"
  21     "Sexdecillion" "Septendecillion" "Octodecillion" "Novemdecillion"
  22     "Vigintillion" "Unvigintillion" "Duovigintillion" "Trevigintillion"
  23     "Quattuorvigintillion" "Quinvigintillion" "Sexvigintillion"
  24     "Septvigintillion" "Octovigintillion" "Novemvigintillion" "Trigintillion"
  25     "Untrigintillion" "Duotrigintillion" } nth ;
  26
  27 SYMBOL: and-needed?
  28 : set-conjunction ( seq -- )
  29     first { [ 100 < ] [ 0 > ] } 1&& and-needed? set ;
  30
  31 : negative-text ( n -- str )
  32     0 < "Negative " "" ? ;
  33
  34 : 3digit-groups ( n -- seq )
  35     [ dup 0 > ] [ 1000 /mod ] [ ] produce nip ;
  36
  37 : hundreds-place ( n -- str )
  38     100 /mod over 0 = [
  39         2drop ""
  40     ] [
  41         [ small-numbers " Hundred" append ] dip
  42         0 = [ " and " append ] unless
  43     ] if ;
  44
  45 : tens-place ( n -- str )
  46     100 mod dup 20 >= [
  47         10 /mod [ tens ] dip
  48         dup 0 = [ drop ] [ small-numbers "-" glue ] if
  49     ] [
  50         dup 0 = [ drop "" ] [ small-numbers ] if
  51     ] if ;
  52
  53 : 3digits>text ( n -- str )
  54     [ hundreds-place ] [ tens-place ] bi append ;
  55
  56 : text-with-scale ( index seq -- str )
  57     [ nth 3digits>text ] [ drop scale-numbers ] 2bi
  58     [ " " glue ] unless-empty ;
  59
  60 : append-with-conjunction ( str1 str2 -- newstr )
  61     over length 0 = [
  62         nip
  63     ] [
  64         swap and-needed? get " and " ", " ?
  65         glue and-needed? off
  66     ] if ;
  67
  68 : (recombine) ( str index seq -- newstr )
  69     2dup nth 0 = [
  70         2drop
  71     ] [
  72         text-with-scale append-with-conjunction
  73     ] if ;
  74
  75 : recombine ( seq -- str )
  76     dup length 1 = [
  77         first 3digits>text
  78     ] [
  79         [ set-conjunction "" ] [ length ] [ ] tri
  80         [ (recombine) ] curry each
  81     ] if ;
  82
  83 : (number>text) ( n -- str )
  84     [ negative-text ] [ abs 3digit-groups recombine ] bi append ;
  85
  86 PRIVATE>
  87
  88 : number>text ( n -- str )
  89     dup zero? [ small-numbers ] [ [ (number>text) ] with-scope ] if ;
  90