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