steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

math.extras: adding round-to-even.

db4
John Benediktsson 2013-03-26 14:36:05 -07:00
parent 814cdaf26d
commit 3e209587c5
2 changed files with 28 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
extra/math/extras/extras-tests.factor
View File

@ -89,3 +89,17 @@ IN: math.extras.test
[ 2 ] [ { 1 1 2 2 2 } majority ] unit-test [ 2 ] [ { 1 1 2 2 2 } majority ] unit-test
[ 3 ] [ { 1 2 3 1 2 3 1 2 3 3 } majority ] unit-test [ 3 ] [ { 1 2 3 1 2 3 1 2 3 3 } majority ] unit-test
{ CHAR: C } [ "AAACCBBCCCBCC" 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

14
extra/math/extras/extras.factor
View File

@ -238,3 +238,17 @@ PRIVATE>
: compression-dissimilarity ( a b -- n ) : compression-dissimilarity ( a b -- n )
compression-lengths + / ; 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 ;