1 {-# OPTIONS -Wall -fno-warn-unused-binds #-}
3 -----------------------------------------------------------------------------
6 -- Copyright : (c) Ashley Yakeley 2005, 2006, 2009
7 -- License : BSD-style (see the file libraries/base/LICENSE)
9 -- Maintainer : Ashley Yakeley <ashley@semantic.org>
10 -- Stability : experimental
11 -- Portability : portable
13 -- This module defines a \"Fixed\" type for fixed-precision arithmetic.
14 -- The parameter to Fixed is any type that's an instance of HasResolution.
15 -- HasResolution has a single method that gives the resolution of the Fixed type.
17 -- This module also contains generalisations of div, mod, and divmod to work
18 -- with any Real instance.
20 -----------------------------------------------------------------------------
26 Fixed,HasResolution(..),
37 import Prelude -- necessary to get dependencies right
41 default () -- avoid any defaulting shenanigans
43 -- | generalisation of 'div' to any instance of Real
44 div' :: (Real a,Integral b) => a -> a -> b
45 div' n d = floor ((toRational n) / (toRational d))
47 -- | generalisation of 'divMod' to any instance of Real
48 divMod' :: (Real a,Integral b) => a -> a -> (b,a)
49 divMod' n d = (f,n - (fromIntegral f) * d) where
52 -- | generalisation of 'mod' to any instance of Real
53 mod' :: (Real a) => a -> a -> a
54 mod' n d = n - (fromInteger f) * d where
57 -- | The type parameter should be an instance of 'HasResolution'.
58 newtype Fixed a = MkFixed Integer deriving (Eq,Ord,Typeable)
60 -- We do this because the automatically derived Data instance requires (Data a) context.
61 -- Our manual instance has the more general (Typeable a) context.
63 tyFixed = mkDataType "Data.Fixed.Fixed" [conMkFixed]
65 conMkFixed = mkConstr tyFixed "MkFixed" [] Prefix
66 instance (Typeable a) => Data (Fixed a) where
67 gfoldl k z (MkFixed a) = k (z MkFixed) a
68 gunfold k z _ = k (z MkFixed)
69 dataTypeOf _ = tyFixed
70 toConstr _ = conMkFixed
72 class HasResolution a where
73 resolution :: p a -> Integer
75 withType :: (p a -> f a) -> f a
76 withType foo = foo undefined
78 withResolution :: (HasResolution a) => (Integer -> f a) -> f a
79 withResolution foo = withType (foo . resolution)
81 instance Enum (Fixed a) where
82 succ (MkFixed a) = MkFixed (succ a)
83 pred (MkFixed a) = MkFixed (pred a)
84 toEnum = MkFixed . toEnum
85 fromEnum (MkFixed a) = fromEnum a
86 enumFrom (MkFixed a) = fmap MkFixed (enumFrom a)
87 enumFromThen (MkFixed a) (MkFixed b) = fmap MkFixed (enumFromThen a b)
88 enumFromTo (MkFixed a) (MkFixed b) = fmap MkFixed (enumFromTo a b)
89 enumFromThenTo (MkFixed a) (MkFixed b) (MkFixed c) = fmap MkFixed (enumFromThenTo a b c)
91 instance (HasResolution a) => Num (Fixed a) where
92 (MkFixed a) + (MkFixed b) = MkFixed (a + b)
93 (MkFixed a) - (MkFixed b) = MkFixed (a - b)
94 fa@(MkFixed a) * (MkFixed b) = MkFixed (div (a * b) (resolution fa))
95 negate (MkFixed a) = MkFixed (negate a)
96 abs (MkFixed a) = MkFixed (abs a)
97 signum (MkFixed a) = fromInteger (signum a)
98 fromInteger i = withResolution (\res -> MkFixed (i * res))
100 instance (HasResolution a) => Real (Fixed a) where
101 toRational fa@(MkFixed a) = (toRational a) / (toRational (resolution fa))
103 instance (HasResolution a) => Fractional (Fixed a) where
104 fa@(MkFixed a) / (MkFixed b) = MkFixed (div (a * (resolution fa)) b)
105 recip fa@(MkFixed a) = MkFixed (div (res * res) a) where
107 fromRational r = withResolution (\res -> MkFixed (floor (r * (toRational res))))
109 instance (HasResolution a) => RealFrac (Fixed a) where
110 properFraction a = (i,a - (fromIntegral i)) where
112 truncate f = truncate (toRational f)
113 round f = round (toRational f)
114 ceiling f = ceiling (toRational f)
115 floor f = floor (toRational f)
117 chopZeros :: Integer -> String
119 chopZeros a | mod a 10 == 0 = chopZeros (div a 10)
122 -- only works for positive a
123 showIntegerZeros :: Bool -> Int -> Integer -> String
124 showIntegerZeros True _ 0 = ""
125 showIntegerZeros chopTrailingZeros digits a = replicate (digits - length s) '0' ++ s' where
127 s' = if chopTrailingZeros then chopZeros a else s
129 withDot :: String -> String
133 -- | First arg is whether to chop off trailing zeros
134 showFixed :: (HasResolution a) => Bool -> Fixed a -> String
135 showFixed chopTrailingZeros fa@(MkFixed a) | a < 0 = "-" ++ (showFixed chopTrailingZeros (asTypeOf (MkFixed (negate a)) fa))
136 showFixed chopTrailingZeros fa@(MkFixed a) = (show i) ++ (withDot (showIntegerZeros chopTrailingZeros digits fracNum)) where
139 -- enough digits to be unambiguous
140 digits = ceiling (logBase 10 (fromInteger res) :: Double)
142 fracNum = div (d * maxnum) res
144 instance (HasResolution a) => Show (Fixed a) where
145 show = showFixed False
148 data E0 = E0 deriving (Typeable)
149 instance HasResolution E0 where
151 -- | resolution of 1, this works the same as Integer
154 data E1 = E1 deriving (Typeable)
155 instance HasResolution E1 where
157 -- | resolution of 10^-1 = .1
160 data E2 = E2 deriving (Typeable)
161 instance HasResolution E2 where
163 -- | resolution of 10^-2 = .01, useful for many monetary currencies
164 type Centi = Fixed E2
166 data E3 = E3 deriving (Typeable)
167 instance HasResolution E3 where
169 -- | resolution of 10^-3 = .001
170 type Milli = Fixed E3
172 data E6 = E6 deriving (Typeable)
173 instance HasResolution E6 where
174 resolution _ = 1000000
175 -- | resolution of 10^-6 = .000001
176 type Micro = Fixed E6
178 data E9 = E9 deriving (Typeable)
179 instance HasResolution E9 where
180 resolution _ = 1000000000
181 -- | resolution of 10^-9 = .000000001
184 data E12 = E12 deriving (Typeable)
185 instance HasResolution E12 where
186 resolution _ = 1000000000000
187 -- | resolution of 10^-12 = .000000000001
188 type Pico = Fixed E12