Skip to content

Commit 4234cc8

Browse files
committed
Functora.Round
1 parent 88ad693 commit 4234cc8

File tree

3 files changed

+300
-1
lines changed

3 files changed

+300
-1
lines changed

pub/functora/functora.cabal

Lines changed: 22 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -316,6 +316,11 @@ common pkg-bolt11
316316
, bitcoin-address
317317
, bytestring
318318

319+
common pkg-round
320+
import: pkg
321+
hs-source-dirs: src/round
322+
build-depends: base
323+
319324
library
320325
import: pkg-prelude
321326
exposed-modules:
@@ -430,6 +435,13 @@ library bolt11
430435
visibility: public
431436
exposed-modules: Functora.Bolt11
432437

438+
library round
439+
import: pkg-round
440+
build-depends: functora
441+
exposed: True
442+
visibility: public
443+
exposed-modules: Functora.Round
444+
433445
executable elm2miso
434446
import: pkg-elm2miso, exe
435447
main-is: Main.hs
@@ -453,12 +465,18 @@ test-suite functora-test
453465
, containers
454466
, Crypto
455467
, cryptohash-sha256
468+
, doctest
456469
, hspec
457470
, modern-uri
458471
, qrcode-core
459472
, QuickCheck
460473
, quickcheck-instances
474+
, smallcheck
461475
, string-qq
476+
, tasty
477+
, tasty-hunit
478+
, tasty-quickcheck
479+
, tasty-smallcheck
462480
, text
463481
, universum
464482

@@ -470,6 +488,7 @@ test-suite functora-test
470488
Functora.PreludeSpec
471489
Functora.QrSpec
472490
Functora.RatesSpec
491+
Functora.RoundSpec
473492
Functora.SoplateSpec
474493
Functora.Tags.TestFgpt
475494
Functora.Tags.TestSing
@@ -483,7 +502,7 @@ test-suite functora-test
483502
pkg-cfg, pkg-web, pkg-sql,
484503
pkg-money, pkg-rates, pkg-tags,
485504
pkg-soplate, pkg-elm2miso, pkg-card,
486-
pkg-bolt11, pkg-uri
505+
pkg-bolt11, pkg-round, pkg-uri
487506

488507
other-modules:
489508
Functora.Aes
@@ -501,6 +520,7 @@ test-suite functora-test
501520
Functora.QrOrphan
502521
Functora.Rates
503522
Functora.Rfc2397
523+
Functora.Round
504524
Functora.Soplate
505525
Functora.Sql
506526
Functora.SqlOrphan
@@ -524,6 +544,7 @@ test-suite functora-test
524544
, money
525545
, qr
526546
, rates
547+
, round
527548
, soplate
528549
, tags
529550
, uri
Lines changed: 172 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,172 @@
1+
-- |
2+
-- Module: Functora.Round
3+
--
4+
-- Rounding rationals to significant digits and decimal places.
5+
--
6+
-- The 'round' function from the prelude returns an integer. The standard librarys
7+
-- of C and C++ have round functions that return floating point numbers. Rounding
8+
-- in this library takes and returns 'Rational's and can round to a number of
9+
-- significant digits or a number of decimal places.
10+
module Functora.Round
11+
( -- * About the Name
12+
-- $name
13+
14+
-- * Rounding to Decimal Places
15+
dpRound,
16+
17+
-- * Rounding to Significant Digits
18+
sdRound,
19+
)
20+
where
21+
22+
import Numeric.Natural (Natural)
23+
import Prelude
24+
25+
-- | Rounds to a non-negative number of __d__ecimal __p__laces. After rounding
26+
-- the result would have the given number of decimal places if converted to
27+
-- a floating point number, such as by using 'fromRational'.
28+
--
29+
-- >>> dpRound 2 (1234.56789 :: Rational)
30+
-- 123457 % 100
31+
-- >>> dpRound 2 (123456789 :: Rational)
32+
-- 123456789 % 1
33+
--
34+
-- Some examples that may be easier to read using decimal point notation.
35+
--
36+
-- >>> dpRound 2 (123456789 :: Rational) == (123456789 :: Rational)
37+
-- True
38+
-- >>> dpRound 2 (1234.56789 :: Rational) == (1234.57 :: Rational)
39+
-- True
40+
-- >>> dpRound 2 (123.456789 :: Rational) == (123.46 :: Rational)
41+
-- True
42+
-- >>> dpRound 2 (12.3456789 :: Rational) == (12.35 :: Rational)
43+
-- True
44+
-- >>> dpRound 2 (1.23456789 :: Rational) == (1.23 :: Rational)
45+
-- True
46+
-- >>> dpRound 2 (0.123456789 :: Rational) == (0.12 :: Rational)
47+
-- True
48+
-- >>> dpRound 2 (0.0123456789 :: Rational) == (0.01 :: Rational)
49+
-- True
50+
-- >>> dpRound 2 (0.0000123456789 :: Rational) == (0.0 :: Rational)
51+
-- True
52+
--
53+
-- If the required number of decimal places is less than zero it is taken to
54+
-- be zero.
55+
--
56+
-- >>> dpRound 0 (1234.56789 :: Rational)
57+
-- 1235 % 1
58+
-- >>> dpRound (-1) (1234.56789 :: Rational)
59+
-- 1235 % 1
60+
-- >>> dpRound 0 (123456789 :: Rational)
61+
-- 123456789 % 1
62+
-- >>> dpRound (-1) (123456789 :: Rational)
63+
-- 123456789 % 1
64+
--
65+
-- Rounding to the existing number of decimal places or more makes no
66+
-- difference.
67+
--
68+
-- >>> 1234.56789 :: Rational
69+
-- 123456789 % 100000
70+
-- >>> dpRound 5 (1234.56789 :: Rational)
71+
-- 123456789 % 100000
72+
-- >>> dpRound 6 (1234.56789 :: Rational)
73+
-- 123456789 % 100000
74+
75+
-- SEE: https://stackoverflow.com/questions/12450501/round-number-to-specified-number-of-digits
76+
dpRound :: (RealFrac a) => Integer -> a -> a
77+
dpRound n f
78+
| n < 0 = dpRound 0 f
79+
| otherwise =
80+
fromInteger (round $ f * (10 ^ n)) / (10.0 ^^ n)
81+
{-# INLINEABLE dpRound #-}
82+
{-# SPECIALIZE dpRound :: Integer -> Double -> Double #-}
83+
{-# SPECIALIZE dpRound :: Integer -> Rational -> Rational #-}
84+
85+
-- | Rounds to a non-negative number of __s__ignificant __d__igits.
86+
--
87+
-- >>> sdRound 1 (123456789 :: Rational)
88+
-- 100000000 % 1
89+
-- >>> sdRound 4 (123456789 :: Rational)
90+
-- 123500000 % 1
91+
-- >>> sdRound 8 (1234.56789 :: Rational)
92+
-- 12345679 % 10000
93+
--
94+
-- More examples using decimal point notation.
95+
--
96+
-- >>> sdRound 4 (123456789 :: Rational) == (123500000 :: Rational)
97+
-- True
98+
-- >>> sdRound 4 (1234.56789 :: Rational) == (1235 :: Rational)
99+
-- True
100+
-- >>> sdRound 4 (123.456789 :: Rational) == (123.5 :: Rational)
101+
-- True
102+
-- >>> sdRound 4 (12.3456789 :: Rational) == (12.35 :: Rational)
103+
-- True
104+
-- >>> sdRound 4 (1.23456789 :: Rational) == (1.235 :: Rational)
105+
-- True
106+
-- >>> sdRound 4 (0.123456789 :: Rational) == (0.1235 :: Rational)
107+
-- True
108+
-- >>> sdRound 4 (0.0123456789 :: Rational) == (0.01235 :: Rational)
109+
-- True
110+
-- >>> sdRound 4 (0.0000123456789 :: Rational) == (0.00001235 :: Rational)
111+
-- True
112+
--
113+
-- Rounding to the existing number of significant digits or more makes no
114+
-- difference.
115+
--
116+
-- >>> 1234.56789 :: Rational
117+
-- 123456789 % 100000
118+
-- >>> sdRound 9 (1234.56789 :: Rational)
119+
-- 123456789 % 100000
120+
-- >>> sdRound 10 (1234.56789 :: Rational)
121+
-- 123456789 % 100000
122+
--
123+
-- Rounding to zero significant digits is always zero.
124+
--
125+
-- >>> sdRound 0 (123456789 :: Rational)
126+
-- 0 % 1
127+
-- >>> sdRound 0 (1234.56789 :: Rational)
128+
-- 0 % 1
129+
-- >>> sdRound 0 (0.123456789 :: Rational)
130+
-- 0 % 1
131+
-- >>> sdRound 0 (0.0000123456789 :: Rational)
132+
-- 0 % 1
133+
sdRound :: (RealFrac a) => Natural -> a -> a
134+
sdRound sd' f =
135+
if m < 0
136+
then dpRound sd gZ / 10 ^^ pZ
137+
else case compare n 0 of
138+
EQ -> dpRound n f
139+
GT -> dpRound n f
140+
LT -> 10 ^^ p * fromInteger (round g)
141+
where
142+
sd = toInteger sd'
143+
144+
f' :: Double
145+
f' = fromRational $ toRational f
146+
147+
m :: Double
148+
m = logBase 10 f'
149+
mZ :: Integer
150+
mZ = truncate m
151+
152+
n = sd - (mZ + 1)
153+
154+
p = negate n
155+
pZ = negate mZ
156+
157+
g = f / 10 ^ p
158+
gZ = f * 10 ^ pZ
159+
{-# INLINEABLE sdRound #-}
160+
{-# SPECIALIZE sdRound :: Natural -> Double -> Double #-}
161+
{-# SPECIALIZE sdRound :: Natural -> Rational -> Rational #-}
162+
163+
-- $name
164+
-- Rounding to decimal places is a special case of rounding significant digits.
165+
-- When the number is split into whole and fractional parts, rounding to
166+
-- decimal places is rounding to significant digits in the fractional part.
167+
--
168+
-- The digits that are discarded become dust and a digit when written down is
169+
-- a char.
170+
--
171+
-- The package name is __siggy__ for significant digits and __chardust__ for
172+
-- the digits that are discarded.
Lines changed: 106 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,106 @@
1+
module Functora.RoundSpec (spec) where
2+
3+
import Functora.Prelude (throw, throwString, try)
4+
import Functora.Round (dpRound, sdRound)
5+
import System.Exit (ExitCode (..))
6+
import Test.DocTest (doctest)
7+
import Test.Hspec (Spec, it)
8+
import Test.Tasty (TestTree, defaultMain, testGroup)
9+
import Test.Tasty.HUnit as HU (testCase, (@?=))
10+
import Test.Tasty.QuickCheck as QC
11+
import Prelude
12+
13+
spec :: Spec
14+
spec = do
15+
it "tasty" $ do
16+
res <- try $ defaultMain tests
17+
case res of
18+
Right () -> throwString @String "unexpected tasty result"
19+
Left ExitSuccess -> pure ()
20+
Left e -> throw e
21+
it "doctest" $
22+
doctest
23+
[ "-isrc",
24+
"src/round/Functora/Round.hs"
25+
]
26+
27+
--
28+
-- Tasty
29+
--
30+
31+
tests :: TestTree
32+
tests =
33+
testGroup
34+
"Tests"
35+
[ units,
36+
properties
37+
]
38+
39+
properties :: TestTree
40+
properties =
41+
testGroup
42+
"Properties"
43+
[ qcProps
44+
]
45+
46+
units :: TestTree
47+
units =
48+
testGroup
49+
"Units"
50+
[ roundUnits
51+
]
52+
53+
roundUnits :: TestTree
54+
roundUnits =
55+
testGroup
56+
"Rounding ..."
57+
[ testGroup
58+
"Rounding to 2 decimal places"
59+
[ HU.testCase "123456789.0 => no change" $
60+
dpRound 2 (123456789.0 :: Rational) @?= 123456789.0,
61+
HU.testCase "1234.56789 => 1234.57" $
62+
dpRound 2 (1234.56789 :: Rational) @?= 1234.57,
63+
HU.testCase "123.456789 => 123.46" $
64+
dpRound 2 (123.456789 :: Rational) @?= 123.46,
65+
HU.testCase "12.3456789 => 12.35" $
66+
dpRound 2 (12.3456789 :: Rational) @?= 12.35,
67+
HU.testCase "1.23456789 => 1.23" $
68+
dpRound 2 (1.23456789 :: Rational) @?= 1.23,
69+
HU.testCase "0.123456789 => 0.12" $
70+
dpRound 2 (0.123456789 :: Rational) @?= 0.12,
71+
HU.testCase "0.0123456789 => 0.01" $
72+
dpRound 2 (0.0123456789 :: Rational) @?= 0.01,
73+
HU.testCase "0.0000123456789 => 0.0" $
74+
dpRound 2 (0.0000123456789 :: Rational) @?= 0.0
75+
],
76+
testGroup
77+
"Rounding 4 significant digits"
78+
[ HU.testCase "123456789.0 => 123500000.0" $
79+
sdRound 4 (123456789.0 :: Rational) @?= 123500000.0,
80+
HU.testCase "1234.56789 => 1235.0" $
81+
sdRound 4 (1234.56789 :: Rational) @?= 1235.0,
82+
HU.testCase "123.456789 => 123.5" $
83+
sdRound 4 (123.456789 :: Rational) @?= 123.5,
84+
HU.testCase "12.3456789 => 12.35" $
85+
sdRound 4 (12.3456789 :: Rational) @?= 12.35,
86+
HU.testCase "1.23456789 => 1.235" $
87+
sdRound 4 (1.23456789 :: Rational) @?= 1.235,
88+
HU.testCase "0.123456789 => 0.1235" $
89+
sdRound 4 (0.123456789 :: Rational) @?= 0.1235,
90+
HU.testCase "0.0123456789 => 0.01235" $
91+
sdRound 4 (0.0123456789 :: Rational) @?= 0.01235,
92+
HU.testCase "0.0000123456789 => 0.00001235" $
93+
sdRound 4 (0.0000123456789 :: Rational) @?= 0.00001235
94+
]
95+
]
96+
97+
qcProps :: TestTree
98+
qcProps =
99+
testGroup
100+
"(checked by QuickCheck)"
101+
[ QC.testProperty "Rounding is idempotent" dpIdempotent
102+
]
103+
104+
dpIdempotent :: Integer -> Rational -> Bool
105+
dpIdempotent dp x =
106+
let y = dpRound dp x in dpRound dp y == y

0 commit comments

Comments
 (0)