extra/math/text/english/english.factor

   1 ! Copyright (c) 2007, 2008, 2018 Aaron Schaefer.
   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^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     swap [
  69         and-needed? get " and " ", " ? glue
  70         and-needed? off
  71     ] unless-empty ;
  72
  73 : (recombine) ( str index seq -- newstr )
  74     2dup nth 0 = [
  75         2drop
  76     ] [
  77         text-with-scale append-with-conjunction
  78     ] if ;
  79
  80 : recombine ( seq -- str )
  81     dup length 1 = [
  82         first 3digits>text
  83     ] [
  84         [ set-conjunction "" ] [ length ] [ ] tri
  85         [ (recombine) ] curry each-integer
  86     ] if ;
  87
  88 : (number>text) ( n -- str )
  89     [ negative-text ] [ abs 3 digit-groups recombine ] bi append ;
  90
  91 PRIVATE>
  92
  93 GENERIC: number>text ( n -- str )
  94
  95 M: integer number>text
  96     [ "zero" ] [ [ (number>text) ] with-scope ] if-zero ;
  97
  98 M: ratio number>text
  99     >fraction [ number>text ] bi@ " divided by " glue ;
 100
 101 M: float number>text
 102     number>string "." split1 [
 103         "-" ?head
 104         [ string>number number>text ]
 105         [ [ "negative " prepend ] when ] bi*
 106     ] [
 107         [ CHAR: 0 - small-numbers ] { } map-as join-words
 108     ] bi* " point " glue ;
 109
 110 M: complex number>text
 111     >rect [ number>text ] [
 112         [ 0 < " minus " " plus " ? ]
 113         [ abs number>text " i" append ] bi
 114     ] bi* 3append ;
 115
 116 : ordinal-suffix ( n -- suffix )
 117     abs dup 100 mod 11 13 between? [ drop "th" ] [
 118         10 mod {
 119             { 1 [ "st" ] }
 120             { 2 [ "nd" ] }
 121             { 3 [ "rd" ] }
 122             [ drop "th" ]
 123         } case
 124     ] if ;
 125
 126 : number-ap-style ( n -- str )
 127     dup { [ integer? ] [ 0 9 between? ] } 1&&
 128     [ number>text ] [ number>string ] if ;
 129
 130 : ordinal-ap-style ( n -- str )
 131     dup {
 132         f "first" "second" "third" "fourth" "fifth" "sixth"
 133         "seventh" "eighth" "ninth"
 134     } ?nth [ nip ] [
 135         [ number>string ] [ ordinal-suffix ] bi append
 136     ] if* ;