diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index 215a904861..6c1930b463 100644 --- 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 a842ea52dc..3c6a32c3fa 100644 --- 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 e8d46f1387..6def5b0558 100644 --- 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 5a4e4c33e5..2974d1deae 100644 --- 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 8acda1801a..118ea884a4 100644 --- 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 d2a49f6ee9..4568ac4227 100644 --- 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 ;