Data/Fixed.hs

   1 {-# OPTIONS -Wall -fno-warn-unused-binds #-}
   2
   3 -----------------------------------------------------------------------------
   4 -- |
   5 -- Module      :  Data.Fixed
   6 -- Copyright   :  (c) Ashley Yakeley 2005, 2006
   7 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   8 --
   9 -- Maintainer  :  Ashley Yakeley <ashley@semantic.org>
  10 -- Stability   :  experimental
  11 -- Portability :  portable
  12 --
  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.
  16 -- Parameter types E6 and E12 (for 10^6 and 10^12) are defined, as well as
  17 -- type synonyms for Fixed E6 and Fixed E12.
  18 --
  19 -- This module also contains generalisations of div, mod, and divmod to work
  20 -- with any Real instance.
  21 --
  22 -----------------------------------------------------------------------------
  23
  24 module Data.Fixed
  25 (
  26         div',mod',divMod',
  27
  28         Fixed,HasResolution(..),
  29         showFixed,
  30         E6,Micro,
  31         E12,Pico
  32 ) where
  33
  34 import Prelude -- necessary to get dependencies right
  35
  36 -- | generalisation of 'div' to any instance of Real
  37 div' :: (Real a,Integral b) => a -> a -> b
  38 div' n d = floor ((toRational n) / (toRational d))
  39
  40 -- | generalisation of 'divMod' to any instance of Real
  41 divMod' :: (Real a,Integral b) => a -> a -> (b,a)
  42 divMod' n d = (f,n - (fromIntegral f) * d) where
  43         f = div' n d
  44
  45 -- | generalisation of 'mod' to any instance of Real
  46 mod' :: (Real a) => a -> a -> a
  47 mod' n d = n - (fromInteger f) * d where
  48         f = div' n d
  49
  50 newtype Fixed a = MkFixed Integer deriving (Eq,Ord)
  51
  52 class HasResolution a where
  53         resolution :: a -> Integer
  54
  55 fixedResolution :: (HasResolution a) => Fixed a -> Integer
  56 fixedResolution fa = resolution (uf fa) where
  57         uf :: Fixed a -> a
  58         uf _ = undefined
  59
  60 withType :: (a -> f a) -> f a
  61 withType foo = foo undefined
  62
  63 withResolution :: (HasResolution a) => (Integer -> f a) -> f a
  64 withResolution foo = withType (foo . resolution)
  65
  66 instance Enum (Fixed a) where
  67         succ (MkFixed a) = MkFixed (succ a)
  68         pred (MkFixed a) = MkFixed (pred a)
  69         toEnum = MkFixed . toEnum
  70         fromEnum (MkFixed a) = fromEnum a
  71         enumFrom (MkFixed a) = fmap MkFixed (enumFrom a)
  72         enumFromThen (MkFixed a) (MkFixed b) = fmap MkFixed (enumFromThen a b)
  73         enumFromTo (MkFixed a) (MkFixed b) = fmap MkFixed (enumFromTo a b)
  74         enumFromThenTo (MkFixed a) (MkFixed b) (MkFixed c) = fmap MkFixed (enumFromThenTo a b c)
  75
  76 instance (HasResolution a) => Num (Fixed a) where
  77         (MkFixed a) + (MkFixed b) = MkFixed (a + b)
  78         (MkFixed a) - (MkFixed b) = MkFixed (a - b)
  79         fa@(MkFixed a) * (MkFixed b) = MkFixed (div (a * b) (fixedResolution fa))
  80         negate (MkFixed a) = MkFixed (negate a)
  81         abs (MkFixed a) = MkFixed (abs a)
  82         signum (MkFixed a) = fromInteger (signum a)
  83         fromInteger i = withResolution (\res -> MkFixed (i * res))
  84
  85 instance (HasResolution a) => Real (Fixed a) where
  86         toRational fa@(MkFixed a) = (toRational a) / (toRational (fixedResolution fa))
  87
  88 instance (HasResolution a) => Fractional (Fixed a) where
  89         fa@(MkFixed a) / (MkFixed b) = MkFixed (div (a * (fixedResolution fa)) b)
  90         recip fa@(MkFixed a) = MkFixed (div (res * res) a) where
  91                 res = fixedResolution fa
  92         fromRational r = withResolution (\res -> MkFixed (floor (r * (toRational res))))
  93
  94 instance (HasResolution a) => RealFrac (Fixed a) where
  95         properFraction a = (i,a - (fromIntegral i)) where
  96                 i = truncate a
  97         truncate f = truncate (toRational f)
  98         round f = round (toRational f)
  99         ceiling f = ceiling (toRational f)
 100         floor f = floor (toRational f)
 101
 102 chopZeros :: Integer -> String
 103 chopZeros 0 = ""
 104 chopZeros a | mod a 10 == 0 = chopZeros (div a 10)
 105 chopZeros a = show a
 106
 107 -- only works for positive a
 108 showIntegerZeros :: Bool -> Int -> Integer -> String
 109 showIntegerZeros True _ 0 = ""
 110 showIntegerZeros chopTrailingZeros digits a = replicate (digits - length s) '0' ++ s' where
 111         s = show a
 112         s' = if chopTrailingZeros then chopZeros a else s
 113
 114 withDot :: String -> String
 115 withDot "" = ""
 116 withDot s = '.':s
 117
 118 -- | First arg is whether to chop off trailing zeros
 119 showFixed :: (HasResolution a) => Bool -> Fixed a -> String
 120 showFixed chopTrailingZeros fa@(MkFixed a) | a < 0 = "-" ++ (showFixed chopTrailingZeros (asTypeOf (MkFixed (negate a)) fa))
 121 showFixed chopTrailingZeros fa@(MkFixed a) = (show i) ++ (withDot (showIntegerZeros chopTrailingZeros digits fracNum)) where
 122         res = fixedResolution fa
 123         (i,d) = divMod a res
 124         -- enough digits to be unambiguous
 125         digits = ceiling (logBase 10 (fromInteger res) :: Double)
 126         maxnum = 10 ^ digits
 127         fracNum = div (d * maxnum) res
 128
 129 instance (HasResolution a) => Show (Fixed a) where
 130         show = showFixed False
 131
 132
 133
 134 data E6 = E6
 135
 136 instance HasResolution E6 where
 137         resolution _ = 1000000
 138
 139 type Micro = Fixed E6
 140
 141
 142 data E12 = E12
 143
 144 instance HasResolution E12 where
 145         resolution _ = 1000000000000
 146
 147 type Pico = Fixed E12