extra/math/text/english/english.factor

   1 ! Copyright (c) 2007, 2008, 2018 Aaron Schaefer, 2022 Alexander Ilin.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: combinators combinators.short-circuit kernel math
   4 math.order 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^630
  25     {
  26         { [ dup 41 < ] [
  27             {
  28                 f "thousand" "million" "billion" "trillion" "quadrillion"
  29                 "quintillion" "sextillion" "septillion" "octillion"
  30                 "nonillion" "decillion" "undecillion" "duodecillion"
  31                 "tredecillion" "quattuordecillion" "quindecillion"
  32                 "sexdecillion" "septendecillion" "octodecillion"
  33                 "novemdecillion" "vigintillion" "unvigintillion"
  34                 "duovigintillion" "tresvigintillion" "quattuorvigintillion"
  35                 "quinvigintillion" "sesvigintillion" "septemvigintillion"
  36                 "octovigintillion" "novemvigintillion" "trigintillion"
  37                 "untrigintillion" "duotrigintillion" "trestrigintillion"
  38                 "quattuortrigintillion" "quintrigintillion" "sestrigintillion"
  39                 "septentrigintillion" "octotrigintillion" "noventrigintillion"
  40             } nth
  41         ] }
  42         { [ dup 311 < ] [
  43             41 - 10 /mod [
  44                 {
  45                     "quadragintillion" "quinquagintillion" "sexagintillion"
  46                     "septuagintillion" "octogintillion" "nonagintillion"
  47                     "centillion" "decicentillion" "viginticentillion"
  48                     "trigintacentillion" "quadragintacentillion"
  49                     "quinquagintacentillion" "sexagintacentillion"
  50                     "septuagintacentillion" "octogintacentillion"
  51                     "nonagintacentillion" "ducentillion"
  52                 } nth
  53                 ! Next 10^300 increments after ducentillion, which is 10^603:
  54                 ! "trecentillion" "quadringentillion"
  55                 ! "quingentillion" "sescentillion"
  56                 ! "septingentillion" "octingentillion"
  57                 ! "nongentillion" "millinillion" = 10^3003
  58             ] [
  59                 {
  60                     f "un" "duo" "tre" "quattuor"
  61                     "quinqua" "se" "septe" "octo" "nove"
  62                 } nth
  63             ] bi* swap "" append-as
  64         ] }
  65     } cond ;
  66
  67 SYMBOL: and-needed?
  68 : set-conjunction ( seq -- )
  69     first { [ 100 < ] [ 0 > ] } 1&& and-needed? set ;
  70
  71 : negative-text ( n -- str )
  72     0 < "negative " "" ? ;
  73
  74 : hundreds-place ( n -- str )
  75     100 /mod over 0 = [
  76         2drop ""
  77     ] [
  78         [ small-numbers " hundred" append ] dip
  79         0 = [ " and " append ] unless
  80     ] if ;
  81
  82 : tens-place ( n -- str )
  83     100 mod dup 20 >= [
  84         10 /mod [ tens ] dip
  85         [ small-numbers "-" glue ] unless-zero
  86     ] [
  87         [ "" ] [ small-numbers ] if-zero
  88     ] if ;
  89
  90 : 3digits>text ( n -- str )
  91     [ hundreds-place ] [ tens-place ] bi append ;
  92
  93 : text-with-scale ( index seq -- str )
  94     [ nth 3digits>text ] [ drop scale-numbers ] 2bi
  95     [ " " glue ] unless-empty ;
  96
  97 : append-with-conjunction ( str1 str2 -- newstr )
  98     swap [
  99         and-needed? get " and " ", " ? glue
 100         and-needed? off
 101     ] unless-empty ;
 102
 103 : (recombine) ( str index seq -- newstr )
 104     2dup nth 0 = [
 105         2drop
 106     ] [
 107         text-with-scale append-with-conjunction
 108     ] if ;
 109
 110 : recombine ( seq -- str )
 111     dup length 1 = [
 112         first 3digits>text
 113     ] [
 114         [ set-conjunction "" ] [ length ] [ ] tri
 115         [ (recombine) ] curry each-integer
 116     ] if ;
 117
 118 : (number>text) ( n -- str )
 119     [ negative-text ] [ abs 3 digit-groups recombine ] bi append ;
 120
 121 PRIVATE>
 122
 123 GENERIC: number>text ( n -- str )
 124
 125 M: integer number>text
 126     [ "zero" ] [ [ (number>text) ] with-scope ] if-zero ;
 127
 128 M: ratio number>text
 129     >fraction [ number>text ] bi@ " divided by " glue ;
 130
 131 M: float number>text
 132     number>string "." split1 [
 133         "-" ?head
 134         [ string>number number>text ]
 135         [ [ "negative " prepend ] when ] bi*
 136     ] [
 137         [ CHAR: 0 - small-numbers ] { } map-as join-words
 138     ] bi* " point " glue ;
 139
 140 M: complex number>text
 141     >rect [ number>text ] [
 142         [ 0 < " minus " " plus " ? ]
 143         [ abs number>text " i" append ] bi
 144     ] bi* 3append ;
 145
 146 : ordinal-suffix ( n -- suffix )
 147     abs dup 100 mod 11 13 between? [ drop "th" ] [
 148         10 mod {
 149             { 1 [ "st" ] }
 150             { 2 [ "nd" ] }
 151             { 3 [ "rd" ] }
 152             [ drop "th" ]
 153         } case
 154     ] if ;
 155
 156 : number-ap-style ( n -- str )
 157     dup { [ integer? ] [ 0 9 between? ] } 1&&
 158     [ number>text ] [ number>string ] if ;
 159
 160 : ordinal-ap-style ( n -- str )
 161     dup {
 162         f "first" "second" "third" "fourth" "fifth" "sixth"
 163         "seventh" "eighth" "ninth"
 164     } ?nth [ nip ] [
 165         [ number>string ] [ ordinal-suffix ] bi append
 166     ] if* ;