module Csound.Exp.Numeric(
fracD, floorD, ceilD, intD, roundD,
fracSig, floorSig, ceilSig, intSig, roundSig
) where
import Data.Maybe(fromJust)
import Control.Applicative
import Data.Fix
import Csound.Exp
import Csound.Exp.Wrapper
import Csound.Exp.Cons
class NumOpt a where
maybeDouble :: a -> Maybe Double
fromDouble :: Double -> a
fromNum :: NumExp a -> a
instance NumOpt E where
maybeDouble x = case ratedExpExp $ unFix x of
ExpPrim (PrimDouble d) -> Just d
_ -> Nothing
fromDouble = prim . PrimDouble
fromNum = noRate . ExpNum . fmap toPrimOr
instance Num E where
(+) a b
| isZero a = b
| isZero b = a
| otherwise = biOpt (+) Add a b
(*) a b
| isZero a || isZero b = fromDouble 0
| otherwise = biOpt (*) Mul a b
() a b
| isZero a = negate b
| isZero b = a
| otherwise = biOpt () Sub a b
negate = unOpt negate Neg
fromInteger = fromDouble . fromInteger
abs = unOpt abs Abs
signum = undefined
instance Fractional E where
(/) a b
| isZero a = fromDouble 0
| isZero b = error "csound (/): division by zero"
| otherwise = biOpt (/) Div a b
fromRational = fromDouble . fromRational
instance Floating E where
pi = fromDouble pi
exp = funOpt exp ExpOp
sqrt = funOpt sqrt Sqrt
log = funOpt log Log
logBase a n = case n of
2 -> funOpt (flip logBase 2) Logbtwo a
10 -> funOpt (flip logBase 10) Log10 a
b -> log a / log b
(**) = biOpt (**) Pow
sin = funOpt sin Sin
tan = funOpt tan Tan
cos = funOpt cos Cos
asin = funOpt asin Sininv
atan = funOpt atan Taninv
acos = funOpt acos Cosinv
sinh = funOpt sinh Sinh
tanh = funOpt tanh Tanh
cosh = funOpt cosh Cosh
asinh a = log $ a + sqrt (a * a + 1)
acosh a = log $ a + sqrt (a + 1) * sqrt (a 1)
atanh a = 0.5 * log ((1 + a) / (1 a))
enumError name = error $ name ++ " -- is defined only for literals"
instance Enum E where
succ = (+1)
pred = \x -> x 1
toEnum = fromDouble . fromIntegral
fromEnum = undefined
enumFrom a = a : enumFrom (a+1)
enumFromThen a b = a : enumFromThen (a + b) b
enumFromTo a b = case (maybeDouble a, maybeDouble b) of
(Just x, Just y) -> fmap fromDouble $ enumFromTo x y
_ -> enumError "[a .. b]"
enumFromThenTo a b c = case (maybeDouble a, maybeDouble b, maybeDouble c) of
(Just x, Just y, Just z) -> fmap fromDouble $ enumFromThenTo x y z
_ -> enumError "[a, b .. c]"
instance Real E where toRational = undefined
instance Integral E where
quot a b = intE $ (intE a) / (intE b)
rem a b = (a `quot` b) * b a
mod = mod'
div a b = intE $ a mod a b / b
quotRem a b = (quot a b, rem a b)
divMod a b = (div a b, mod a b)
toInteger = undefined
onE1 :: (Val a, Val b) => (E -> E) -> (a -> b)
onE1 f = wrap . unFix . f . Fix . unwrap
onE2 :: (Val a, Val b, Val c) => (E -> E -> E) -> (a -> b -> c)
onE2 f a b = wrap $ unFix $ f (Fix $ unwrap a) (Fix $ unwrap b)
onConst :: Val b => (a -> E) -> (a -> b)
onConst f = wrap . unFix . f
instance Real Sig where toRational = undefined
instance Ord Sig where compare = undefined
instance Eq Sig where (==) = undefined
instance Real D where toRational = undefined
instance Ord D where compare = undefined
instance Eq D where (==) = undefined
instance Enum Sig where
succ = onE1 succ
pred = onE1 pred
toEnum = fromE . toEnum
fromEnum = fromEnum . toE
enumFrom a = fmap fromE $ enumFrom $ toE a
enumFromThen a b = fmap fromE $ enumFromThen (toE a) (toE b)
enumFromTo a b = fmap fromE $ enumFromTo (toE a) (toE b)
enumFromThenTo a b c = fmap fromE $ enumFromThenTo (toE a) (toE b) (toE c)
instance Enum D where
succ = onE1 succ
pred = onE1 pred
toEnum = fromE . toEnum
fromEnum = fromEnum . toE
enumFrom a = fmap fromE $ enumFrom $ toE a
enumFromThen a b = fmap fromE $ enumFromThen (toE a) (toE b)
enumFromTo a b = fmap fromE $ enumFromTo (toE a) (toE b)
enumFromThenTo a b c = fmap fromE $ enumFromThenTo (toE a) (toE b) (toE c)
instance Integral Sig where
quot = onE2 quot
rem = onE2 rem
div = onE2 div
mod = onE2 mod
quotRem a b = (fromE x, fromE y)
where (x, y) = quotRem (toE a) (toE b)
divMod a b = (fromE x, fromE y)
where (x, y) = divMod (toE a) (toE b)
toInteger = toInteger . toE
instance Integral D where
quot = onE2 quot
rem = onE2 rem
div = onE2 div
mod = onE2 mod
quotRem a b = (fromE x, fromE y)
where (x, y) = quotRem (toE a) (toE b)
divMod a b = (fromE x, fromE y)
where (x, y) = divMod (toE a) (toE b)
toInteger = toInteger . toE
fracSig :: Sig -> Sig
fracSig = onE1 fracE
floorSig :: Sig -> Sig
floorSig = onE1 floorE
ceilSig :: Sig -> Sig
ceilSig = onE1 ceilE
intSig :: Sig -> Sig
intSig = onE1 intE
roundSig :: Sig -> Sig
roundSig = onE1 roundE
fracD :: D -> D
fracD = onE1 fracE
floorD :: D -> D
floorD = onE1 floorE
ceilD :: D -> D
ceilD = onE1 ceilE
intD :: D -> D
intD = onE1 intE
roundD :: D -> D
roundD = onE1 roundE
instance Num Sig where
(+) = onE2 (+)
(*) = onE2 (*)
() = onE2 ()
negate = onE1 negate
fromInteger = onConst fromInteger
abs = onE1 abs
signum = onE1 signum
instance Num D where
(+) = onE2 (+)
(*) = onE2 (*)
() = onE2 ()
negate = onE1 negate
fromInteger = onConst fromInteger
abs = onE1 abs
signum = onE1 signum
instance Fractional Sig where
(/) = onE2 (/)
fromRational = onConst fromRational
instance Fractional D where
(/) = onE2 (/)
fromRational = onConst fromRational
instance Floating Sig where
pi = wrap $ unFix pi
exp = onE1 exp
sqrt = onE1 sqrt
log = onE1 log
logBase = onE2 logBase
(**) = onE2 (**)
sin = onE1 sin
tan = onE1 tan
cos = onE1 cos
asin = onE1 asin
atan = onE1 atan
acos = onE1 acos
sinh = onE1 sinh
tanh = onE1 tanh
cosh = onE1 cosh
asinh = onE1 asinh
acosh = onE1 acosh
atanh = onE1 atanh
instance Floating D where
pi = wrap $ unFix pi
exp = onE1 exp
sqrt = onE1 sqrt
log = onE1 log
logBase = onE2 logBase
(**) = onE2 (**)
sin = onE1 sin
tan = onE1 tan
cos = onE1 cos
asin = onE1 asin
atan = onE1 atan
acos = onE1 acos
sinh = onE1 sinh
tanh = onE1 tanh
cosh = onE1 cosh
asinh = onE1 asinh
acosh = onE1 acosh
atanh = onE1 atanh
isZero :: NumOpt a => a -> Bool
isZero a = maybe False id $ ((==0) <$> maybeDouble a)
unOpt :: (NumOpt a) => (Double -> Double) -> NumOp -> a -> a
unOpt doubleOp op a = fromJust $
(fromDouble . doubleOp <$> maybeDouble a)
<|> Just (noOpt1 op a)
biOpt :: (NumOpt a) => (Double -> Double -> Double) -> NumOp -> a -> a -> a
biOpt doubleOp op a b = fromJust $
(fromDouble <$> liftA2 doubleOp (maybeDouble a) (maybeDouble b))
<|> Just (noOpt2 op a b)
funOpt :: NumOpt a => (Double -> Double) -> NumOp -> a -> a
funOpt doubleOp op a = fromJust $
(fromDouble . doubleOp <$> maybeDouble a)
<|> Just (noOpt1 op a)
noOpt1 :: NumOpt a => NumOp -> a -> a
noOpt1 op a = fromNum $ PreInline op [a]
noOpt2 :: NumOpt a => NumOp -> a -> a -> a
noOpt2 op a b = fromNum $ PreInline op [a, b]
doubleToInt :: NumOpt a => (Double -> Int) -> NumOp -> a -> a
doubleToInt fun op a = fromJust $
(fromDouble . fromIntegral . fun <$> maybeDouble a)
<|> Just (noOpt1 op a)
mod' :: NumOpt a => a -> a -> a
mod' = biOpt (\a b -> fromIntegral $ mod (floor a) (floor b)) Pow
ceilE, floorE, fracE, intE, roundE :: E -> E
ceilE = doubleToInt ceiling Ceil
floorE = doubleToInt floor Floor
roundE = doubleToInt round Round
fracE = unOpt (snd . properFraction) Frac
intE = doubleToInt truncate IntOp