extra/math/text/french/french.factor

   1 ! Copyright (c) 2009 Samuel Tardieu.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs combinators kernel math math.functions
   4 math.parser math.text.utils sequences splitting ;
   5 IN: math.text.french
   6
   7 <PRIVATE
   8
   9 DEFER: basic
  10
  11 CONSTANT: literals
  12     H{
  13         { 0 "zéro" } { 1 "un" } { 2 "deux" } { 3 "trois" } { 4 "quatre" }
  14         { 5 "cinq" } { 6 "six" } { 7 "sept" } { 8 "huit" } { 9 "neuf" }
  15         { 10 "dix" } { 11 "onze" } { 12 "douze" } { 13 "treize" }
  16         { 14 "quatorze" } { 15 "quinze" } { 16 "seize" } { 17 "dix-sept" }
  17         { 18 "dix-huit" } { 19 "dix-neuf" } { 20 "vingt" } { 30 "trente" }
  18         { 40 "quarante" } { 50 "cinquante" } { 60 "soixante" }
  19         { 71 "soixante et onze" } { 80 "quatre-vingts" }
  20         { 81 "quatre-vingt-un" }
  21         { 100 "cent" } { 1000 "mille" }
  22     }
  23
  24 MEMO: units ( -- seq ) ! up to 10^99
  25     { "m" "b" "tr" "quadr" "quint" "sext" "sept" "oct"
  26       "non" "déc" "unodéc" "duodéc" "trédéc" "quattuordéc"
  27       "quindéc" "sexdéc" }
  28       [ [ "illion" append ] [ "illiard" append ] bi 2array ] map concat
  29       "mille" prefix ;
  30
  31 ! The only plurals we have to remove are "quatre-vingts" and "cents",
  32 ! which are also the only strings ending with "ts".
  33 : unpluralize ( str -- newstr ) dup "ts" tail? [ but-last ] when ;
  34 : pluralize ( str -- newstr ) dup "s" tail? [ CHAR: s suffix ] unless ;
  35
  36 : space-append ( str1 str2 -- str ) " " glue ;
  37
  38 : dash-append ( str1 str2 -- str ) "-" glue ;
  39
  40 ! Numbers below 1000000 use dashes between them. Pluralized prefixes
  41 ! must be unpluralized.
  42 : complete ( str n -- str )
  43     { { 0 [ ] }
  44       { 1 [ "-et-un" append ] }
  45       [ [ unpluralize ] dip basic "-" glue ] } case ;
  46
  47 : smaller-than-60 ( n -- str )
  48     dup 10 mod [ - ] keep [ basic ] dip complete ;
  49
  50 : base-onto ( n b -- str ) [ nip literals at ] [ - ] 2bi complete ;
  51
  52 : smaller-than-80 ( n -- str ) 60 base-onto ;
  53
  54 : smaller-than-100 ( n -- str ) 80 base-onto ;
  55
  56 : smaller-than-1000 ( n -- str )
  57     100 /mod
  58     [ "cent" swap dup 1 = [ drop ] [ basic swap dash-append ] if ]
  59     [ [ pluralize ] [ basic dash-append ] if-zero ] bi* ;
  60
  61 : smaller-than-2000 ( n -- str ) "mille" swap 1000 - complete ;
  62
  63 : smaller-than-1000000 ( n -- str )
  64     1000 /mod [ basic unpluralize "-mille" append ] dip complete ;
  65
  66 : n-units ( n unit -- str/f )
  67     {
  68         { [ over zero? ] [ 2drop f ] }
  69         { [ over 1 = ] [ [ basic ] dip space-append ] }
  70         [ [ basic ] dip space-append pluralize ]
  71     } cond ;
  72
  73 : over-1000000 ( n -- str )
  74     3 digit-groups [ 1 + units nth n-units ] map-index sift
  75     reverse join-words ;
  76
  77 : decompose ( n -- str ) 1000000 /mod [ over-1000000 ] dip
  78     dup 0 > [ basic space-append ] [ drop ] if ;
  79
  80 : basic ( n -- str )
  81     {
  82         { [ dup literals key? ] [ literals at ] }
  83         { [ dup 0 < ] [ abs basic "moins " swap append ] }
  84         { [ dup 60 < ] [ smaller-than-60 ] }
  85         { [ dup 80 < ] [ smaller-than-80 ] }
  86         { [ dup 100 < ] [ smaller-than-100 ] }
  87         { [ dup 1000 < ] [ smaller-than-1000 ] }
  88         { [ dup 2000 < ] [ smaller-than-2000 ] }
  89         { [ dup 1000000 < ] [ smaller-than-1000000 ] }
  90         [ decompose ]
  91     } cond ;
  92
  93 : ieme ( str -- str )
  94     dup "ts" tail? [ but-last ] when
  95     dup "e" tail? [ but-last ] when
  96     dup "q" tail? [ CHAR: u suffix ] when
  97     "ième" append ;
  98
  99 : divisor ( n -- str )
 100     {
 101         { 2 [ "demi" ] }
 102         { 3 [ "tiers" ] }
 103         { 4 [ "quart" ] }
 104         [ basic ieme ]
 105     } case ;
 106
 107 PRIVATE>
 108
 109 GENERIC: number>text ( n -- str )
 110
 111 M: integer number>text
 112     dup abs 102 10^ >= [ number>string ] [ basic ] if ;
 113
 114 M: ratio number>text
 115     >fraction [ [ number>text ] keep ] [ divisor ] bi*
 116     swap abs 1 > [ pluralize ] when
 117     space-append ;