{-# LANGUAGE OverloadedStrings #-}

module Funcons.Operations.Floats where

import Funcons.Operations.Internal hiding (isInt)

library :: HasValues t => Library t
library :: Library t
library = [(OP, ValueOp t)] -> Library t
forall t. [(OP, ValueOp t)] -> Library t
libFromList [
  ]

ieee_float_truncate_ :: HasValues t => [OpExpr t] -> OpExpr t
ieee_float_truncate_ :: [OpExpr t] -> OpExpr t
ieee_float_truncate_ = BinaryExpr t -> [OpExpr t] -> OpExpr t
forall t. BinaryExpr t -> [OpExpr t] -> OpExpr t
binaryOp BinaryExpr t
forall t. HasValues t => OpExpr t -> OpExpr t -> OpExpr t
ieee_float_truncate 
ieee_float_truncate :: HasValues t => OpExpr t -> OpExpr t -> OpExpr t
ieee_float_truncate :: OpExpr t -> OpExpr t -> OpExpr t
ieee_float_truncate = OP -> BinaryVOp t -> OpExpr t -> OpExpr t -> OpExpr t
forall t.
HasValues t =>
OP -> BinaryVOp t -> OpExpr t -> OpExpr t -> OpExpr t
vBinaryOp OP
"ieee-float-truncate" BinaryVOp t
forall t t t. HasValues t => Values t -> Values t -> Result t
op
  where op :: Values t -> Values t -> Result t
op (IEEE_Float_64 Double
f) (ADTVal Name
"binary64" [t]
_) = t -> Result t
forall t. t -> Result t
Normal (t -> Result t) -> t -> Result t
forall a b. (a -> b) -> a -> b
$ Values t -> t
forall t. HasValues t => Values t -> t
inject (Values t -> t) -> Values t -> t
forall a b. (a -> b) -> a -> b
$ Integer -> Values t
forall t. Integer -> Values t
Int (Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
truncate Double
f)
        op Values t
_ Values t
_ = OP -> Result t
forall t. OP -> Result t
SortErr OP
"ieee-float-truncate not applied to a float of the right format"

ieee_float_add_ :: HasValues t => [OpExpr t] -> OpExpr t
ieee_float_add_ :: [OpExpr t] -> OpExpr t
ieee_float_add_ = OP -> NaryVOp t -> [OpExpr t] -> OpExpr t
forall t. HasValues t => OP -> NaryVOp t -> [OpExpr t] -> OpExpr t
vNaryOp OP
"ieee-float-add" NaryVOp t
forall t. HasValues t => [Values t] -> Result t
op
  where op :: [Values t] -> Result t
op (Values t
format:[Values t]
vs) = OP
-> (Double -> Double -> Double)
-> Double
-> Values t
-> [Values t]
-> Result t
forall t.
HasValues t =>
OP
-> (Double -> Double -> Double)
-> Double
-> Values t
-> [Values t]
-> Result t
ieee_float_op OP
"ieee-float-add" Double -> Double -> Double
forall a. Num a => a -> a -> a
(+) Double
0 Values t
format [Values t]
vs
        op [] = OP -> Result t
forall t. OP -> Result t
SortErr OP
"ieee-float-add not applied to a format and a list of floats"

{-
ieee_float_multiply_ = ieee_float_multiply 
ieee_float_multiply = applyFuncon "ieee-float-multiply"
ieee_float_multiply_op (format:vs) = ieee_float_op "ieee_float-multiply" ieee_float_multiply (*) 1 format vs
ieee_float_multiply_op [] = sortErr (ieee_float_multiply [listval []]) "ieee-float-multiply not applied to a format and a list of floats"

ieee_float_divide = applyFuncon "ieee-float-divide"
ieee_float_divide_op format vx vy
    | isIEEEFormat format vx && isIEEEFormat format vy =
        let f1 = doubleFromIEEEFormat format vx
            f2 = doubleFromIEEEFormat format vy
        in rewriteTo $ FValue $ IEEE_Float_64 $ (f1 / f2)
ieee_float_divide_op ft vx vy = sortErr (ieee_float_divide [FValue ft,FValue vx, FValue vy])
                         "ieee-float-divide not applied to a format and ieee-floats"

ieee_float_remainder = applyFuncon "ieee-float-remainder"
ieee_float_remainder_op format vx vy
    | isIEEEFormat format vx =
        let f1 = doubleFromIEEEFormat format vx
            f2 = doubleFromIEEEFormat format vy
        in rewriteTo $ FValue $ IEEE_Float_64 $ (f1 `mod'` f2)
ieee_float_remainder_op ft vx vy = sortErr (ieee_float_remainder [FValue ft,FValue vx, FValue vy])
                         "ieee-float-remainder not applied to a format and ieee-floats"

ieee_float_negate = applyFuncon "ieee-float-negate"
ieee_float_negate_op format vx
    | isIEEEFormat format vx = let f1 = doubleFromIEEEFormat format vx
                               in rewriteTo $ FValue $ IEEE_Float_64 (-f1)
    | otherwise = sortErr (ieee_float_negate [FValue format,FValue vx]) "ieee-float-negate not applied to ieee-float"

ieee_float_subtract = applyFuncon "ieee-float-subtract"
ieee_float_subtract_op format vx vy
    | isIEEEFormat format vx && isIEEEFormat format vy =
        let f1 = doubleFromIEEEFormat format vx
            f2 = doubleFromIEEEFormat format vy
        in rewriteTo $ FValue $ IEEE_Float_64 $ (f1 - f2)
ieee_float_subtract_op ft vx vy = sortErr (ieee_float_subtract [FValue ft, FValue vx, FValue vy])
                         "ieee-float-subtract not applied to a format and ieee-floats"

ieee_float_float_power = applyFuncon "ieee-float-float-power"
ieee_float_power_op format vx vy
    | isIEEEFormat format vx && isIEEEFormat format vy =
        let f1 = doubleFromIEEEFormat format vx
            f2 = doubleFromIEEEFormat format vy
        in rewriteTo $ FValue $ IEEE_Float_64 $ (f1 ** f2)
ieee_float_power_op ft vx vy = sortErr (ieee_float_float_power [FValue ft, FValue vx, FValue vy])
                         "ieee-float-power not applied to a format and ieee-floats"

ieee_float_is_less = applyFuncon "ieee-float-is-less"
ieee_float_is_less_op format vx vy
    | isIEEEFormat format vx && isIEEEFormat format vy =
        let f1 = doubleFromIEEEFormat format vx
            f2 = doubleFromIEEEFormat format vy
        in rewriteTo $ FValue $ tobool (f1 < f2)
ieee_float_is_less_op ft vx vy = sortErr (ieee_float_is_less [FValue ft, FValue vx, FValue vy])
                         "ieee-float-is-less not applied to a format and ieee-floats"

ieee_float_is_greater = applyFuncon "ieee-float-is-greater"
ieee_float_is_greater_op format vx vy
    | isIEEEFormat format vx && isIEEEFormat format vy =
        let f1 = doubleFromIEEEFormat format vx
            f2 = doubleFromIEEEFormat format vy
        in rewriteTo $ FValue $ tobool (f1 > f2)
ieee_float_is_greater_op ft vx vy = sortErr (ieee_float_is_greater [FValue ft, FValue vx, FValue vy])
                         "ieee-float-is-greater not applied to a format and ieee-floats"

ieee_float_is_less_or_equal = applyFuncon "ieee-float-is-less-or-equal"
ieee_float_is_less_or_equal_op format vx vy
    | isIEEEFormat format vx && isIEEEFormat format vy =
        let f1 = doubleFromIEEEFormat format vx
            f2 = doubleFromIEEEFormat format vy
        in rewriteTo $ FValue $ tobool (f1 <= f2)
ieee_float_is_less_or_equal_op ft vx vy = sortErr (ieee_float_is_less_or_equal [FValue ft,FValue vx, FValue vy])
                         "ieee-float-is-less-or-equal not applied to a format and ieee-floats"

ieee_float_is_greater_or_equal = applyFuncon "ieee-float-is-greater-or-equal"
ieee_float_is_greater_or_equal_op format vx vy
    | isIEEEFormat format vx && isIEEEFormat format vy =
        let f1 = doubleFromIEEEFormat format vx
            f2 = doubleFromIEEEFormat format vy
        in rewriteTo $ FValue $ tobool (f1 >= f2)
ieee_float_is_greater_or_equal_op ft vx vy = sortErr (ieee_float_is_greater_or_equal [FValue ft,FValue vx, FValue vy])
                         "ieee-float-is-greater-or-equal not applied to a format and ieee-floats"


signed_bits_maximum = applyFuncon "signed-bits-maximum"
stepSigned_Bits_Maximum [vn] | Nat n <- upcastNaturals vn
        = rewriteTo $ integer_subtract_ [integer_power_ [int_ 2, integer_subtract_ [int_ $ fromInteger n, int_ 1]],int_ 1]
stepSigned_Bits_Maximum vs = sortErr (signed_bits_maximum (fvalues vs)) "sort check"

signed_bits_minimum = applyFuncon "signed-bits-minimum"
stepSigned_Bits_Minimum [vn] | Nat n <- upcastNaturals vn
        = rewriteTo $ applyFuncon "integer-negate" [signed_bits_maximum [FValue vn]]
stepSigned_Bits_Minimum vs = sortErr (signed_bits_maximum (fvalues vs)) "sort check"

    -- TODO binary64 assumption (perhaps use config files)
ieee_float_acos = applyFuncon "ieee-float-acos"
stepIEEE_Float_Acos [f,vx] = let f1 = doubleFromIEEEFormat f vx
                                     in rewriteTo $ FValue $ IEEE_Float_64 (acos f1)
stepIEEE_Float_Acos vn = sortErr (ieee_float_acos (fvalues vn)) "sort check"

ieee_float_asin = applyFuncon "ieee-float-asin"
stepIEEE_Float_Asin [f,vx] = let f1 = doubleFromIEEEFormat f vx
                                     in rewriteTo $ FValue $ IEEE_Float_64 (asin f1)
stepIEEE_Float_Asin vn = sortErr (ieee_float_asin (fvalues vn)) "sort check"

ieee_float_atan = applyFuncon "ieee-float-atan"
stepIEEE_Float_Atan [f,vx] = let f1 = doubleFromIEEEFormat f vx
                                     in rewriteTo $ FValue $ IEEE_Float_64 (atan f1)
stepIEEE_Float_Atan vn = sortErr (ieee_float_atan (fvalues vn)) "sort check"

ieee_float_atan2 = applyFuncon "ieee-float-atan2"
stepIEEE_Float_Atan2 [f,vx,vy] = let f1 = doubleFromIEEEFormat f vx
                                     f2 = doubleFromIEEEFormat f vy
                                 in rewriteTo $ FValue $ IEEE_Float_64 (atan2 f1 f2)
stepIEEE_Float_Atan2 vn = sortErr (ieee_float_atan2 (fvalues vn)) "sort check"

ieee_float_cos = applyFuncon "ieee-float-cos"
stepIEEE_Float_Cos [f,vx] = let f1 = doubleFromIEEEFormat f vx
                                     in rewriteTo $ FValue $ IEEE_Float_64 (cos f1)
stepIEEE_Float_Cos vn = sortErr (ieee_float_cos (fvalues vn)) "sort check"

ieee_float_cosh = applyFuncon "ieee-float-cosh"
stepIEEE_Float_Cosh [f,vx] = let f1 = doubleFromIEEEFormat f vx
                                     in rewriteTo $ FValue $ IEEE_Float_64 (cosh f1)
stepIEEE_Float_Cosh vn = sortErr (ieee_float_cosh (fvalues vn)) "sort check"

ieee_float_exp = applyFuncon "ieee-float-exp"
stepIEEE_Float_Exp [f,vx] = let f1 = doubleFromIEEEFormat f vx
                                     in rewriteTo $ FValue $ IEEE_Float_64 (exp f1)
stepIEEE_Float_Exp vn = sortErr (ieee_float_exp (fvalues vn)) "sort check"

ieee_float_log = applyFuncon "ieee-float-log"
stepIEEE_Float_Log [f,vx] = let f1 = doubleFromIEEEFormat f vx
                                     in rewriteTo $ FValue $ IEEE_Float_64 (log f1)
stepIEEE_Float_Log vn = sortErr (ieee_float_log (fvalues vn)) "sort check"

ieee_float_log10 = applyFuncon "ieee-float-log10"
stepIEEE_Float_Log10 [f,vx] = let f1 = doubleFromIEEEFormat f vx
                                     in rewriteTo $ FValue $ IEEE_Float_64 (logBase 10 f1)
stepIEEE_Float_Log10 vn = sortErr (ieee_float_log10 (fvalues vn)) "sort check"

ieee_float_sin = applyFuncon "ieee-float-sin"
stepIEEE_Float_Sin [f,vx] = let f1 = doubleFromIEEEFormat f vx
                                     in rewriteTo $ FValue $ IEEE_Float_64 (sin f1)
stepIEEE_Float_Sin vn = sortErr (ieee_float_sin (fvalues vn)) "sort check"

ieee_float_sinh = applyFuncon "ieee-float-sinh"
stepIEEE_Float_Sinh [f,vx] = let f1 = doubleFromIEEEFormat f vx
                                     in rewriteTo $ FValue $ IEEE_Float_64 (sinh f1)
stepIEEE_Float_Sinh vn = sortErr (ieee_float_sinh (fvalues vn)) "sort check"

ieee_float_sqrt = applyFuncon "ieee-float-sqrt"
stepIEEE_Float_Sqrt [f,vx] = let f1 = doubleFromIEEEFormat f vx
                                     in rewriteTo $ FValue $ IEEE_Float_64 (sqrt f1)
stepIEEE_Float_Sqrt vn = sortErr (ieee_float_sqrt (fvalues vn)) "sort check"

ieee_float_tan = applyFuncon "ieee-float-tan"
stepIEEE_Float_Tan [f,vx] = let f1 = doubleFromIEEEFormat f vx
                                     in rewriteTo $ FValue $ IEEE_Float_64 (tan f1)
stepIEEE_Float_Tan vn = sortErr (ieee_float_tan (fvalues vn)) "sort check"

ieee_float_tanh = applyFuncon "ieee-float-tanh"
stepIEEE_Float_Tanh [f,vx] = let f1 = doubleFromIEEEFormat f vx
                                     in rewriteTo $ FValue $ IEEE_Float_64 (tanh f1)
stepIEEE_Float_Tanh vn = sortErr (ieee_float_tanh (fvalues vn)) "sort check"

ieee_float_ceiling = applyFuncon "ieee-float-ceiling"
stepIEEE_Float_Ceiling [f,vx] = let f1 = doubleFromIEEEFormat f vx
                                     in rewriteTo $ int_ (ceiling f1)
stepIEEE_Float_Ceiling vn = sortErr (ieee_float_ceiling (fvalues vn)) "sort check"

ieee_float_floor = applyFuncon "ieee-float-floor"
stepIEEE_Float_Floor [f,vx] = let f1 = doubleFromIEEEFormat f vx
                                     in rewriteTo $ int_ (floor f1)
stepIEEE_Float_Floor vn = sortErr (ieee_float_floor (fvalues vn)) "sort check"

ieee_float_absolute_value = applyFuncon "ieee-float-absolute-value"
stepIEEE_Float_Absolute_Value [f,vx] = let f1 = doubleFromIEEEFormat f vx
                                     in rewriteTo $ FValue $ IEEE_Float_64 (Prelude.abs f1)
stepIEEE_Float_Absolute_Value vn = sortErr (ieee_float_absolute_value (fvalues vn)) "sort check"

stepIEEE_Float_Remainder [f,f1,f2] = ieee_float_remainder_op f f1 f2
stepIEEE_Float_Remainder vn = sortErr (ieee_float_remainder (fvalues vn)) "sort check"

stepIEEE_Float_Is_Less [f,f1,f2] = ieee_float_is_less_op f f1 f2
stepIEEE_Float_Is_Less vn = sortErr (ieee_float_is_less (fvalues vn)) "sort check"
stepIEEE_Float_Is_Greater [f,f1,f2] = ieee_float_is_greater_op f f1 f2
stepIEEE_Float_Is_Greater vn = sortErr (ieee_float_is_greater (fvalues vn)) "sort check"
stepIEEE_Float_Is_Less_Or_Equal [f,f1,f2] = ieee_float_is_less_or_equal_op f f1 f2
stepIEEE_Float_Is_Less_Or_Equal vn = sortErr (ieee_float_is_less_or_equal (fvalues vn)) "sort check"
stepIEEE_Float_Is_Greater_Or_Equal [f,f1,f2] = ieee_float_is_greater_or_equal_op f f1 f2
stepIEEE_Float_Is_Greater_Or_Equal vn = sortErr (ieee_float_is_greater_or_equal (fvalues vn)) "sort check"
-}

ieee_float_op :: HasValues t => String -> (Double -> Double -> Double) 
                -> Double -> Values t -> [Values t] -> Result t 
ieee_float_op :: OP
-> (Double -> Double -> Double)
-> Double
-> Values t
-> [Values t]
-> Result t
ieee_float_op OP
str Double -> Double -> Double
f Double
b Values t
format [Values t]
vs
    | (Values t -> Bool) -> [Values t] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Values t -> Values t -> Bool
forall t. Values t -> Values t -> Bool
isIEEEFormat Values t
format) [Values t]
vs = t -> Result t
forall t. t -> Result t
Normal (t -> Result t) -> t -> Result t
forall a b. (a -> b) -> a -> b
$ Values t -> t
forall t. HasValues t => Values t -> t
inject (Values t -> t) -> Values t -> t
forall a b. (a -> b) -> a -> b
$ Double -> Values t
forall t. Double -> Values t
IEEE_Float_64
        (Double -> Values t) -> Double -> Values t
forall a b. (a -> b) -> a -> b
$ (Double -> Double -> Double) -> Double -> [Double] -> Double
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Double -> Double -> Double
f Double
b ([Double] -> Double) -> [Double] -> Double
forall a b. (a -> b) -> a -> b
$ (Values t -> Double) -> [Values t] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (Values t -> Values t -> Double
forall t. Values t -> Values t -> Double
doubleFromIEEEFormat Values t
format) [Values t]
vs
    | Bool
otherwise = OP -> Result t
forall t. OP -> Result t
SortErr OP
err
    where   err :: OP
err     = OP
str OP -> OP -> OP
forall a. [a] -> [a] -> [a]
++ OP
" not applied to ieee_floats"


isIEEEFormat :: Values t -> Values t -> Bool
isIEEEFormat :: Values t -> Values t -> Bool
isIEEEFormat (ADTVal Name
"binary32" [t]
_) (IEEE_Float_32 Float
_) = Bool
True
isIEEEFormat (ADTVal Name
"binary64" [t]
_) (IEEE_Float_64 Double
_) = Bool
True
isIEEEFormat Values t
_ Values t
_ = Bool
False

doubleFromIEEEFormat :: Values t -> Values t -> Double
doubleFromIEEEFormat :: Values t -> Values t -> Double
doubleFromIEEEFormat (ADTVal Name
"binary64" [t]
_) (IEEE_Float_64 Double
d) = Double
d
doubleFromIEEEFormat Values t
_ Values t
_ = OP -> Double
forall a. HasCallStack => OP -> a
error OP
"fromIEEEFormat"