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
   4 math.functions math.parser math.text.utils namespaces sequences
   5 splitting ;
   6 IN: math.text.english
   7
   8 <PRIVATE
   9
  10 : small-numbers ( n -- str )
  11     {
  12         "zero" "one" "two" "three" "four" "five" "six"
  13         "seven" "eight" "nine" "ten" "eleven" "twelve"
  14         "thirteen" "fourteen" "fifteen" "sixteen" "seventeen"
  15         "eighteen" "nineteen"
  16     } nth ;
  17
  18 : tens ( n -- str )
  19     {
  20         f f "twenty" "thirty" "forty" "fifty" "sixty"
  21         "seventy" "eighty" "ninety"
  22     } nth ;
  23
  24 : scale-numbers ( n -- str )  ! up to 10^99
  25     {
  26         f "thousand" "million" "billion" "trillion" "quadrillion"
  27         "quintillion" "sextillion" "septillion" "octillion"
  28         "nonillion" "decillion" "undecillion" "duodecillion"
  29         "tredecillion" "quattuordecillion" "quindecillion"
  30         "sexdecillion" "septendecillion" "octodecillion" "novemdecillion"
  31         "vigintillion" "unvigintillion" "duovigintillion" "trevigintillion"
  32         "quattuorvigintillion" "quinvigintillion" "sexvigintillion"
  33         "septvigintillion" "octovigintillion" "novemvigintillion"
  34         "trigintillion" "untrigintillion" "duotrigintillion"
  35     } nth ;
  36
  37 SYMBOL: and-needed?
  38 : set-conjunction ( seq -- )
  39     first { [ 100 < ] [ 0 > ] } 1&& and-needed? set ;
  40
  41 : negative-text ( n -- str )
  42     0 < "negative " "" ? ;
  43
  44 : hundreds-place ( n -- str )
  45     100 /mod over 0 = [
  46         2drop ""
  47     ] [
  48         [ small-numbers " hundred" append ] dip
  49         0 = [ " and " append ] unless
  50     ] if ;
  51
  52 : tens-place ( n -- str )
  53     100 mod dup 20 >= [
  54         10 /mod [ tens ] dip
  55         [ small-numbers "-" glue ] unless-zero
  56     ] [
  57         [ "" ] [ small-numbers ] if-zero
  58     ] if ;
  59
  60 : 3digits>text ( n -- str )
  61     [ hundreds-place ] [ tens-place ] bi append ;
  62
  63 : text-with-scale ( index seq -- str )
  64     [ nth 3digits>text ] [ drop scale-numbers ] 2bi
  65     [ " " glue ] unless-empty ;
  66
  67 : append-with-conjunction ( str1 str2 -- newstr )
  68     over length 0 = [
  69         nip
  70     ] [
  71         swap and-needed? get " and " ", " ?
  72         glue and-needed? off
  73     ] if ;
  74
  75 : (recombine) ( str index seq -- newstr )
  76     2dup nth 0 = [
  77         2drop
  78     ] [
  79         text-with-scale append-with-conjunction
  80     ] if ;
  81
  82 : recombine ( seq -- str )
  83     dup length 1 = [
  84         first 3digits>text
  85     ] [
  86         [ set-conjunction "" ] [ length ] [ ] tri
  87         [ (recombine) ] curry each-integer
  88     ] if ;
  89
  90 : (number>text) ( n -- str )
  91     [ negative-text ] [ abs 3 digit-groups recombine ] bi append ;
  92
  93 PRIVATE>
  94
  95 GENERIC: number>text ( n -- str )
  96
  97 M: integer number>text
  98     [ "zero" ] [ [ (number>text) ] with-scope ] if-zero ;
  99
 100 M: ratio number>text
 101     >fraction [ number>text ] bi@ " divided by " glue ;
 102
 103 M: float number>text
 104     number>string "." split1 [
 105         "-" ?head
 106         [ string>number number>text ]
 107         [ [ "negative " prepend ] when ] bi*
 108     ] [
 109         [ CHAR: 0 - small-numbers ] { } map-as " " join
 110     ] bi* " point " glue ;
 111
 112 M: complex number>text
 113     >rect
 114     [ number>text " i" append ]
 115     [
 116         [ 0 < " minus " " plus " ? ]
 117         [ abs number>text " j" append ] bi
 118     ] bi* 3append ;