factor: trim using lists

[factor.git] / extra / math / text / french / french.factor

diff --git a/extra/math/text/french/french.factor b/extra/math/text/french/french.factor
index 8d313b91970f4fcc3dfe4eba2fa4417e7bf8879f..79a5ba335acb43785e9b50c0bc29fcf10a256227 100644 (file)
--- a/extra/math/text/french/french.factor
+++ b/extra/math/text/french/french.factor
@@ -1,12 +1,12 @@
 ! Copyright (c) 2009 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs combinators kernel math math.functions
-math.parser math.text.utils memoize sequences ;
+math.parser math.text.utils sequences splitting ;
 IN: math.text.french
 
 <PRIVATE
 
-DEFER: basic ( n -- str )
+DEFER: basic
 
 CONSTANT: literals
     H{ { 0 "zéro" } { 1 "un" } { 2 "deux" } { 3 "trois" } { 4 "quatre" }
@@ -29,41 +29,37 @@ MEMO: units ( -- seq ) ! up to 10^99
 ! The only plurals we have to remove are "quatre-vingts" and "cents",
 ! which are also the only strings ending with "ts".
 : unpluralize ( str -- newstr ) dup "ts" tail? [ but-last ] when ;
-: pluralize ( str -- newstr ) CHAR: s suffix ;
+: pluralize ( str -- newstr ) dup "s" tail? [ CHAR: s suffix ] unless ;
 
 : space-append ( str1 str2 -- str ) " " glue ;
 
-! Small numbers (below 100) use dashes between them unless they are
-! separated with "et". Pluralized prefixes must be unpluralized.
-: complete-small ( str n -- str )
+: dash-append ( str1 str2 -- str ) "-" glue ;
+
+! Numbers below 1000000 use dashes between them. Pluralized prefixes
+! must be unpluralized.
+: complete ( str n -- str )
     { { 0 [ ] }
-      { 1 [ " et un" append ] }
+      { 1 [ "-et-un" append ] }
       [ [ unpluralize ] dip basic "-" glue ] } case ;
 
 : smaller-than-60 ( n -- str )
-    dup 10 mod [ - ] keep [ basic ] dip complete-small ;
+    dup 10 mod [ - ] keep [ basic ] dip complete ;
 
-: base-onto ( n b -- str ) [ nip literals at ] [ - ] 2bi complete-small ;
+: base-onto ( n b -- str ) [ nip literals at ] [ - ] 2bi complete ;
 
 : smaller-than-80 ( n -- str ) 60 base-onto ;
 
 : smaller-than-100 ( n -- str ) 80 base-onto ;
 
-: if-zero ( n quot quot -- )
-    [ dup zero? ] 2dip [ [ drop ] prepose ] dip if ; inline
-
-: complete ( str n -- newstr )
-    [ ] [ basic space-append ] if-zero ;
-
 : smaller-than-1000 ( n -- str )
     100 /mod
-    [ "cent" swap dup 1 = [ drop ] [ basic swap space-append ] if ]
-    [ [ pluralize ] [ basic space-append ] if-zero ] bi* ;
+    [ "cent" swap dup 1 = [ drop ] [ basic swap dash-append ] if ]
+    [ [ pluralize ] [ basic dash-append ] if-zero ] bi* ;
 
 : smaller-than-2000 ( n -- str ) "mille" swap 1000 - complete ;
 
 : smaller-than-1000000 ( n -- str )
-    1000 /mod [ basic unpluralize " mille" append ] dip complete ;
+    1000 /mod [ basic unpluralize "-mille" append ] dip complete ;
 
 : n-units ( n unit -- str/f )
     {
@@ -74,9 +70,10 @@ MEMO: units ( -- seq ) ! up to 10^99
 
 : over-1000000 ( n -- str )
     3 digit-groups [ 1 + units nth n-units ] map-index sift
-    reverse " " join ;
+    reverse join-words ;
 
-: decompose ( n -- str ) 1000000 /mod [ over-1000000 ] dip complete ;
+: decompose ( n -- str ) 1000000 /mod [ over-1000000 ] dip
+    dup 0 > [ basic space-append ] [ drop ] if ;
 
 : basic ( n -- str )
     {
@@ -91,7 +88,28 @@ MEMO: units ( -- seq ) ! up to 10^99
         [ decompose ]
     } cond ;
 
+: ieme ( str -- str )
+    dup "ts" tail? [ but-last ] when
+    dup "e" tail? [ but-last ] when
+    dup "q" tail? [ CHAR: u suffix ] when
+    "ième" append ;
+
+: divisor ( n -- str )
+    {
+        { 2 [ "demi" ] }
+        { 3 [ "tiers" ] }
+        { 4 [ "quart" ] }
+        [ basic ieme ]
+    } case ;
+
 PRIVATE>
 
-: number>text ( n -- str )
-    dup abs 10 102 ^ >= [ number>string ] [ basic ] if ;
+GENERIC: number>text ( n -- str )
+
+M: integer number>text
+    dup abs 102 10^ >= [ number>string ] [ basic ] if ;
+
+M: ratio number>text
+    >fraction [ [ number>text ] keep ] [ divisor ] bi*
+    swap abs 1 > [ pluralize ] when
+    space-append ;