2 {-# OPTIONS -Wall -fno-warn-unused-binds #-}
5 {-# LANGUAGE DeriveDataTypeable #-}
7 -----------------------------------------------------------------------------
10 -- Copyright : (c) Ashley Yakeley 2005, 2006, 2009
11 -- License : BSD-style (see the file libraries/base/LICENSE)
13 -- Maintainer : Ashley Yakeley <ashley@semantic.org>
14 -- Stability : experimental
15 -- Portability : portable
17 -- This module defines a \"Fixed\" type for fixed-precision arithmetic.
18 -- The parameter to Fixed is any type that's an instance of HasResolution.
19 -- HasResolution has a single method that gives the resolution of the Fixed type.
21 -- This module also contains generalisations of div, mod, and divmod to work
22 -- with any Real instance.
24 -----------------------------------------------------------------------------
30 Fixed,HasResolution(..),
41 import Prelude -- necessary to get dependencies right
50 default () -- avoid any defaulting shenanigans
53 -- | generalisation of 'div' to any instance of Real
54 div' :: (Real a,Integral b) => a -> a -> b
55 div' n d = floor ((toRational n) / (toRational d))
57 -- | generalisation of 'divMod' to any instance of Real
58 divMod' :: (Real a,Integral b) => a -> a -> (b,a)
59 divMod' n d = (f,n - (fromIntegral f) * d) where
62 -- | generalisation of 'mod' to any instance of Real
63 mod' :: (Real a) => a -> a -> a
64 mod' n d = n - (fromInteger f) * d where
67 -- | The type parameter should be an instance of 'HasResolution'.
68 newtype Fixed a = MkFixed Integer
70 deriving (Eq,Ord,Typeable)
76 -- We do this because the automatically derived Data instance requires (Data a) context.
77 -- Our manual instance has the more general (Typeable a) context.
79 tyFixed = mkDataType "Data.Fixed.Fixed" [conMkFixed]
81 conMkFixed = mkConstr tyFixed "MkFixed" [] Prefix
82 instance (Typeable a) => Data (Fixed a) where
83 gfoldl k z (MkFixed a) = k (z MkFixed) a
84 gunfold k z _ = k (z MkFixed)
85 dataTypeOf _ = tyFixed
86 toConstr _ = conMkFixed
89 class HasResolution a where
90 resolution :: p a -> Integer
92 withType :: (p a -> f a) -> f a
93 withType foo = foo undefined
95 withResolution :: (HasResolution a) => (Integer -> f a) -> f a
96 withResolution foo = withType (foo . resolution)
98 instance Enum (Fixed a) where
99 succ (MkFixed a) = MkFixed (succ a)
100 pred (MkFixed a) = MkFixed (pred a)
101 toEnum = MkFixed . toEnum
102 fromEnum (MkFixed a) = fromEnum a
103 enumFrom (MkFixed a) = fmap MkFixed (enumFrom a)
104 enumFromThen (MkFixed a) (MkFixed b) = fmap MkFixed (enumFromThen a b)
105 enumFromTo (MkFixed a) (MkFixed b) = fmap MkFixed (enumFromTo a b)
106 enumFromThenTo (MkFixed a) (MkFixed b) (MkFixed c) = fmap MkFixed (enumFromThenTo a b c)
108 instance (HasResolution a) => Num (Fixed a) where
109 (MkFixed a) + (MkFixed b) = MkFixed (a + b)
110 (MkFixed a) - (MkFixed b) = MkFixed (a - b)
111 fa@(MkFixed a) * (MkFixed b) = MkFixed (div (a * b) (resolution fa))
112 negate (MkFixed a) = MkFixed (negate a)
113 abs (MkFixed a) = MkFixed (abs a)
114 signum (MkFixed a) = fromInteger (signum a)
115 fromInteger i = withResolution (\res -> MkFixed (i * res))
117 instance (HasResolution a) => Real (Fixed a) where
118 toRational fa@(MkFixed a) = (toRational a) / (toRational (resolution fa))
120 instance (HasResolution a) => Fractional (Fixed a) where
121 fa@(MkFixed a) / (MkFixed b) = MkFixed (div (a * (resolution fa)) b)
122 recip fa@(MkFixed a) = MkFixed (div (res * res) a) where
124 fromRational r = withResolution (\res -> MkFixed (floor (r * (toRational res))))
126 instance (HasResolution a) => RealFrac (Fixed a) where
127 properFraction a = (i,a - (fromIntegral i)) where
129 truncate f = truncate (toRational f)
130 round f = round (toRational f)
131 ceiling f = ceiling (toRational f)
132 floor f = floor (toRational f)
134 chopZeros :: Integer -> String
136 chopZeros a | mod a 10 == 0 = chopZeros (div a 10)
139 -- only works for positive a
140 showIntegerZeros :: Bool -> Int -> Integer -> String
141 showIntegerZeros True _ 0 = ""
142 showIntegerZeros chopTrailingZeros digits a = replicate (digits - length s) '0' ++ s' where
144 s' = if chopTrailingZeros then chopZeros a else s
146 withDot :: String -> String
150 -- | First arg is whether to chop off trailing zeros
151 showFixed :: (HasResolution a) => Bool -> Fixed a -> String
152 showFixed chopTrailingZeros fa@(MkFixed a) | a < 0 = "-" ++ (showFixed chopTrailingZeros (asTypeOf (MkFixed (negate a)) fa))
153 showFixed chopTrailingZeros fa@(MkFixed a) = (show i) ++ (withDot (showIntegerZeros chopTrailingZeros digits fracNum)) where
156 -- enough digits to be unambiguous
157 digits = ceiling (logBase 10 (fromInteger res) :: Double)
159 fracNum = div (d * maxnum) res
161 readsFixed :: (HasResolution a) => ReadS (Fixed a)
162 readsFixed = readsSigned
163 where readsSigned ('-' : xs) = [ (negate x, rest)
164 | (x, rest) <- readsUnsigned xs ]
165 readsSigned xs = readsUnsigned xs
166 readsUnsigned xs = case span isDigit xs of
169 let i = fromInteger (read is)
172 case span isDigit xs'' of
175 let j = fromInteger (read js)
176 l = genericLength js :: Integer
177 in [(i + (j / (10 ^ l)), xs''')]
180 instance (HasResolution a) => Show (Fixed a) where
181 show = showFixed False
183 instance (HasResolution a) => Read (Fixed a) where
184 readsPrec _ = readsFixed
190 instance HasResolution E0 where
192 -- | resolution of 1, this works the same as Integer
199 instance HasResolution E1 where
201 -- | resolution of 10^-1 = .1
208 instance HasResolution E2 where
210 -- | resolution of 10^-2 = .01, useful for many monetary currencies
211 type Centi = Fixed E2
217 instance HasResolution E3 where
219 -- | resolution of 10^-3 = .001
220 type Milli = Fixed E3
226 instance HasResolution E6 where
227 resolution _ = 1000000
228 -- | resolution of 10^-6 = .000001
229 type Micro = Fixed E6
235 instance HasResolution E9 where
236 resolution _ = 1000000000
237 -- | resolution of 10^-9 = .000000001
244 instance HasResolution E12 where
245 resolution _ = 1000000000000
246 -- | resolution of 10^-12 = .000000000001
247 type Pico = Fixed E12