Float.hs

{-# OPTIONS_LHC -N -fffi -fm4 #-}

module Lhc.Float(
    Float(..),
    Double(..),
    floatToDouble,
    doubleToFloat,
    Floating(..),
    RealFrac(..),
    RealFloat(..),
    rationalToDouble
    )
    where

import Lhc.Basics
import Lhc.Int
import Lhc.IO(error)
import Lhc.Num
import Lhc.Order
import Lhc.Types
import Lhc.Enum

infixr 8  **

data Float = Float Float32_
data Double = Double Float64_


foreign import primitive "F2F" floatToDouble :: Float -> Double
foreign import primitive "F2F" doubleToFloat :: Double -> Float

 -- floating point stuff

class  (Fractional a) => Floating a  where
    pi                  :: a
    exp, log, sqrt      :: a -> a
    (**), logBase       :: a -> a -> a
    sin, cos, tan       :: a -> a
    asin, acos, atan    :: a -> a
    sinh, cosh, tanh    :: a -> a
    asinh, acosh, atanh :: a -> a

        -- Minimal complete definition:
        --      pi, exp, log, sin, cos, sinh, cosh
        --      asin, acos, atan
        --      asinh, acosh, atanh
    x ** y           =  exp (log x * y)
    logBase x y      =  log y / log x
    sqrt x           =  x ** (1 / 2) -- 0.5        -- TODO Doubles
    tan  x           =  sin  x / cos  x
    tanh x           =  sinh x / cosh x



-- TODO Doubles
class  (Real a, Fractional a) => RealFrac a  where
    properFraction   :: (Integral b) => a -> (b,a)
    truncate, round  :: (Integral b) => a -> b
    ceiling, floor   :: (Integral b) => a -> b



        -- Minimal complete definition:
        --      properFraction
    truncate x       =  m  where (m,_) = properFraction x

    round x          =  let (n,r) = properFraction x
                            m     = if r < 0 then n - 1 else n + 1
                          in case signum (abs r - (1 / 2)) of
                                -1 -> n
                                0  -> if n `rem` 2 == 0 then n else m
                                1  -> m

    ceiling x        =  if r > 0 then n + 1 else n
                        where (n,r) = properFraction x

    floor x          =  if r < 0 then n - 1 else n
                        where (n,r) = properFraction x

        -- Minimal complete definition:
        --      properFraction

    properFractionf   :: a -> (a,a)
    truncatef, roundf :: a -> a
    ceilingf, floorf  :: a -> a

    truncatef x       =  m  where (m,_) = properFractionf x
    roundf x          =  fromInteger (round x)
    ceilingf x        =  if r > 0 then n + 1 else n
                        where (n,r) = properFractionf x
    floorf x          =  if r < 0 then n - 1 else n
                        where (n,r) = properFractionf x


-- TODO Doubles
class  (RealFrac a, Floating a) => RealFloat a  where
    floatRadix       :: a -> Integer
    floatDigits      :: a -> Int
    floatRange       :: a -> (Int,Int)
    decodeFloat      :: a -> (Integer,Int)
    encodeFloat      :: Integer -> Int -> a
    exponent         :: a -> Int
    significand      :: a -> a
    scaleFloat       :: Int -> a -> a
    isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
                     :: a -> Bool
    atan2            :: a -> a -> a

        -- Minimal complete definition:
        --      All except exponent, significand,
        --                 scaleFloat, atan2
    exponent x       =  if m == 0 then 0 else n + floatDigits x
                        where (m,n) = decodeFloat x

    significand x    =  encodeFloat m (- floatDigits x)
                        where (m,_) = decodeFloat x

    scaleFloat k x   =  encodeFloat m (n+k)
                        where (m,n) = decodeFloat x

    atan2 y x
      | x>0           =  atan (y/x)
      | x==0 && y>0   =  pi/2
      | x<0  && y>0   =  pi + atan (y/x)
      |(x<=0 && y<0)  ||
       (x<0 && isNegativeZero y) ||
       (isNegativeZero x && isNegativeZero y)
                      = -atan2 (-y) x
      | y==0 && (x<0 || isNegativeZero x)
                      =  pi    -- must be after the previous test on zero y
      | x==0 && y==0  =  y     -- must be after the other double zero tests
      | otherwise     =  x + y -- x or y is a NaN, return a NaN (via +)

    decodeFloatf     :: a -> (a,Int)
    decodeFloatf x    = case decodeFloat x of
        (v,exp) -> (fromInteger v,exp)

    encodeFloatf     :: a -> Int -> a
    encodeFloatf a i = scaleFloat i a



rationalToDouble :: Rational -> Double
rationalToDouble (x:%y) = fromInteger x `divideDouble` fromInteger y

foreign import primitive "FDiv" divideDouble ::  Double -> Double -> Double
foreign import primitive "box" boxBool :: Bool__ -> Bool


m4_define(NUMINSTANCE,
instance Num $1 where
    $1 x * $1 y = $1 (times$1 x y)
    $1 x + $1 y = $1 (plus$1 x y)
    $1 x - $1 y = $1 (minus$1 x y)
    abs ($1 x) = $1 (abs$1 x)
    negate ($1 x) = $1 (neg$1 x)
    fromInt x = fromInt$1 x
    fromInteger x = fromInteger$1 x
    signum x = case compare x 0 of
        EQ -> 0
        GT -> 1
        LT -> -1

foreign import primitive "FMul" times$1 :: $2 -> $2 -> $2
foreign import primitive "FAdd" plus$1  :: $2 -> $2 -> $2
foreign import primitive "FSub" minus$1 :: $2 -> $2 -> $2

foreign import primitive "FAbs" abs$1 :: $2 -> $2
foreign import primitive "FNeg" neg$1 :: $2 -> $2

foreign import primitive "I2F"  fromInt$1 :: Int -> $1
foreign import primitive "I2F"  fromInteger$1 :: Integer -> $1

foreign import primitive "F2I"  toInt$1 :: $1 -> Int

instance Enum $1 where
    succ = increment$1
    pred = decrement$1
    toEnum x = fromInt$1 x
    fromEnum x = toInt$1 x

    enumFrom x  | x `seq` True     =  x:enumFrom (increment$1 x)
    enumFromTo x y = f x where
        f x | x > y = []
            | otherwise = x:f (increment$1 x)
    enumFromThen x y | x `seq` y `seq` True = f x where
        z = y `fminus$1` x
        f x = x:f (x `fplus$1` z)
    enumFromThenTo x y z | y >= x = f x where
        inc = y `fminus$1` x
        f x | x <= z = x:f (x `fplus$1` inc)
            | otherwise = []
    enumFromThenTo x y z  = f x where
        inc = y `fminus$1` x
        f x | x >= z = x:f (x `fplus$1` inc)
            | otherwise = []

foreign import primitive "fincrement" increment$1 :: $1 -> $1
foreign import primitive "fdecrement" decrement$1 :: $1 -> $1
foreign import primitive "FAdd" fplus$1  :: $1 -> $1 -> $1
foreign import primitive "FSub" fminus$1 :: $1 -> $1 -> $1

instance Eq $1 where
    $1 x == $1 y = boxBool (x `eq$2` y)
    $1 x /= $1 y = boxBool (x `neq$2` y)

instance Ord $1 where
    $1 x < $1 y = boxBool (flt$2 x y)
    $1 x > $1 y = boxBool (fgt$2 x y)
    $1 x <= $1 y = boxBool (flte$2 x y)
    $1 x >= $1 y = boxBool (fgte$2 x y)



foreign import primitive "FEq" eq$2   :: $2 -> $2 -> Bool__
foreign import primitive "FNEq" neq$2 :: $2 -> $2 -> Bool__
foreign import primitive "FLt" flt$2  :: $2 -> $2 -> Bool__
foreign import primitive "FLte" flte$2 :: $2 -> $2 -> Bool__
foreign import primitive "FGt" fgt$2 :: $2 -> $2 -> Bool__
foreign import primitive "FGte" fgte$2 :: $2 -> $2 -> Bool__

)



NUMINSTANCE(Float,Float32_)
NUMINSTANCE(Double,Float64_)