ghc/lib/ghc/PrelNum.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1996
   3 %
   4
   5 \section[PrelNum]{Module @PrelNum@}
   6
   7 Numeric part of the prelude.
   8
   9 It's rather big!
  10
  11 \begin{code}
  12 {-# OPTIONS -H20m #-}
  13 #include "../includes/ieee-flpt.h"
  14 \end{code}
  15
  16 \begin{code}
  17 module PrelNum where
  18
  19 import Prelude  ()
  20 import IOBase   ( error )                       {-# SOURCE #-}
  21 import PrelList
  22 import PrelBase
  23 import GHC
  24
  25 infixr 8  ^, ^^, **
  26 infixl 7  %, `quot`, `rem`, `div`, `mod`
  27 \end{code}
  28
  29
  30 %*********************************************************
  31 %*                                                      *
  32 \subsection{Standard numeric classes}
  33 %*                                                      *
  34 %*********************************************************
  35
  36 \begin{code}
  37 class  (Num a, Ord a) => Real a  where
  38     toRational          ::  a -> Rational
  39
  40 class  (Real a, Enum a) => Integral a  where
  41     quot, rem, div, mod :: a -> a -> a
  42     quotRem, divMod     :: a -> a -> (a,a)
  43     toInteger           :: a -> Integer
  44     toInt               :: a -> Int -- partain: Glasgow extension
  45
  46     n `quot` d          =  q  where (q,r) = quotRem n d
  47     n `rem` d           =  r  where (q,r) = quotRem n d
  48     n `div` d           =  q  where (q,r) = divMod n d
  49     n `mod` d           =  r  where (q,r) = divMod n d
  50     divMod n d          =  if signum r == negate (signum d) then (q-1, r+d) else qr
  51                            where qr@(q,r) = quotRem n d
  52
  53 class  (Num a) => Fractional a  where
  54     (/)                 :: a -> a -> a
  55     recip               :: a -> a
  56     fromRational        :: Rational -> a
  57
  58     recip x             =  1 / x
  59
  60 class  (Fractional a) => Floating a  where
  61     pi                  :: a
  62     exp, log, sqrt      :: a -> a
  63     (**), logBase       :: a -> a -> a
  64     sin, cos, tan       :: a -> a
  65     asin, acos, atan    :: a -> a
  66     sinh, cosh, tanh    :: a -> a
  67     asinh, acosh, atanh :: a -> a
  68
  69     x ** y              =  exp (log x * y)
  70     logBase x y         =  log y / log x
  71     sqrt x              =  x ** 0.5
  72     tan  x              =  sin  x / cos  x
  73     tanh x              =  sinh x / cosh x
  74
  75 class  (Real a, Fractional a) => RealFrac a  where
  76     properFraction      :: (Integral b) => a -> (b,a)
  77     truncate, round     :: (Integral b) => a -> b
  78     ceiling, floor      :: (Integral b) => a -> b
  79
  80     truncate x          =  m  where (m,_) = properFraction x
  81
  82     round x             =  let (n,r) = properFraction x
  83                                m     = if r < 0 then n - 1 else n + 1
  84                            in case signum (abs r - 0.5) of
  85                                 -1 -> n
  86                                 0  -> if even n then n else m
  87                                 1  -> m
  88
  89     ceiling x           =  if r > 0 then n + 1 else n
  90                            where (n,r) = properFraction x
  91
  92     floor x             =  if r < 0 then n - 1 else n
  93                            where (n,r) = properFraction x
  94
  95 class  (RealFrac a, Floating a) => RealFloat a  where
  96     floatRadix          :: a -> Integer
  97     floatDigits         :: a -> Int
  98     floatRange          :: a -> (Int,Int)
  99     decodeFloat         :: a -> (Integer,Int)
 100     encodeFloat         :: Integer -> Int -> a
 101     exponent            :: a -> Int
 102     significand         :: a -> a
 103     scaleFloat          :: Int -> a -> a
 104     isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
 105                         :: a -> Bool
 106
 107     exponent x          =  if m == 0 then 0 else n + floatDigits x
 108                            where (m,n) = decodeFloat x
 109
 110     significand x       =  encodeFloat m (negate (floatDigits x))
 111                            where (m,_) = decodeFloat x
 112
 113     scaleFloat k x      =  encodeFloat m (n+k)
 114                            where (m,n) = decodeFloat x
 115 \end{code}
 116
 117 %*********************************************************
 118 %*                                                      *
 119 \subsection{Overloaded numeric functions}
 120 %*                                                      *
 121 %*********************************************************
 122
 123 \begin{code}
 124 even, odd       :: (Integral a) => a -> Bool
 125 even n          =  n `rem` 2 == 0
 126 odd             =  not . even
 127
 128 {-# GENERATE_SPECS gcd a{Int#,Int,Integer} #-}
 129 gcd             :: (Integral a) => a -> a -> a
 130 gcd 0 0         =  error "Prelude.gcd: gcd 0 0 is undefined"
 131 gcd x y         =  gcd' (abs x) (abs y)
 132                    where gcd' x 0  =  x
 133                          gcd' x y  =  gcd' y (x `rem` y)
 134
 135 {-# GENERATE_SPECS lcm a{Int#,Int,Integer} #-}
 136 lcm             :: (Integral a) => a -> a -> a
 137 lcm _ 0         =  0
 138 lcm 0 _         =  0
 139 lcm x y         =  abs ((x `quot` (gcd x y)) * y)
 140
 141 (^)             :: (Num a, Integral b) => a -> b -> a
 142 x ^ 0           =  1
 143 x ^ n | n > 0   =  f x (n-1) x
 144                    where f _ 0 y = y
 145                          f x n y = g x n  where
 146                                    g x n | even n  = g (x*x) (n `quot` 2)
 147                                          | otherwise = f x (n-1) (x*y)
 148 _ ^ _           = error "Prelude.^: negative exponent"
 149
 150 (^^)            :: (Fractional a, Integral b) => a -> b -> a
 151 x ^^ n          =  if n >= 0 then x^n else recip (x^(negate n))
 152
 153 fromIntegral    :: (Integral a, Num b) => a -> b
 154 fromIntegral    =  fromInteger . toInteger
 155
 156 fromRealFrac    :: (RealFrac a, Fractional b) => a -> b
 157 fromRealFrac    =  fromRational . toRational
 158
 159 atan2           :: (RealFloat a) => a -> a -> a
 160 atan2 y x       =  case (signum y, signum x) of
 161                         ( 0, 1) ->  0
 162                         ( 1, 0) ->  pi/2
 163                         ( 0,-1) ->  pi
 164                         (-1, 0) ->  (negate pi)/2
 165                         ( _, 1) ->  atan (y/x)
 166                         ( _,-1) ->  atan (y/x) + pi
 167                         ( 0, 0) ->  error "Prelude.atan2: atan2 of origin"
 168 \end{code}
 169
 170
 171 %*********************************************************
 172 %*                                                      *
 173 \subsection{Instances for @Int@}
 174 %*                                                      *
 175 %*********************************************************
 176
 177 \begin{code}
 178 instance  Real Int  where
 179     toRational x        =  toInteger x % 1
 180
 181 instance  Integral Int  where
 182     a@(I# _) `quotRem` b@(I# _) = (a `quotInt` b, a `remInt` b)
 183     -- OK, so I made it a little stricter.  Shoot me.  (WDP 94/10)
 184
 185     -- following chks for zero divisor are non-standard (WDP)
 186     a `quot` b          =  if b /= 0
 187                            then a `quotInt` b
 188                            else error "Integral.Int.quot{PreludeCore}: divide by 0\n"
 189     a `rem` b           =  if b /= 0
 190                            then a `remInt` b
 191                            else error "Integral.Int.rem{PreludeCore}: divide by 0\n"
 192
 193     x `div` y = if x > 0 && y < 0       then quotInt (x-y-1) y
 194                 else if x < 0 && y > 0  then quotInt (x-y+1) y
 195                 else quotInt x y
 196     x `mod` y = if x > 0 && y < 0 || x < 0 && y > 0 then
 197                     if r/=0 then r+y else 0
 198                 else
 199                     r
 200               where r = remInt x y
 201
 202     divMod x@(I# _) y@(I# _) = (x `div` y, x `mod` y)
 203     -- Stricter.  Sorry if you don't like it.  (WDP 94/10)
 204
 205 --OLD:   even x = eqInt (x `mod` 2) 0
 206 --OLD:   odd x  = neInt (x `mod` 2) 0
 207
 208     toInteger (I# n#) = int2Integer# n#  -- give back a full-blown Integer
 209     toInt x           = x
 210
 211 \end{code}
 212
 213
 214 %*********************************************************
 215 %*                                                      *
 216 \subsection{Type @Integer@}
 217 %*                                                      *
 218 %*********************************************************
 219
 220 These types are used to return from integer primops
 221
 222 \begin{code}
 223 data Return2GMPs     = Return2GMPs     Int# Int# ByteArray# Int# Int# ByteArray#
 224 data ReturnIntAndGMP = ReturnIntAndGMP Int# Int# Int# ByteArray#
 225 \end{code}
 226
 227 Instances
 228
 229 \begin{code}
 230 instance  Eq Integer  where
 231     (J# a1 s1 d1) == (J# a2 s2 d2)
 232       = (cmpInteger# a1 s1 d1 a2 s2 d2) ==# 0#
 233
 234     (J# a1 s1 d1) /= (J# a2 s2 d2)
 235       = (cmpInteger# a1 s1 d1 a2 s2 d2) /=# 0#
 236
 237 instance  Ord Integer  where
 238     (J# a1 s1 d1) <= (J# a2 s2 d2)
 239       = (cmpInteger# a1 s1 d1 a2 s2 d2) <=# 0#
 240
 241     (J# a1 s1 d1) <  (J# a2 s2 d2)
 242       = (cmpInteger# a1 s1 d1 a2 s2 d2) <# 0#
 243
 244     (J# a1 s1 d1) >= (J# a2 s2 d2)
 245       = (cmpInteger# a1 s1 d1 a2 s2 d2) >=# 0#
 246
 247     (J# a1 s1 d1) >  (J# a2 s2 d2)
 248       = (cmpInteger# a1 s1 d1 a2 s2 d2) ># 0#
 249
 250     x@(J# a1 s1 d1) `max` y@(J# a2 s2 d2)
 251       = if ((cmpInteger# a1 s1 d1 a2 s2 d2) ># 0#) then x else y
 252
 253     x@(J# a1 s1 d1) `min` y@(J# a2 s2 d2)
 254       = if ((cmpInteger# a1 s1 d1 a2 s2 d2) <# 0#) then x else y
 255
 256     compare (J# a1 s1 d1) (J# a2 s2 d2)
 257        = case cmpInteger# a1 s1 d1 a2 s2 d2 of { res# ->
 258          if res# <# 0# then LT else
 259          if res# ># 0# then GT else EQ
 260          }
 261
 262 instance  Num Integer  where
 263     (+) (J# a1 s1 d1) (J# a2 s2 d2)
 264       = plusInteger# a1 s1 d1 a2 s2 d2
 265
 266     (-) (J# a1 s1 d1) (J# a2 s2 d2)
 267       = minusInteger# a1 s1 d1 a2 s2 d2
 268
 269     negate (J# a s d) = negateInteger# a s d
 270
 271     (*) (J# a1 s1 d1) (J# a2 s2 d2)
 272       = timesInteger# a1 s1 d1 a2 s2 d2
 273
 274     -- ORIG: abs n = if n >= 0 then n else -n
 275
 276     abs n@(J# a1 s1 d1)
 277       = case 0 of { J# a2 s2 d2 ->
 278         if (cmpInteger# a1 s1 d1 a2 s2 d2) >=# 0#
 279         then n
 280         else negateInteger# a1 s1 d1
 281         }
 282
 283     signum n@(J# a1 s1 d1)
 284       = case 0 of { J# a2 s2 d2 ->
 285         let
 286             cmp = cmpInteger# a1 s1 d1 a2 s2 d2
 287         in
 288         if      cmp >#  0# then 1
 289         else if cmp ==# 0# then 0
 290         else                    (negate 1)
 291         }
 292
 293     fromInteger x       =  x
 294
 295     fromInt (I# n#)     =  int2Integer# n# -- gives back a full-blown Integer
 296
 297 instance  Real Integer  where
 298     toRational x        =  x % 1
 299
 300 instance  Integral Integer where
 301     quotRem (J# a1 s1 d1) (J# a2 s2 d2)
 302       = case (quotRemInteger# a1 s1 d1 a2 s2 d2) of
 303           Return2GMPs a3 s3 d3 a4 s4 d4
 304             -> (J# a3 s3 d3, J# a4 s4 d4)
 305
 306 {- USING THE UNDERLYING "GMP" CODE IS DUBIOUS FOR NOW:
 307
 308     divMod (J# a1 s1 d1) (J# a2 s2 d2)
 309       = case (divModInteger# a1 s1 d1 a2 s2 d2) of
 310           Return2GMPs a3 s3 d3 a4 s4 d4
 311             -> (J# a3 s3 d3, J# a4 s4 d4)
 312 -}
 313     toInteger n      = n
 314     toInt (J# a s d) = case (integer2Int# a s d) of { n# -> I# n# }
 315
 316     -- the rest are identical to the report default methods;
 317     -- you get slightly better code if you let the compiler
 318     -- see them right here:
 319     n `quot` d  =  q  where (q,r) = quotRem n d
 320     n `rem` d   =  r  where (q,r) = quotRem n d
 321     n `div` d   =  q  where (q,r) = divMod n d
 322     n `mod` d   =  r  where (q,r) = divMod n d
 323
 324     divMod n d  =  case (quotRem n d) of { qr@(q,r) ->
 325                    if signum r == negate (signum d) then (q - 1, r+d) else qr }
 326                    -- Case-ified by WDP 94/10
 327
 328 instance  Enum Integer  where
 329     enumFrom n           =  n : enumFrom (n + 1)
 330     enumFromThen m n     =  en' m (n - m)
 331                             where en' m n = m : en' (m + n) n
 332     enumFromTo n m       =  takeWhile (<= m) (enumFrom n)
 333     enumFromThenTo n m p =  takeWhile (if m >= n then (<= p) else (>= p))
 334                                       (enumFromThen n m)
 335
 336 instance  Show Integer  where
 337     showsPrec   x = showSignedInteger x
 338     showList = showList__ (showsPrec 0)
 339
 340 integer_0, integer_1, integer_2, integer_m1 :: Integer
 341 integer_0 = 0; integer_1 = 1; integer_2 = 2; integer_m1 = -1
 342 \end{code}
 343
 344
 345 %*********************************************************
 346 %*                                                      *
 347 \subsection{Type @Float@}
 348 %*                                                      *
 349 %*********************************************************
 350
 351 \begin{code}
 352 instance  Num Float  where
 353     (+)         x y     =  plusFloat x y
 354     (-)         x y     =  minusFloat x y
 355     negate      x       =  negateFloat x
 356     (*)         x y     =  timesFloat x y
 357     abs x | x >= 0.0    =  x
 358           | otherwise   =  negateFloat x
 359     signum x | x == 0.0  = 0
 360              | x > 0.0   = 1
 361              | otherwise = negate 1
 362     fromInteger n       =  encodeFloat n 0
 363     fromInt i           =  int2Float i
 364
 365 instance  Real Float  where
 366     toRational x        =  (m%1)*(b%1)^^n
 367                            where (m,n) = decodeFloat x
 368                                  b     = floatRadix  x
 369
 370 instance  Fractional Float  where
 371     (/) x y             =  divideFloat x y
 372     fromRational x      =  fromRational__ x
 373     recip x             =  1.0 / x
 374
 375 instance  Floating Float  where
 376     pi                  =  3.141592653589793238
 377     exp x               =  expFloat x
 378     log x               =  logFloat x
 379     sqrt x              =  sqrtFloat x
 380     sin x               =  sinFloat x
 381     cos x               =  cosFloat x
 382     tan x               =  tanFloat x
 383     asin x              =  asinFloat x
 384     acos x              =  acosFloat x
 385     atan x              =  atanFloat x
 386     sinh x              =  sinhFloat x
 387     cosh x              =  coshFloat x
 388     tanh x              =  tanhFloat x
 389     (**) x y            =  powerFloat x y
 390     logBase x y         =  log y / log x
 391
 392     asinh x = log (x + sqrt (1.0+x*x))
 393     acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0)))
 394     atanh x = log ((x+1.0) / sqrt (1.0-x*x))
 395
 396 instance  RealFrac Float  where
 397
 398     {-# SPECIALIZE properFraction :: Float -> (Int, Float) #-}
 399     {-# SPECIALIZE truncate :: Float -> Int #-}
 400     {-# SPECIALIZE round    :: Float -> Int #-}
 401     {-# SPECIALIZE ceiling  :: Float -> Int #-}
 402     {-# SPECIALIZE floor    :: Float -> Int #-}
 403
 404     {-# SPECIALIZE properFraction :: Float -> (Integer, Float) #-}
 405     {-# SPECIALIZE truncate :: Float -> Integer #-}
 406     {-# SPECIALIZE round    :: Float -> Integer #-}
 407     {-# SPECIALIZE ceiling  :: Float -> Integer #-}
 408     {-# SPECIALIZE floor    :: Float -> Integer #-}
 409
 410     properFraction x
 411       = case (decodeFloat x)      of { (m,n) ->
 412         let  b = floatRadix x     in
 413         if n >= 0 then
 414             (fromInteger m * fromInteger b ^ n, 0.0)
 415         else
 416             case (quotRem m (b^(negate n))) of { (w,r) ->
 417             (fromInteger w, encodeFloat r n)
 418             }
 419         }
 420
 421     truncate x  = case properFraction x of
 422                      (n,_) -> n
 423
 424     round x     = case properFraction x of
 425                      (n,r) -> let
 426                                 m         = if r < 0.0 then n - 1 else n + 1
 427                                 half_down = abs r - 0.5
 428                               in
 429                               case (compare half_down 0.0) of
 430                                 LT -> n
 431                                 EQ -> if even n then n else m
 432                                 GT -> m
 433
 434     ceiling x   = case properFraction x of
 435                     (n,r) -> if r > 0.0 then n + 1 else n
 436
 437     floor x     = case properFraction x of
 438                     (n,r) -> if r < 0.0 then n - 1 else n
 439
 440 instance  RealFloat Float  where
 441     floatRadix _        =  FLT_RADIX        -- from float.h
 442     floatDigits _       =  FLT_MANT_DIG     -- ditto
 443     floatRange _        =  (FLT_MIN_EXP, FLT_MAX_EXP) -- ditto
 444
 445     decodeFloat (F# f#)
 446       = case decodeFloat# f#    of
 447           ReturnIntAndGMP exp# a# s# d# ->
 448             (J# a# s# d#, I# exp#)
 449
 450     encodeFloat (J# a# s# d#) (I# e#)
 451       = case encodeFloat# a# s# d# e# of { flt# -> F# flt# }
 452
 453     exponent x          = case decodeFloat x of
 454                             (m,n) -> if m == 0 then 0 else n + floatDigits x
 455
 456     significand x       = case decodeFloat x of
 457                             (m,_) -> encodeFloat m (negate (floatDigits x))
 458
 459     scaleFloat k x      = case decodeFloat x of
 460                             (m,n) -> encodeFloat m (n+k)
 461
 462 instance  Show Float  where
 463     showsPrec   x = showSigned showFloat x
 464     showList = showList__ (showsPrec 0)
 465 \end{code}
 466
 467 %*********************************************************
 468 %*                                                      *
 469 \subsection{Type @Double@}
 470 %*                                                      *
 471 %*********************************************************
 472
 473 \begin{code}
 474 instance  Num Double  where
 475     (+)         x y     =  plusDouble x y
 476     (-)         x y     =  minusDouble x y
 477     negate      x       =  negateDouble x
 478     (*)         x y     =  timesDouble x y
 479     abs x | x >= 0.0    =  x
 480           | otherwise   =  negateDouble x
 481     signum x | x == 0.0  = 0
 482              | x > 0.0   = 1
 483              | otherwise = negate 1
 484     fromInteger n       =  encodeFloat n 0
 485     fromInt (I# n#)     =  case (int2Double# n#) of { d# -> D# d# }
 486
 487 instance  Real Double  where
 488     toRational x        =  (m%1)*(b%1)^^n
 489                            where (m,n) = decodeFloat x
 490                                  b     = floatRadix  x
 491
 492 instance  Fractional Double  where
 493     (/) x y             =  divideDouble x y
 494     fromRational x      =  fromRational__ x
 495     recip x             =  1.0 / x
 496
 497 instance  Floating Double  where
 498     pi                  =  3.141592653589793238
 499     exp x               =  expDouble x
 500     log x               =  logDouble x
 501     sqrt x              =  sqrtDouble x
 502     sin  x              =  sinDouble x
 503     cos  x              =  cosDouble x
 504     tan  x              =  tanDouble x
 505     asin x              =  asinDouble x
 506     acos x              =  acosDouble x
 507     atan x              =  atanDouble x
 508     sinh x              =  sinhDouble x
 509     cosh x              =  coshDouble x
 510     tanh x              =  tanhDouble x
 511     (**) x y            =  powerDouble x y
 512     logBase x y         =  log y / log x
 513
 514     asinh x = log (x + sqrt (1.0+x*x))
 515     acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0)))
 516     atanh x = log ((x+1.0) / sqrt (1.0-x*x))
 517
 518 instance  RealFrac Double  where
 519
 520     {-# SPECIALIZE properFraction :: Double -> (Int, Double) #-}
 521     {-# SPECIALIZE truncate :: Double -> Int #-}
 522     {-# SPECIALIZE round    :: Double -> Int #-}
 523     {-# SPECIALIZE ceiling  :: Double -> Int #-}
 524     {-# SPECIALIZE floor    :: Double -> Int #-}
 525
 526     {-# SPECIALIZE properFraction :: Double -> (Integer, Double) #-}
 527     {-# SPECIALIZE truncate :: Double -> Integer #-}
 528     {-# SPECIALIZE round    :: Double -> Integer #-}
 529     {-# SPECIALIZE ceiling  :: Double -> Integer #-}
 530     {-# SPECIALIZE floor    :: Double -> Integer #-}
 531
 532 #if defined(__UNBOXED_INSTANCES__)
 533     {-# SPECIALIZE properFraction :: Double -> (Int#, Double) #-}
 534     {-# SPECIALIZE truncate :: Double -> Int# #-}
 535     {-# SPECIALIZE round    :: Double -> Int# #-}
 536     {-# SPECIALIZE ceiling  :: Double -> Int# #-}
 537     {-# SPECIALIZE floor    :: Double -> Int# #-}
 538 #endif
 539
 540     properFraction x
 541       = case (decodeFloat x)      of { (m,n) ->
 542         let  b = floatRadix x     in
 543         if n >= 0 then
 544             (fromInteger m * fromInteger b ^ n, 0.0)
 545         else
 546             case (quotRem m (b^(negate n))) of { (w,r) ->
 547             (fromInteger w, encodeFloat r n)
 548             }
 549         }
 550
 551     truncate x  = case properFraction x of
 552                      (n,_) -> n
 553
 554     round x     = case properFraction x of
 555                      (n,r) -> let
 556                                 m         = if r < 0.0 then n - 1 else n + 1
 557                                 half_down = abs r - 0.5
 558                               in
 559                               case (compare half_down 0.0) of
 560                                 LT -> n
 561                                 EQ -> if even n then n else m
 562                                 GT -> m
 563
 564     ceiling x   = case properFraction x of
 565                     (n,r) -> if r > 0.0 then n + 1 else n
 566
 567     floor x     = case properFraction x of
 568                     (n,r) -> if r < 0.0 then n - 1 else n
 569
 570 instance  RealFloat Double  where
 571     floatRadix _        =  FLT_RADIX        -- from float.h
 572     floatDigits _       =  DBL_MANT_DIG     -- ditto
 573     floatRange _        =  (DBL_MIN_EXP, DBL_MAX_EXP) -- ditto
 574
 575     decodeFloat (D# d#)
 576       = case decodeDouble# d#   of
 577           ReturnIntAndGMP exp# a# s# d# ->
 578             (J# a# s# d#, I# exp#)
 579
 580     encodeFloat (J# a# s# d#) (I# e#)
 581       = case encodeDouble# a# s# d# e#  of { dbl# -> D# dbl# }
 582
 583     exponent x          = case decodeFloat x of
 584                             (m,n) -> if m == 0 then 0 else n + floatDigits x
 585
 586     significand x       = case decodeFloat x of
 587                             (m,_) -> encodeFloat m (negate (floatDigits x))
 588
 589     scaleFloat k x      = case decodeFloat x of
 590                             (m,n) -> encodeFloat m (n+k)
 591
 592 instance  Show Double  where
 593     showsPrec   x = showSigned showFloat x
 594     showList = showList__ (showsPrec 0)
 595 \end{code}
 596
 597
 598 %*********************************************************
 599 %*                                                      *
 600 \subsection{Common code for @Float@ and @Double@}
 601 %*                                                      *
 602 %*********************************************************
 603
 604 The Enum instances for Floats and Doubles are slightly unusual.
 605 The `toEnum' function truncates numbers to Int.  The definitions
 606 of enumFrom and enumFromThen allow floats to be used in arithmetic
 607 series: [0,0.1 .. 1.0].  However, roundoff errors make these somewhat
 608 dubious.  This example may have either 10 or 11 elements, depending on
 609 how 0.1 is represented.
 610
 611 \begin{code}
 612 instance  Enum Float  where
 613     toEnum              =  fromIntegral
 614     fromEnum            =  fromInteger . truncate   -- may overflow
 615     enumFrom            =  numericEnumFrom
 616     enumFromThen        =  numericEnumFromThen
 617
 618 instance  Enum Double  where
 619     toEnum              =  fromIntegral
 620     fromEnum            =  fromInteger . truncate   -- may overflow
 621     enumFrom            =  numericEnumFrom
 622     enumFromThen        =  numericEnumFromThen
 623
 624 numericEnumFrom         :: (Real a) => a -> [a]
 625 numericEnumFromThen     :: (Real a) => a -> a -> [a]
 626 numericEnumFrom         =  iterate (+1)
 627 numericEnumFromThen n m =  iterate (+(m-n)) n
 628 \end{code}
 629
 630
 631 %*********************************************************
 632 %*                                                      *
 633 \subsection{The @Ratio@ and @Rational@ types}
 634 %*                                                      *
 635 %*********************************************************
 636
 637 \begin{code}
 638 data  (Integral a)      => Ratio a = a :% a  deriving (Eq)
 639 type  Rational          =  Ratio Integer
 640 \end{code}
 641
 642 \begin{code}
 643 (%)                     :: (Integral a) => a -> a -> Ratio a
 644 numerator, denominator  :: (Integral a) => Ratio a -> a
 645 approxRational          :: (RealFrac a) => a -> a -> Rational
 646
 647
 648 reduce _ 0              =  error "{Ratio.%}: zero denominator"
 649 reduce x y              =  (x `quot` d) :% (y `quot` d)
 650                            where d = gcd x y
 651
 652 x % y                   =  reduce (x * signum y) (abs y)
 653
 654 numerator (x:%y)        =  x
 655
 656 denominator (x:%y)      =  y
 657 \end{code}
 658
 659
 660 @approxRational@, applied to two real fractional numbers x and epsilon,
 661 returns the simplest rational number within epsilon of x.  A rational
 662 number n%d in reduced form is said to be simpler than another n'%d' if
 663 abs n <= abs n' && d <= d'.  Any real interval contains a unique
 664 simplest rational; here, for simplicity, we assume a closed rational
 665 interval.  If such an interval includes at least one whole number, then
 666 the simplest rational is the absolutely least whole number.  Otherwise,
 667 the bounds are of the form q%1 + r%d and q%1 + r'%d', where abs r < d
 668 and abs r' < d', and the simplest rational is q%1 + the reciprocal of
 669 the simplest rational between d'%r' and d%r.
 670
 671 \begin{code}
 672 approxRational x eps    =  simplest (x-eps) (x+eps)
 673         where simplest x y | y < x      =  simplest y x
 674                            | x == y     =  xr
 675                            | x > 0      =  simplest' n d n' d'
 676                            | y < 0      =  - simplest' (-n') d' (-n) d
 677                            | otherwise  =  0 :% 1
 678                                         where xr@(n:%d) = toRational x
 679                                               (n':%d')  = toRational y
 680
 681               simplest' n d n' d'       -- assumes 0 < n%d < n'%d'
 682                         | r == 0     =  q :% 1
 683                         | q /= q'    =  (q+1) :% 1
 684                         | otherwise  =  (q*n''+d'') :% n''
 685                                      where (q,r)      =  quotRem n d
 686                                            (q',r')    =  quotRem n' d'
 687                                            (n'':%d'') =  simplest' d' r' d r
 688 \end{code}
 689
 690
 691 \begin{code}
 692 instance  (Integral a)  => Ord (Ratio a)  where
 693     (x:%y) <= (x':%y')  =  x * y' <= x' * y
 694     (x:%y) <  (x':%y')  =  x * y' <  x' * y
 695
 696 instance  (Integral a)  => Num (Ratio a)  where
 697     (x:%y) + (x':%y')   =  reduce (x*y' + x'*y) (y*y')
 698     (x:%y) * (x':%y')   =  reduce (x * x') (y * y')
 699     negate (x:%y)       =  (-x) :% y
 700     abs (x:%y)          =  abs x :% y
 701     signum (x:%y)       =  signum x :% 1
 702     fromInteger x       =  fromInteger x :% 1
 703
 704 instance  (Integral a)  => Real (Ratio a)  where
 705     toRational (x:%y)   =  toInteger x :% toInteger y
 706
 707 instance  (Integral a)  => Fractional (Ratio a)  where
 708     (x:%y) / (x':%y')   =  (x*y') % (y*x')
 709     recip (x:%y)        =  if x < 0 then (-y) :% (-x) else y :% x
 710     fromRational (x:%y) =  fromInteger x :% fromInteger y
 711
 712 instance  (Integral a)  => RealFrac (Ratio a)  where
 713     properFraction (x:%y) = (fromIntegral q, r:%y)
 714                             where (q,r) = quotRem x y
 715
 716 instance  (Integral a)  => Enum (Ratio a)  where
 717     enumFrom            =  iterate ((+)1)
 718     enumFromThen n m    =  iterate ((+)(m-n)) n
 719     toEnum n            =  fromIntegral n :% 1
 720     fromEnum            =  fromInteger . truncate
 721
 722 ratio_prec :: Int
 723 ratio_prec = 7
 724
 725 instance  (Integral a)  => Show (Ratio a)  where
 726     showsPrec p (x:%y)  =  showParen (p > ratio_prec)
 727                                (shows x . showString " % " . shows y)
 728 \end{code}
 729
 730 {-
 731 [In response to a request by simonpj, Joe Fasel writes:]
 732
 733 A quite reasonable request!  This code was added to the Prelude just
 734 before the 1.2 release, when Lennart, working with an early version
 735 of hbi, noticed that (read . show) was not the identity for
 736 floating-point numbers.  (There was a one-bit error about half the time.)
 737 The original version of the conversion function was in fact simply
 738 a floating-point divide, as you suggest above.  The new version is,
 739 I grant you, somewhat denser.
 740
 741 How's this?
 742
 743 Joe
 744 -}
 745
 746 \begin{code}
 747 {-# GENERATE_SPECS fromRational__ a{Double#,Double} #-}
 748 fromRational__ :: (RealFloat a) => Rational -> a
 749 fromRational__ x = x'
 750         where x' = f e
 751
 752 --              If the exponent of the nearest floating-point number to x
 753 --              is e, then the significand is the integer nearest xb^(-e),
 754 --              where b is the floating-point radix.  We start with a good
 755 --              guess for e, and if it is correct, the exponent of the
 756 --              floating-point number we construct will again be e.  If
 757 --              not, one more iteration is needed.
 758
 759               f e   = if e' == e then y else f e'
 760                       where y      = encodeFloat (round (x * (1 % b)^^e)) e
 761                             (_,e') = decodeFloat y
 762               b     = floatRadix x'
 763
 764 --              We obtain a trial exponent by doing a floating-point
 765 --              division of x's numerator by its denominator.  The
 766 --              result of this division may not itself be the ultimate
 767 --              result, because of an accumulation of three rounding
 768 --              errors.
 769
 770               (s,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
 771                                         / fromInteger (denominator x))
 772 \end{code}
 773
 774
 775 %*********************************************************
 776 %*                                                      *
 777 \subsection{Showing numbers}
 778 %*                                                      *
 779 %*********************************************************
 780
 781 \begin{code}
 782 showInteger n r
 783   = case quotRem n 10 of                     { (n', d) ->
 784     case (chr (ord_0 + fromIntegral d)) of { C# c# -> -- stricter than necessary
 785     let
 786         r' = C# c# : r
 787     in
 788     if n' == 0 then r' else showInteger n' r'
 789     }}
 790
 791 showSigned :: (Real a) => (a -> ShowS) -> Int -> a -> ShowS
 792 showSigned showPos p x = if x < 0 then showParen (p > 6)
 793                                                  (showChar '-' . showPos (-x))
 794                                   else showPos x
 795
 796 showSignedInteger :: Int -> Integer -> ShowS
 797 showSignedInteger p n r
 798   = -- from HBC version; support code follows
 799     if n < 0 && p > 6 then '(':jtos n++(')':r) else jtos n ++ r
 800
 801 jtos :: Integer -> String
 802 jtos n
 803   = if n < 0 then
 804         '-' : jtos' (-n) []
 805     else
 806         jtos' n []
 807
 808 jtos' :: Integer -> String -> String
 809 jtos' n cs
 810   = if n < 10 then
 811         chr (fromInteger (n + ord_0)) : cs
 812     else
 813         jtos' (n `quot` 10) (chr (fromInteger (n `rem` 10 + ord_0)) : cs)
 814 \end{code}
 815
 816 The functions showFloat below uses rational arithmetic
 817 to insure correct conversion between the floating-point radix and
 818 decimal.  It is often possible to use a higher-precision floating-
 819 point type to obtain the same results.
 820
 821 \begin{code}
 822 {-# GENERATE_SPECS showFloat a{Double#,Double} #-}
 823 showFloat:: (RealFloat a) => a -> ShowS
 824 showFloat x =
 825     if x == 0 then showString ("0." ++ take (m-1) zeros)
 826               else if e >= m-1 || e < 0 then showSci else showFix
 827     where
 828     showFix     = showString whole . showChar '.' . showString frac
 829                   where (whole,frac) = splitAt (e+1) (show sig)
 830     showSci     = showChar d . showChar '.' . showString frac
 831                       . showChar 'e' . shows e
 832                   where (d:frac) = show sig
 833     (m, sig, e) = if b == 10 then (w,   s,   n+w-1)
 834                              else (m', sig', e'   )
 835     m'          = ceiling
 836                       ((fromInt w * log (fromInteger b)) / log 10 :: Double)
 837                   + 1
 838     (sig', e')  = if      sig1 >= 10^m'     then (round (t/10), e1+1)
 839                   else if sig1 <  10^(m'-1) then (round (t*10), e1-1)
 840                                             else (sig1,          e1  )
 841     sig1        = round t
 842     t           = s%1 * (b%1)^^n * 10^^(m'-e1-1)
 843     e1          = floor (logBase 10 x)
 844     (s, n)      = decodeFloat x
 845     b           = floatRadix x
 846     w           = floatDigits x
 847
 848 zeros = repeat '0'
 849 \end{code}
 850
 851 @showRational@ converts a Rational to a string that looks like a
 852 floating point number, but without converting to any floating type
 853 (because of the possible overflow).
 854
 855 From/by Lennart, 94/09/26
 856
 857 \begin{code}
 858 showRational :: Int -> Rational -> String
 859 showRational n r =
 860     if r == 0 then
 861         "0.0"
 862     else
 863         let (r', e) = normalize r
 864         in  prR n r' e
 865
 866 startExpExp = 4 :: Int
 867
 868 -- make sure 1 <= r < 10
 869 normalize :: Rational -> (Rational, Int)
 870 normalize r = if r < 1 then
 871                   case norm startExpExp (1 / r) 0 of (r', e) -> (10 / r', -e-1)
 872               else
 873                   norm startExpExp r 0
 874         where norm :: Int -> Rational -> Int -> (Rational, Int)
 875               -- Invariant: r*10^e == original r
 876               norm 0  r e = (r, e)
 877               norm ee r e =
 878                 let n = 10^ee
 879                     tn = 10^n
 880                 in  if r >= tn then norm ee (r/tn) (e+n) else norm (ee-1) r e
 881
 882 drop0 "" = ""
 883 drop0 (c:cs) = c : reverse (dropWhile (=='0') (reverse cs))
 884
 885 prR :: Int -> Rational -> Int -> String
 886 prR n r e | r <  1  = prR n (r*10) (e-1)                -- final adjustment
 887 prR n r e | r >= 10 = prR n (r/10) (e+1)
 888 prR n r e0 =
 889         let s = show ((round (r * 10^n))::Integer)
 890             e = e0+1
 891         in  if e > 0 && e < 8 then
 892                 take e s ++ "." ++ drop0 (drop e s)
 893             else if e <= 0 && e > -3 then
 894                 "0." ++ take (-e) (repeat '0') ++ drop0 s
 895             else
 896                 head s : "."++ drop0 (tail s) ++ "e" ++ show e0
 897 \end{code}
 898
 899 %*********************************************************
 900 %*                                                      *
 901 \subsection{Numeric primops}
 902 %*                                                      *
 903 %*********************************************************
 904
 905 Definitions of the boxed PrimOps; these will be
 906 used in the case of partial applications, etc.
 907
 908 \begin{code}
 909 plusFloat   (F# x) (F# y) = F# (plusFloat# x y)
 910 minusFloat  (F# x) (F# y) = F# (minusFloat# x y)
 911 timesFloat  (F# x) (F# y) = F# (timesFloat# x y)
 912 divideFloat (F# x) (F# y) = F# (divideFloat# x y)
 913 negateFloat (F# x)        = F# (negateFloat# x)
 914
 915 gtFloat     (F# x) (F# y) = gtFloat# x y
 916 geFloat     (F# x) (F# y) = geFloat# x y
 917 eqFloat     (F# x) (F# y) = eqFloat# x y
 918 neFloat     (F# x) (F# y) = neFloat# x y
 919 ltFloat     (F# x) (F# y) = ltFloat# x y
 920 leFloat     (F# x) (F# y) = leFloat# x y
 921
 922 float2Int   (F# x) = I# (float2Int# x)
 923 int2Float   (I# x) = F# (int2Float# x)
 924
 925 expFloat    (F# x) = F# (expFloat# x)
 926 logFloat    (F# x) = F# (logFloat# x)
 927 sqrtFloat   (F# x) = F# (sqrtFloat# x)
 928 sinFloat    (F# x) = F# (sinFloat# x)
 929 cosFloat    (F# x) = F# (cosFloat# x)
 930 tanFloat    (F# x) = F# (tanFloat# x)
 931 asinFloat   (F# x) = F# (asinFloat# x)
 932 acosFloat   (F# x) = F# (acosFloat# x)
 933 atanFloat   (F# x) = F# (atanFloat# x)
 934 sinhFloat   (F# x) = F# (sinhFloat# x)
 935 coshFloat   (F# x) = F# (coshFloat# x)
 936 tanhFloat   (F# x) = F# (tanhFloat# x)
 937
 938 powerFloat  (F# x) (F# y) = F# (powerFloat# x y)
 939
 940 -- definitions of the boxed PrimOps; these will be
 941 -- used in the case of partial applications, etc.
 942
 943 plusDouble   (D# x) (D# y) = D# (x +## y)
 944 minusDouble  (D# x) (D# y) = D# (x -## y)
 945 timesDouble  (D# x) (D# y) = D# (x *## y)
 946 divideDouble (D# x) (D# y) = D# (x /## y)
 947 negateDouble (D# x)        = D# (negateDouble# x)
 948
 949 gtDouble    (D# x) (D# y) = x >## y
 950 geDouble    (D# x) (D# y) = x >=## y
 951 eqDouble    (D# x) (D# y) = x ==## y
 952 neDouble    (D# x) (D# y) = x /=## y
 953 ltDouble    (D# x) (D# y) = x <## y
 954 leDouble    (D# x) (D# y) = x <=## y
 955
 956 double2Int   (D# x) = I# (double2Int#   x)
 957 int2Double   (I# x) = D# (int2Double#   x)
 958 double2Float (D# x) = F# (double2Float# x)
 959 float2Double (F# x) = D# (float2Double# x)
 960
 961 expDouble    (D# x) = D# (expDouble# x)
 962 logDouble    (D# x) = D# (logDouble# x)
 963 sqrtDouble   (D# x) = D# (sqrtDouble# x)
 964 sinDouble    (D# x) = D# (sinDouble# x)
 965 cosDouble    (D# x) = D# (cosDouble# x)
 966 tanDouble    (D# x) = D# (tanDouble# x)
 967 asinDouble   (D# x) = D# (asinDouble# x)
 968 acosDouble   (D# x) = D# (acosDouble# x)
 969 atanDouble   (D# x) = D# (atanDouble# x)
 970 sinhDouble   (D# x) = D# (sinhDouble# x)
 971 coshDouble   (D# x) = D# (coshDouble# x)
 972 tanhDouble   (D# x) = D# (tanhDouble# x)
 973
 974 powerDouble  (D# x) (D# y) = D# (x **## y)
 975 \end{code}