move math.extras:round-to-even to math.functions to use in basis:formatting

Also add round-to-odd in case it is needed.
Also change float rounding to be independent of the current rounding mode

diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor
index 215a9048611ae3e88fa5d7b92d900d0d14e7a395..6c1930b4637150e2ba31e15777cb9a52aa550c84 100644 (file)
--- a/basis/math/functions/functions-docs.factor
+++ b/basis/math/functions/functions-docs.factor
@@ -325,6 +325,24 @@ HELP: round
     { $example "USING: math.functions prettyprint ;" "4.4 round ." "4.0" }
 } ;
 
+HELP: round-to-even
+{ $values { "x" real } { "y" "a whole real number" } }
+{ $description "Outputs the whole number closest to " { $snippet "x" } ", rounding out at half, breaking ties towards even numbers. This is also known as banker's rounding or unbiased rounding." }
+{ $notes "The result is not necessarily an integer." }
+{ $examples
+    { $example "USING: math.functions prettyprint ;" "0.5 round-to-even ." "0.0" }
+    { $example "USING: math.functions prettyprint ;" "1.5 round-to-even ." "2.0" }
+} ;
+
+HELP: round-to-odd
+{ $values { "x" real } { "y" "a whole real number" } }
+{ $description "Outputs the whole number closest to " { $snippet "x" } ", rounding out at half, breaking ties towards odd numbers." }
+{ $notes "The result is not necessarily an integer." }
+{ $examples
+    { $example "USING: math.functions prettyprint ;" "0.5 round-to-odd ." "1.0" }
+    { $example "USING: math.functions prettyprint ;" "1.5 round-to-odd ." "1.0" }
+} ;
+
 HELP: roots
 { $values { "x" number } { "t" integer } { "seq" sequence } }
 { $description "Outputs the " { $snippet "t" } " roots of a number " { $snippet "x" } "." }

diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor
index a842ea52dc4d3c7bb24c59bba72e2b063936b449..3c6a32c3fa7fe4912cfc6527acb85662fab6b7ac 100644 (file)
--- a/basis/math/functions/functions-tests.factor
+++ b/basis/math/functions/functions-tests.factor
@@ -200,6 +200,32 @@ CONSTANT: log10-factorial-1000 0x1.40f3593ed6f8ep11
 { { +fp-invalid-operation+ } } [ [ NAN: 4000000000000 ceiling drop ] collect-fp-exceptions ] unit-test
 { { +fp-invalid-operation+ } } [ [ NAN: 4000000000000 floor drop ] collect-fp-exceptions ] unit-test
 
+{ -5 } [ -4-3/5 round-to-even ] unit-test
+{ -4 } [ -4-1/2 round-to-even ] unit-test
+{ -4 } [ -4-2/5 round-to-even ] unit-test
+{ 5 } [ 4+3/5 round-to-even ] unit-test
+{ 4 } [ 4+1/2 round-to-even ] unit-test
+{ 4 } [ 4+2/5 round-to-even ] unit-test
+{ -5.0 } [ -4.6 round-to-even ] unit-test
+{ -4.0 } [ -4.5 round-to-even ] unit-test
+{ -4.0 } [ -4.4 round-to-even ] unit-test
+{ 5.0 } [ 4.6 round-to-even ] unit-test
+{ 4.0 } [ 4.5 round-to-even ] unit-test
+{ 4.0 } [ 4.4 round-to-even ] unit-test
+
+{ -5 } [ -4-3/5 round-to-odd ] unit-test
+{ -5 } [ -4-1/2 round-to-odd ] unit-test
+{ -4 } [ -4-2/5 round-to-odd ] unit-test
+{ 5 } [ 4+3/5 round-to-odd ] unit-test
+{ 5 } [ 4+1/2 round-to-odd ] unit-test
+{ 4 } [ 4+2/5 round-to-odd ] unit-test
+{ -5.0 } [ -4.6 round-to-odd ] unit-test
+{ -5.0 } [ -4.5 round-to-odd ] unit-test
+{ -4.0 } [ -4.4 round-to-odd ] unit-test
+{ 5.0 } [ 4.6 round-to-odd ] unit-test
+{ 5.0 } [ 4.5 round-to-odd ] unit-test
+{ 4.0 } [ 4.4 round-to-odd ] unit-test
+
 { 6 59967 } [ 3837888 factor-2s ] unit-test
 { 6 -59967 } [ -3837888 factor-2s ] unit-test
 

diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor
index e8d46f1387fb5ec7fea51e44986d2b29f9265f9b..6def5b0558eb9679d13d5f27608a3f8b4abeb56f 100644 (file)
--- a/basis/math/functions/functions.factor
+++ b/basis/math/functions/functions.factor
@@ -375,13 +375,45 @@ M: float truncate
 
 GENERIC: round ( x -- y )
 
+GENERIC: round-to-even ( x -- y )
+
+GENERIC: round-to-odd ( x -- y )
+
 M: integer round ; inline
 
-M: ratio round
-    >fraction [ /mod dup abs 2 * ] keep >= [ 0 < -1 1 ? + ] [ drop ] if ;
+M: integer round-to-even ; inline
+
+M: integer round-to-odd ; inline
+
+: (round-tiebreak?) ( quotient rem denom tiebreak-quot -- q ? )
+    [ [ > ] ] dip [ 2dip = and ] curry 3bi or ; inline
+
+: (round-to-even?) ( quotient rem denom -- quotient ? )
+    [ >integer odd? ] (round-tiebreak?) ; inline
+
+: (round-to-odd?) ( quotient rem denom -- quotient ? )
+    [ >integer even? ] (round-tiebreak?) ; inline
+
+: (ratio-round) ( x round-quot -- y )
+    [ >fraction [ /mod dup swapd abs 2 * ] keep ] [ call ] bi*
+    [ swap 0 < -1 1 ? + ] [ nip ] if ; inline
+
+: (float-round) ( x round-quot -- y )
+    [ dup 1 mod [ - ] keep dup swapd abs 0.5 ] [ call ] bi*
+    [ swap 0.0 < -1.0 1.0 ? + ] [ nip ] if ; inline
+
+M: ratio round [ >= ] (ratio-round) ;
+
+M: ratio round-to-even [ (round-to-even?) ] (ratio-round) ;
+
+M: ratio round-to-odd [ (round-to-odd?) ] (ratio-round) ;
 
 M: float round dup sgn 2 /f + truncate ;
 
+M: float round-to-even [ (round-to-even?) ] (float-round) ;
+
+M: float round-to-odd [ (round-to-odd?) ] (float-round) ;
+
 : floor ( x -- y )
     dup 1 mod
     [ dup 0 < [ - 1 - ] [ - ] if ] unless-zero ; foldable

diff --git a/extra/math/extras/extras-docs.factor b/extra/math/extras/extras-docs.factor
index 5a4e4c33e5dbba3100acba0d7a217e9c9ce96ad1..2974d1deaea6dd575a09cce5d9e41c492b9c724d 100644 (file)
--- a/extra/math/extras/extras-docs.factor
+++ b/extra/math/extras/extras-docs.factor
@@ -99,13 +99,6 @@ HELP: round-to-decimal
     { $example "USING: math.extras prettyprint ;" "12345.6789 -3 round-to-decimal ." "12000.0" }
 } ;
 
-HELP: round-to-even
-{ $values { "x" real } { "y" real } }
-{ $description "Rounds " { $snippet "x" } " towards the nearest even number. This is also known as banker's rounding or unbiased rounding." }
-{ $examples
-    { $example "USING: math.extras prettyprint ;" "0.5 round-to-even ." "0.0" }
-    { $example "USING: math.extras prettyprint ;" "1.5 round-to-even ." "2.0" } } ;
-
 HELP: kahan-sum
 { $values { "seq" sequence } { "n" float } }
 { $description "Calculates the summation of the sequence using the Kahan summation algorithm." } ;

diff --git a/extra/math/extras/extras-tests.factor b/extra/math/extras/extras-tests.factor
index 8acda1801addb23ad521a30dfa5dd389a70c3fcf..118ea884a443fe2586b279727c2bd7b926187625 100644 (file)
--- a/extra/math/extras/extras-tests.factor
+++ b/extra/math/extras/extras-tests.factor
@@ -98,20 +98,6 @@ IN: math.extras.test
 { 3 } [ { 1 2 3 1 2 3 1 2 3 3 } majority ] unit-test
 { CHAR: C } [ "AAACCBBCCCBCC" majority ] unit-test
 
-{ -5 } [ -4-3/5 round-to-even ] unit-test
-{ -4 } [ -4-1/2 round-to-even ] unit-test
-{ -4 } [ -4-2/5 round-to-even ] unit-test
-{ 5 } [ 4+3/5 round-to-even ] unit-test
-{ 4 } [ 4+1/2 round-to-even ] unit-test
-{ 4 } [ 4+2/5 round-to-even ] unit-test
-
-{ -5.0 } [ -4.6 round-to-even ] unit-test
-{ -4.0 } [ -4.5 round-to-even ] unit-test
-{ -4.0 } [ -4.4 round-to-even ] unit-test
-{ 5.0 } [ 4.6 round-to-even ] unit-test
-{ 4.0 } [ 4.5 round-to-even ] unit-test
-{ 4.0 } [ 4.4 round-to-even ] unit-test
-
 { 0.0 } [ 0 2 round-to-decimal ] unit-test
 { 1.0 } [ 1 2 round-to-decimal ] unit-test
 { 1.23 } [ 1.2349 2 round-to-decimal ] unit-test

diff --git a/extra/math/extras/extras.factor b/extra/math/extras/extras.factor
index d2a49f6ee9430350464510c918d7101a749a4093..4568ac4227e329a95a997ace7112d665a38a2a87 100644 (file)
--- a/extra/math/extras/extras.factor
+++ b/extra/math/extras/extras.factor
@@ -249,20 +249,6 @@ PRIVATE>
 : compression-dissimilarity ( a b -- n )
     compression-lengths + / ;
 
-GENERIC: round-to-even ( x -- y )
-
-M: integer round-to-even ; inline
-
-M: ratio round-to-even
-    >fraction [ /mod abs 2 * ] keep > [ dup 0 < -1 1 ? + ] when ;
-
-M: float round-to-even
-    dup 0 > [
-        dup 0x1p52 <= [ 0x1p52 + 0x1p52 - ] when
-    ] [
-        dup -0x1p52 >= [ 0x1p52 - 0x1p52 + ] when
-    ] if ;
-
 : round-to-decimal ( x n -- y )
     10^ [ * 0.5 over 0 > [ + ] [ - ] if truncate ] [ / ] bi ;