extra/math/text/english/english.factor

   1 ! Copyright (c) 2007 Aaron Schaefer.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: combinators.lib kernel math math.functions math.parser namespaces
   4     sequences splitting sequences.lib ;
   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 { [ dup 100 < ] [ dup 0 > ] } && and-needed? set drop ;
  30
  31 : negative-text ( n -- str )
  32     0 < "Negative " "" ? ;
  33
  34 : 3digit-groups ( n -- seq )
  35     number>string <reversed> 3 <groups>
  36     [ reverse string>number ] map ;
  37
  38 : hundreds-place ( n -- str )
  39     100 /mod swap dup zero? [
  40         2drop ""
  41     ] [
  42         small-numbers " Hundred" append
  43         swap zero? [ " and " append ] unless
  44     ] if ;
  45
  46 : tens-place ( n -- str )
  47     100 mod dup 20 >= [
  48         10 /mod [ tens ] dip
  49         dup zero? [ drop ] [ "-" swap small-numbers 3append ] if
  50     ] [
  51         dup zero? [ drop "" ] [ small-numbers ] if
  52     ] if ;
  53
  54 : 3digits>text ( n -- str )
  55     dup hundreds-place swap tens-place append ;
  56
  57 : text-with-scale ( index seq -- str )
  58     dupd nth 3digits>text swap
  59     scale-numbers dup empty? [
  60         drop
  61     ] [
  62         " " swap 3append
  63     ] if ;
  64
  65 : append-with-conjunction ( str1 str2 -- newstr )
  66     over length zero? [
  67         nip
  68     ] [
  69         and-needed? get " and " ", " ? rot 3append
  70         and-needed? off
  71     ] if ;
  72
  73 : (recombine) ( str index seq -- newstr seq )
  74     2dup nth zero? [
  75         nip
  76     ] [
  77         [ text-with-scale ] keep
  78         -rot append-with-conjunction swap
  79     ] if ;
  80
  81 : recombine ( seq -- str )
  82     dup length 1 = [
  83         first 3digits>text
  84     ] [
  85         dup set-conjunction "" swap
  86         dup length [ swap (recombine) ] each drop
  87     ] if ;
  88
  89 : (number>text) ( n -- str )
  90     dup negative-text swap abs 3digit-groups recombine append ;
  91
  92 PRIVATE>
  93
  94 : number>text ( n -- str )
  95     dup zero? [
  96         small-numbers
  97     ] [
  98         [ (number>text) ] with-scope
  99     ] if ;
 100