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