9dcf4969f45674bcf1c8f7635cac7a691466e609
[haskell-report.git] / report / lib-code / Numeric.hs
1 module Numeric(fromRat,
2 showSigned, showIntAtBase,
3 showInt, showOct, showHex,
4 readSigned, readInt,
5 readDec, readOct, readHex,
6 floatToDigits,
7 showEFloat, showFFloat, showGFloat, showFloat,
8 readFloat, lexDigits) where
9
10 import Char ( isDigit, isOctDigit, isHexDigit
11 , digitToInt, intToDigit )
12 import Ratio ( (%), numerator, denominator )
13 import Array ( (!), Array, array )
14
15 -- This converts a rational to a floating. This should be used in the
16 -- Fractional instances of Float and Double.
17
18 fromRat :: (RealFloat a) => Rational -> a
19 fromRat x =
20 if x == 0 then encodeFloat 0 0 -- Handle exceptional cases
21 else if x < 0 then - fromRat' (-x) -- first.
22 else fromRat' x
23
24 -- Conversion process:
25 -- Scale the rational number by the RealFloat base until
26 -- it lies in the range of the mantissa (as used by decodeFloat/encodeFloat).
27 -- Then round the rational to an Integer and encode it with the exponent
28 -- that we got from the scaling.
29 -- To speed up the scaling process we compute the log2 of the number to get
30 -- a first guess of the exponent.
31 fromRat' :: (RealFloat a) => Rational -> a
32 fromRat' x = r
33 where b = floatRadix r
34 p = floatDigits r
35 (minExp0, _) = floatRange r
36 minExp = minExp0 - p -- the real minimum exponent
37 xMin = toRational (expt b (p-1))
38 xMax = toRational (expt b p)
39 p0 = (integerLogBase b (numerator x) -
40 integerLogBase b (denominator x) - p) `max` minExp
41 f = if p0 < 0 then 1 % expt b (-p0) else expt b p0 % 1
42 (x', p') = scaleRat (toRational b) minExp xMin xMax p0 (x / f)
43 r = encodeFloat (round x') p'
44
45 -- Scale x until xMin <= x < xMax, or p (the exponent) <= minExp.
46 scaleRat :: Rational -> Int -> Rational -> Rational ->
47 Int -> Rational -> (Rational, Int)
48 scaleRat b minExp xMin xMax p x =
49 if p <= minExp then
50 (x, p)
51 else if x >= xMax then
52 scaleRat b minExp xMin xMax (p+1) (x/b)
53 else if x < xMin then
54 scaleRat b minExp xMin xMax (p-1) (x*b)
55 else
56 (x, p)
57
58 -- Exponentiation with a cache for the most common numbers.
59 minExpt = 0::Int
60 maxExpt = 1100::Int
61 expt :: Integer -> Int -> Integer
62 expt base n =
63 if base == 2 && n >= minExpt && n <= maxExpt then
64 expts!n
65 else
66 base^n
67
68 expts :: Array Int Integer
69 expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]]
70
71 -- Compute the (floor of the) log of i in base b.
72 -- Simplest way would be just divide i by b until it's smaller then b,
73 -- but that would be very slow! We are just slightly more clever.
74 integerLogBase :: Integer -> Integer -> Int
75 integerLogBase b i =
76 if i < b then
77 0
78 else
79 -- Try squaring the base first to cut down the number of divisions.
80 let l = 2 * integerLogBase (b*b) i
81 doDiv :: Integer -> Int -> Int
82 doDiv i l = if i < b then l else doDiv (i `div` b) (l+1)
83 in doDiv (i `div` (b^l)) l
84
85
86 -- Misc utilities to show integers and floats
87
88 showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS
89 showSigned showPos p x
90 | x < 0 = showParen (p > 6) (showChar '-' . showPos (-x))
91 | otherwise = showPos x
92
93 -- showInt, showOct, showHex are used for positive numbers only
94 showInt, showOct, showHex :: Integral a => a -> ShowS
95 showOct = showIntAtBase 8 intToDigit
96 showInt = showIntAtBase 10 intToDigit
97 showHex = showIntAtBase 16 intToDigit
98
99 showIntAtBase :: Integral a
100 => a -- base
101 -> (Int -> Char) -- digit to char
102 -> a -- number to show
103 -> ShowS
104 showIntAtBase base intToDig n rest
105 | n < 0 = error "Numeric.showIntAtBase: can't show negative numbers"
106 | n' == 0 = rest'
107 | otherwise = showIntAtBase base intToDig n' rest'
108 where
109 (n',d) = quotRem n base
110 rest' = intToDig (fromIntegral d) : rest
111
112
113 readSigned :: (Real a) => ReadS a -> ReadS a
114 readSigned readPos = readParen False read'
115 where read' r = read'' r ++
116 [(-x,t) | ("-",s) <- lex r,
117 (x,t) <- read'' s]
118 read'' r = [(n,s) | (str,s) <- lex r,
119 (n,"") <- readPos str]
120
121
122 -- readInt reads a string of digits using an arbitrary base.
123 -- Leading minus signs must be handled elsewhere.
124
125 readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
126 readInt radix isDig digToInt s =
127 [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
128 | (ds,r) <- nonnull isDig s ]
129
130 -- Unsigned readers for various bases
131 readDec, readOct, readHex :: (Integral a) => ReadS a
132 readDec = readInt 10 isDigit digitToInt
133 readOct = readInt 8 isOctDigit digitToInt
134 readHex = readInt 16 isHexDigit digitToInt
135
136
137 showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
138 showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
139 showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
140 showFloat :: (RealFloat a) => a -> ShowS
141
142 showEFloat d x = showString (formatRealFloat FFExponent d x)
143 showFFloat d x = showString (formatRealFloat FFFixed d x)
144 showGFloat d x = showString (formatRealFloat FFGeneric d x)
145 showFloat = showGFloat Nothing
146
147 -- These are the format types. This type is not exported.
148
149 data FFFormat = FFExponent | FFFixed | FFGeneric
150
151 formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
152 formatRealFloat fmt decs x
153 = s
154 where
155 base = 10
156 s = if isNaN x then
157 "NaN"
158 else if isInfinite x then
159 if x < 0 then "-Infinity" else "Infinity"
160 else if x < 0 || isNegativeZero x then
161 '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
162 else
163 doFmt fmt (floatToDigits (toInteger base) x)
164
165 doFmt fmt (is, e)
166 = let
167 ds = map intToDigit is
168 in
169 case fmt of
170 FFGeneric ->
171 doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
172 (is, e)
173 FFExponent ->
174 case decs of
175 Nothing ->
176 case ds of
177 [] -> "0.0e0"
178 [d] -> d : ".0e" ++ show (e-1)
179 d:ds -> d : '.' : ds ++ 'e':show (e-1)
180
181 Just dec ->
182 let dec' = max dec 1 in
183 case is of
184 [] -> '0':'.':take dec' (repeat '0') ++ "e0"
185 _ ->
186 let (ei, is') = roundTo base (dec'+1) is
187 d:ds = map intToDigit
188 (if ei > 0 then init is' else is')
189 in d:'.':ds ++ "e" ++ show (e-1+ei)
190
191 FFFixed ->
192 case decs of
193 Nothing -- Always prints a decimal point
194 | e > 0 -> take e (ds ++ repeat '0')
195 ++ '.' : mk0 (drop e ds)
196 | otherwise -> "0." ++ mk0 (replicate (-e) '0' ++ ds)
197
198 Just dec -> -- Print decimal point iff dec > 0
199 let dec' = max dec 0 in
200 if e >= 0 then
201 let (ei, is') = roundTo base (dec' + e) is
202 (ls, rs) = splitAt (e+ei)
203 (map intToDigit is')
204 in mk0 ls ++ mkdot0 rs
205 else
206 let (ei, is') = roundTo base dec'
207 (replicate (-e) 0 ++ is)
208 d : ds = map intToDigit
209 (if ei > 0 then is' else 0:is')
210 in d : mkdot0 ds
211 where
212 mk0 "" = "0" -- Print 0.34, not .34
213 mk0 s = s
214
215 mkdot0 "" = "" -- Print 34, not 34.
216 mkdot0 s = '.' : s -- when the format specifies no
217 -- digits after the decimal point
218
219
220 roundTo :: Int -> Int -> [Int] -> (Int, [Int])
221 roundTo base d is = case f d is of
222 (0, is) -> (0, is)
223 (1, is) -> (1, 1 : is)
224 where b2 = base `div` 2
225 f n [] = (0, replicate n 0)
226 f 0 (i:_) = (if i >= b2 then 1 else 0, [])
227 f d (i:is) =
228 let (c, ds) = f (d-1) is
229 i' = c + i
230 in if i' == base then (1, 0:ds) else (0, i':ds)
231
232 --
233 -- Based on "Printing Floating-Point Numbers Quickly and Accurately"
234 -- by R.G. Burger and R. K. Dybvig, in PLDI 96.
235 -- The version here uses a much slower logarithm estimator.
236 -- It should be improved.
237
238 -- This function returns a non-empty list of digits (Ints in [0..base-1])
239 -- and an exponent. In general, if
240 -- floatToDigits r = ([a, b, ... z], e)
241 -- then
242 -- r = 0.ab..z * base^e
243 --
244
245 floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
246
247 floatToDigits _ 0 = ([], 0)
248 floatToDigits base x =
249 let (f0, e0) = decodeFloat x
250 (minExp0, _) = floatRange x
251 p = floatDigits x
252 b = floatRadix x
253 minExp = minExp0 - p -- the real minimum exponent
254
255 -- Haskell requires that f be adjusted so denormalized numbers
256 -- will have an impossibly low exponent. Adjust for this.
257 f :: Integer
258 e :: Int
259 (f, e) = let n = minExp - e0
260 in if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
261
262 (r, s, mUp, mDn) =
263 if e >= 0 then
264 let be = b^e in
265 if f == b^(p-1) then
266 (f*be*b*2, 2*b, be*b, b)
267 else
268 (f*be*2, 2, be, be)
269 else
270 if e > minExp && f == b^(p-1) then
271 (f*b*2, b^(-e+1)*2, b, 1)
272 else
273 (f*2, b^(-e)*2, 1, 1)
274 k =
275 let k0 =
276 if b==2 && base==10 then
277 -- logBase 10 2 is slightly bigger than 3/10 so
278 -- the following will err on the low side. Ignoring
279 -- the fraction will make it err even more.
280 -- Haskell promises that p-1 <= logBase b f < p.
281 (p - 1 + e0) * 3 `div` 10
282 else
283 ceiling ((log (fromInteger (f+1)) +
284 fromIntegral e * log (fromInteger b)) /
285 log (fromInteger base))
286 fixup n =
287 if n >= 0 then
288 if r + mUp <= expt base n * s then n else fixup (n+1)
289 else
290 if expt base (-n) * (r + mUp) <= s then n
291 else fixup (n+1)
292 in fixup k0
293
294 gen ds rn sN mUpN mDnN =
295 let (dn, rn') = (rn * base) `divMod` sN
296 mUpN' = mUpN * base
297 mDnN' = mDnN * base
298 in case (rn' < mDnN', rn' + mUpN' > sN) of
299 (True, False) -> dn : ds
300 (False, True) -> dn+1 : ds
301 (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
302 (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
303 rds =
304 if k >= 0 then
305 gen [] r (s * expt base k) mUp mDn
306 else
307 let bk = expt base (-k)
308 in gen [] (r * bk) s (mUp * bk) (mDn * bk)
309 in (map fromIntegral (reverse rds), k)
310
311
312
313 -- This floating point reader uses a less restrictive syntax for floating
314 -- point than the Haskell lexer. The `.' is optional.
315
316 readFloat :: (RealFrac a) => ReadS a
317 readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
318 (k,t) <- readExp s] ++
319 [ (0/0, t) | ("NaN",t) <- lex r] ++
320 [ (1/0, t) | ("Infinity",t) <- lex r]
321 where
322 readFix r = [(read (ds++ds'), length ds', t)
323 | (ds,d) <- lexDigits r,
324 (ds',t) <- lexFrac d ]
325
326 lexFrac ('.':ds) = lexDigits ds
327 lexFrac s = [("",s)]
328
329 readExp (e:s) | e `elem` "eE" = readExp' s
330 readExp s = [(0,s)]
331
332 readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
333 readExp' ('+':s) = readDec s
334 readExp' s = readDec s
335
336 lexDigits :: ReadS String
337 lexDigits = nonnull isDigit
338
339 nonnull :: (Char -> Bool) -> ReadS String
340 nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
341