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