{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# Language TypeSynonymInstances, FlexibleInstances, CPP #-}
-- | Numeric instances
module Csound.Dynamic.Build.Numeric(
    ceilE, floorE, roundE, intE, fracE
) where

#if !MIN_VERSION_base(4,11,0)
import Data.Monoid (Monoid(..))
#endif

import Csound.Dynamic.Types.Exp
import Csound.Dynamic.Build(toExp, prim, opr1, numExp1)

---------------------------------------------
-- monoid

#if MIN_VERSION_base(4,11,0)
instance Semigroup E where
  E
x <> :: E -> E -> E
<> E
y          = E
x E -> E -> E
forall a. Num a => a -> a -> a
+ E
y

instance Monoid E where
    mempty :: E
mempty  = E
0

#else

instance Monoid E where
    mempty  = 0
    mappend = (+)

#endif



--------------------------------------------
-- numeric instances

instance Num E where
    + :: E -> E -> E
(+) E
a E
b
        | E -> Bool
isZero E
a = E
b
        | E -> Bool
isZero E
b = E
a
        | Bool
otherwise = (Double -> Double -> Double) -> NumOp -> E -> E -> E
biOpt Double -> Double -> Double
forall a. Num a => a -> a -> a
(+) NumOp
Add E
a E
b

    * :: E -> E -> E
(*) E
a E
b
        | E -> Bool
isZero E
a Bool -> Bool -> Bool
|| E -> Bool
isZero E
b = Double -> E
fromDouble Double
0
        | Bool
otherwise = (Double -> Double -> Double) -> NumOp -> E -> E -> E
biOpt Double -> Double -> Double
forall a. Num a => a -> a -> a
(*) NumOp
Mul E
a E
b

    (-) E
a E
b
        | E -> Bool
isZero E
a = E -> E
forall a. Num a => a -> a
negate E
b
        | E -> Bool
isZero E
b = E
a
        | Bool
otherwise = (Double -> Double -> Double) -> NumOp -> E -> E -> E
biOpt (-) NumOp
Sub E
a E
b

    negate :: E -> E
negate = (Double -> Double) -> (E -> E) -> E -> E
unOpt Double -> Double
forall a. Num a => a -> a
negate (NumOp -> E -> E
numExp1 NumOp
Neg)

    fromInteger :: Integer -> E
fromInteger = Double -> E
fromDouble (Double -> E) -> (Integer -> Double) -> Integer -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Double
forall a. Num a => Integer -> a
fromInteger
    abs :: E -> E
abs = (Double -> Double) -> (E -> E) -> E -> E
unOpt Double -> Double
forall a. Num a => a -> a
abs (Name -> E -> E
opr1 Name
"abs")
    signum :: E -> E
signum = E -> E
forall a. HasCallStack => a
undefined

instance Fractional E where
    / :: E -> E -> E
(/) E
a E
b
        | E -> Bool
isZero E
a = Double -> E
fromDouble Double
0
        | E -> Bool
isZero E
b = Name -> E
forall a. HasCallStack => Name -> a
error Name
"csound (/): division by zero"
        | Bool
otherwise = (Double -> Double -> Double) -> NumOp -> E -> E -> E
biOpt Double -> Double -> Double
forall a. Fractional a => a -> a -> a
(/) NumOp
Div E
a E
b

    fromRational :: Rational -> E
fromRational = Double -> E
fromDouble (Double -> E) -> (Rational -> Double) -> Rational -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Double
forall a. Fractional a => Rational -> a
fromRational

instance Floating E where
    pi :: E
pi = Double -> E
fromDouble Double
forall a. Floating a => a
pi
    exp :: E -> E
exp = (Double -> Double) -> (E -> E) -> E -> E
unOpt Double -> Double
forall a. Floating a => a -> a
exp (Name -> E -> E
opr1 Name
"exp")
    sqrt :: E -> E
sqrt = (Double -> Double) -> (E -> E) -> E -> E
unOpt Double -> Double
forall a. Floating a => a -> a
sqrt (Name -> E -> E
opr1 Name
"sqrt")
    log :: E -> E
log = (Double -> Double) -> (E -> E) -> E -> E
unOpt Double -> Double
forall a. Floating a => a -> a
log (Name -> E -> E
opr1 Name
"log")
    logBase :: E -> E -> E
logBase E
n E
a = case E
n of
        E
2 -> (Double -> Double) -> (E -> E) -> E -> E
unOpt ((Double -> Double -> Double) -> Double -> Double -> Double
forall a b c. (a -> b -> c) -> b -> a -> c
flip Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase Double
2) (Name -> E -> E
opr1 Name
"logbtwo") E
a
        E
10 -> (Double -> Double) -> (E -> E) -> E -> E
unOpt ((Double -> Double -> Double) -> Double -> Double -> Double
forall a b c. (a -> b -> c) -> b -> a -> c
flip Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase Double
10) (Name -> E -> E
opr1 Name
"log10") E
a
        E
b -> E -> E
forall a. Floating a => a -> a
log E
a E -> E -> E
forall a. Fractional a => a -> a -> a
/ E -> E
forall a. Floating a => a -> a
log E
b
    ** :: E -> E -> E
(**) = (Double -> Double -> Double) -> NumOp -> E -> E -> E
biOpt Double -> Double -> Double
forall a. Floating a => a -> a -> a
(**) NumOp
Pow
    sin :: E -> E
sin = (Double -> Double) -> (E -> E) -> E -> E
unOpt Double -> Double
forall a. Floating a => a -> a
sin (Name -> E -> E
opr1 Name
"sin")
    tan :: E -> E
tan = (Double -> Double) -> (E -> E) -> E -> E
unOpt Double -> Double
forall a. Floating a => a -> a
tan (Name -> E -> E
opr1 Name
"tan")
    cos :: E -> E
cos = (Double -> Double) -> (E -> E) -> E -> E
unOpt Double -> Double
forall a. Floating a => a -> a
cos (Name -> E -> E
opr1 Name
"cos")
    asin :: E -> E
asin = (Double -> Double) -> (E -> E) -> E -> E
unOpt Double -> Double
forall a. Floating a => a -> a
asin (Name -> E -> E
opr1 Name
"sininv")
    atan :: E -> E
atan = (Double -> Double) -> (E -> E) -> E -> E
unOpt Double -> Double
forall a. Floating a => a -> a
atan (Name -> E -> E
opr1 Name
"taninv")
    acos :: E -> E
acos = (Double -> Double) -> (E -> E) -> E -> E
unOpt Double -> Double
forall a. Floating a => a -> a
acos (Name -> E -> E
opr1 Name
"cosinv")
    sinh :: E -> E
sinh = (Double -> Double) -> (E -> E) -> E -> E
unOpt Double -> Double
forall a. Floating a => a -> a
sinh (Name -> E -> E
opr1 Name
"sinh")
    tanh :: E -> E
tanh = (Double -> Double) -> (E -> E) -> E -> E
unOpt Double -> Double
forall a. Floating a => a -> a
tanh (Name -> E -> E
opr1 Name
"tanh")
    cosh :: E -> E
cosh = (Double -> Double) -> (E -> E) -> E -> E
unOpt Double -> Double
forall a. Floating a => a -> a
cosh (Name -> E -> E
opr1 Name
"cosh")
    asinh :: E -> E
asinh E
a = E -> E
forall a. Floating a => a -> a
log (E -> E) -> E -> E
forall a b. (a -> b) -> a -> b
$ E
a E -> E -> E
forall a. Num a => a -> a -> a
+ E -> E
forall a. Floating a => a -> a
sqrt (E
a E -> E -> E
forall a. Num a => a -> a -> a
* E
a E -> E -> E
forall a. Num a => a -> a -> a
+ E
1)
    acosh :: E -> E
acosh E
a = E -> E
forall a. Floating a => a -> a
log (E -> E) -> E -> E
forall a b. (a -> b) -> a -> b
$ E
a E -> E -> E
forall a. Num a => a -> a -> a
+ E -> E
forall a. Floating a => a -> a
sqrt (E
a E -> E -> E
forall a. Num a => a -> a -> a
+ E
1) E -> E -> E
forall a. Num a => a -> a -> a
* E -> E
forall a. Floating a => a -> a
sqrt (E
a E -> E -> E
forall a. Num a => a -> a -> a
- E
1)
    atanh :: E -> E
atanh E
a = E
0.5 E -> E -> E
forall a. Num a => a -> a -> a
* E -> E
forall a. Floating a => a -> a
log ((E
1 E -> E -> E
forall a. Num a => a -> a -> a
+ E
a) E -> E -> E
forall a. Fractional a => a -> a -> a
/ (E
1 E -> E -> E
forall a. Num a => a -> a -> a
- E
a))

enumError :: String -> a
enumError :: Name -> a
enumError Name
name = Name -> a
forall a. HasCallStack => Name -> a
error (Name -> a) -> Name -> a
forall a b. (a -> b) -> a -> b
$ Name
name Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++ Name
" -- is defined only for literals"

instance Enum E where
    succ :: E -> E
succ = (E -> E -> E
forall a. Num a => a -> a -> a
+E
1)
    pred :: E -> E
pred = \E
x -> E
x E -> E -> E
forall a. Num a => a -> a -> a
- E
1
    toEnum :: Int -> E
toEnum = Double -> E
fromDouble (Double -> E) -> (Int -> Double) -> Int -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    fromEnum :: E -> Int
fromEnum = Name -> E -> Int
forall a. HasCallStack => Name -> a
error Name
"fromEnum is not defined for Csound values"
    enumFrom :: E -> [E]
enumFrom E
a = E
a E -> [E] -> [E]
forall a. a -> [a] -> [a]
: E -> [E]
forall a. Enum a => a -> [a]
enumFrom (E
aE -> E -> E
forall a. Num a => a -> a -> a
+E
1)
    enumFromThen :: E -> E -> [E]
enumFromThen E
a E
b = E
a E -> [E] -> [E]
forall a. a -> [a] -> [a]
: E -> E -> [E]
forall a. Enum a => a -> a -> [a]
enumFromThen (E
a E -> E -> E
forall a. Num a => a -> a -> a
+ E
b) E
b

    enumFromTo :: E -> E -> [E]
enumFromTo E
a E
b = case (E -> Either Double E
toNumOpt E
a, E -> Either Double E
toNumOpt E
b) of
        (Left Double
x, Left Double
y) -> (Double -> E) -> [Double] -> [E]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> E
fromDouble ([Double] -> [E]) -> [Double] -> [E]
forall a b. (a -> b) -> a -> b
$ Double -> Double -> [Double]
forall a. Enum a => a -> a -> [a]
enumFromTo Double
x Double
y
        (Either Double E, Either Double E)
_ -> Name -> [E]
forall a. Name -> a
enumError Name
"[a .. b]"

    enumFromThenTo :: E -> E -> E -> [E]
enumFromThenTo E
a E
b E
c = case (E -> Either Double E
toNumOpt E
a, E -> Either Double E
toNumOpt E
b, E -> Either Double E
toNumOpt E
c) of
        (Left Double
x, Left Double
y, Left Double
z) -> (Double -> E) -> [Double] -> [E]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> E
fromDouble ([Double] -> [E]) -> [Double] -> [E]
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double -> [Double]
forall a. Enum a => a -> a -> a -> [a]
enumFromThenTo Double
x Double
y Double
z
        (Either Double E, Either Double E, Either Double E)
_ -> Name -> [E]
forall a. Name -> a
enumError Name
"[a, b .. c]"


instance Real E where toRational :: E -> Rational
toRational = Name -> E -> Rational
forall a. HasCallStack => Name -> a
error Name
"instance of the Real is not defined for Csound values. It's here only for other classes."

instance Integral E where
    quot :: E -> E -> E
quot E
a E
b = E -> E
intE (E -> E) -> E -> E
forall a b. (a -> b) -> a -> b
$ (E -> E
intE E
a) E -> E -> E
forall a. Fractional a => a -> a -> a
/ (E -> E
intE E
b)
    rem :: E -> E -> E
rem E
a E
b = (E
a E -> E -> E
forall a. Integral a => a -> a -> a
`quot` E
b) E -> E -> E
forall a. Num a => a -> a -> a
* E
b E -> E -> E
forall a. Num a => a -> a -> a
- E
a
    mod :: E -> E -> E
mod = E -> E -> E
mod'
    div :: E -> E -> E
div E
a E
b = E -> E
intE (E -> E) -> E -> E
forall a b. (a -> b) -> a -> b
$ E
a E -> E -> E
forall a. Num a => a -> a -> a
- E -> E -> E
forall a. Integral a => a -> a -> a
mod E
a E
b E -> E -> E
forall a. Fractional a => a -> a -> a
/ E
b
    quotRem :: E -> E -> (E, E)
quotRem E
a E
b = (E -> E -> E
forall a. Integral a => a -> a -> a
quot E
a E
b, E -> E -> E
forall a. Integral a => a -> a -> a
rem E
a E
b)
    divMod :: E -> E -> (E, E)
divMod E
a E
b = (E -> E -> E
forall a. Integral a => a -> a -> a
div E
a E
b, E -> E -> E
forall a. Integral a => a -> a -> a
mod E
a E
b)
    toInteger :: E -> Integer
toInteger = Name -> E -> Integer
forall a. HasCallStack => Name -> a
error Name
"toInteger is not defined for Csound values"

------------------------------------------------------------
-- Optimizations for constants
--
-- If an arithmetic expression contains constants we can execute
-- it and render as constant. We check wether all arguments
-- are constants. If it's so we apply some numeric function and
-- propogate a constant value.

toNumOpt :: E -> Either Double E
toNumOpt :: E -> Either Double E
toNumOpt E
x = case E -> Exp E
toExp E
x of
    ExpPrim (PrimDouble Double
d) -> Double -> Either Double E
forall a b. a -> Either a b
Left Double
d
    Exp E
_ -> E -> Either Double E
forall a b. b -> Either a b
Right E
x

fromNumOpt :: Either Double E -> E
fromNumOpt :: Either Double E -> E
fromNumOpt = (Double -> E) -> (E -> E) -> Either Double E -> E
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Prim -> E
prim (Prim -> E) -> (Double -> Prim) -> Double -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Prim
PrimDouble) E -> E
forall a. a -> a
id

expNum :: NumExp E -> E
expNum :: NumExp E -> E
expNum = Exp E -> E
noRate (Exp E -> E) -> (NumExp E -> Exp E) -> NumExp E -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NumExp (PrimOr E) -> Exp E
forall a. NumExp a -> MainExp a
ExpNum (NumExp (PrimOr E) -> Exp E)
-> (NumExp E -> NumExp (PrimOr E)) -> NumExp E -> Exp E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (E -> PrimOr E) -> NumExp E -> NumExp (PrimOr E)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap E -> PrimOr E
toPrimOr

fromDouble :: Double -> E
fromDouble :: Double -> E
fromDouble = Either Double E -> E
fromNumOpt (Either Double E -> E)
-> (Double -> Either Double E) -> Double -> E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Either Double E
forall a b. a -> Either a b
Left

isZero :: E -> Bool
isZero :: E -> Bool
isZero E
a = (Double -> Bool) -> (E -> Bool) -> Either Double E -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ( Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
0) (Bool -> E -> Bool
forall a b. a -> b -> a
const Bool
False) (Either Double E -> Bool) -> Either Double E -> Bool
forall a b. (a -> b) -> a -> b
$ E -> Either Double E
toNumOpt E
a

-- optimization for unary functions
unOpt :: (Double -> Double) -> (E -> E) -> E -> E
unOpt :: (Double -> Double) -> (E -> E) -> E -> E
unOpt Double -> Double
doubleOp E -> E
op E
a = Either Double E -> E
fromNumOpt (Either Double E -> E) -> Either Double E -> E
forall a b. (a -> b) -> a -> b
$ (Double -> Either Double E)
-> (E -> Either Double E) -> Either Double E -> Either Double E
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Double -> Either Double E
forall a b. a -> Either a b
Left (Double -> Either Double E)
-> (Double -> Double) -> Double -> Either Double E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double
doubleOp) (E -> Either Double E
forall a b. b -> Either a b
Right (E -> Either Double E) -> (E -> E) -> E -> Either Double E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E -> E
op) (Either Double E -> Either Double E)
-> Either Double E -> Either Double E
forall a b. (a -> b) -> a -> b
$ E -> Either Double E
toNumOpt E
a

-- optimization for binary functions
biOpt :: (Double -> Double -> Double) -> NumOp -> E -> E -> E
biOpt :: (Double -> Double -> Double) -> NumOp -> E -> E -> E
biOpt Double -> Double -> Double
doubleOp NumOp
op E
a E
b = Either Double E -> E
fromNumOpt (Either Double E -> E) -> Either Double E -> E
forall a b. (a -> b) -> a -> b
$ case (E -> Either Double E
toNumOpt E
a, E -> Either Double E
toNumOpt E
b) of
    (Left Double
da, Left Double
db) -> Double -> Either Double E
forall a b. a -> Either a b
Left (Double -> Either Double E) -> Double -> Either Double E
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
doubleOp Double
da Double
db
    (Either Double E, Either Double E)
_ -> E -> Either Double E
forall a b. b -> Either a b
Right (E -> Either Double E) -> E -> Either Double E
forall a b. (a -> b) -> a -> b
$ E -> E -> E
noOpt2 E
a E
b
    where noOpt2 :: E -> E -> E
noOpt2 E
x E
y = NumExp E -> E
expNum (NumExp E -> E) -> NumExp E -> E
forall a b. (a -> b) -> a -> b
$ NumOp -> [E] -> NumExp E
forall a b. a -> [b] -> PreInline a b
PreInline NumOp
op [E
x, E
y]

doubleToInt :: (Double -> Int) -> (E -> E) -> E -> E
doubleToInt :: (Double -> Int) -> (E -> E) -> E -> E
doubleToInt Double -> Int
fun = (Double -> Double) -> (E -> E) -> E -> E
unOpt (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> (Double -> Int) -> Double -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Int
fun)

-- arithmetic

mod' :: E -> E -> E
mod' :: E -> E -> E
mod' = (Double -> Double -> Double) -> NumOp -> E -> E -> E
biOpt (\Double
a Double
b -> Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> Int -> Double
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod (Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor Double
a :: Int) (Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor Double
b)) NumOp
Mod

-- other functions

ceilE, floorE, fracE, intE, roundE :: E -> E

ceilE :: E -> E
ceilE   = (Double -> Int) -> (E -> E) -> E -> E
doubleToInt Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Name -> E -> E
opr1 Name
"ceil")
floorE :: E -> E
floorE  = (Double -> Int) -> (E -> E) -> E -> E
doubleToInt Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Name -> E -> E
opr1 Name
"floor")
roundE :: E -> E
roundE  = (Double -> Int) -> (E -> E) -> E -> E
doubleToInt Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Name -> E -> E
opr1 Name
"round")
fracE :: E -> E
fracE   = (Double -> Double) -> (E -> E) -> E -> E
unOpt ((Int, Double) -> Double
forall a b. (a, b) -> b
snd ((Int, Double) -> Double)
-> (Double -> (Int, Double)) -> Double -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> (Int, Double)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction :: (Double -> (Int, Double)))) (Name -> E -> E
opr1 Name
"frac")
intE :: E -> E
intE    = (Double -> Int) -> (E -> E) -> E -> E
doubleToInt Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Name -> E -> E
opr1 Name
"int")