{-# 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"