From cfb44999a14b9a1f32af01f79a0a4073d1c39c8b Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Mon, 17 Jun 2013 10:10:40 -0700 Subject: [PATCH] math.extras: adding round-away-from-zero. --- extra/math/extras/extras-tests.factor | 6 ++++++ extra/math/extras/extras.factor | 7 +++++++ 2 files changed, 13 insertions(+) diff --git a/extra/math/extras/extras-tests.factor b/extra/math/extras/extras-tests.factor index 2819c965d9..24d978c231 100644 --- a/extra/math/extras/extras-tests.factor +++ b/extra/math/extras/extras-tests.factor @@ -130,5 +130,11 @@ IN: math.extras.test { 10 } [ 12 5 round-to-step ] unit-test { 15 } [ 13 5 round-to-step ] unit-test +{ 0 } [ 0 round-away-from-zero ] unit-test +{ -1.0 } [ -0.1 round-away-from-zero ] unit-test +{ 1.0 } [ 0.1 round-away-from-zero ] unit-test +{ -2.0 } [ -1.9 round-away-from-zero ] unit-test +{ 2.0 } [ 1.9 round-away-from-zero ] unit-test + { { 0 1 2 3 0 0 1 } } [ { 1 2 3 3 2 1 2 } [ <= ] monotonic-count ] unit-test { 4 } [ { 1 2 3 1 2 3 4 5 } [ < ] max-monotonic-count ] unit-test diff --git a/extra/math/extras/extras.factor b/extra/math/extras/extras.factor index 02a75982fc..427c55caec 100644 --- a/extra/math/extras/extras.factor +++ b/extra/math/extras/extras.factor @@ -265,6 +265,13 @@ M: float round-to-even : round-to-step ( x step -- y ) [ [ / round ] [ * ] bi ] unless-zero ; +GENERIC: round-away-from-zero ( x -- y ) + +M: integer round-away-from-zero ; inline + +M: real round-away-from-zero + dup 0 < [ floor ] [ ceiling ] if ; + : monotonic-count ( seq quot: ( elt1 elt2 -- ? ) -- newseq ) over empty? [ 2drop { } ] [ [ 0 swap unclip-slice swap ] dip '[