module Sound.SC3.Common.Math where
import qualified Data.Fixed as F
import Data.Maybe
half_pi :: Floating a => a
half_pi = pi / 2
two_pi :: Floating n => n
two_pi = 2 * pi
mul_add_hs :: Num a => a -> a -> a -> a
mul_add_hs m a = (+ a) . (* m)
sc_truncate :: RealFrac a => a -> a
sc_truncate = fromInteger . truncate
sc_round :: RealFrac a => a -> a
sc_round = fromInteger . round
sc_ceiling :: RealFrac a => a -> a
sc_ceiling = fromInteger . ceiling
sc_floor :: RealFrac a => a -> a
sc_floor = fromInteger . floor
sc3_round_to :: RealFrac n => n -> n -> n
sc3_round_to a b = if b == 0 then a else sc_floor ((a / b) + 0.5) * b
sc3_idiv :: RealFrac n => n -> n -> n
sc3_idiv a b = fromInteger (floor a `div` floor b)
sc3_mod :: RealFrac n => n -> n -> n
sc3_mod = F.mod'
fmod_f32 :: Float -> Float -> Float
fmod_f32 = sc3_mod
fmod_f64 :: Double -> Double -> Double
fmod_f64 = sc3_mod
sc_clip :: Ord a => a -> a -> a -> a
sc_clip n i j = if n < i then i else if n > j then j else n
clip_hs :: (Ord a) => (a,a) -> a -> a
clip_hs (i,j) n = sc_clip n i j
sc_mod :: RealFrac a => a -> a -> a
sc_mod n hi =
let lo = 0.0
in if n >= lo && n < hi
then n
else if hi == lo
then lo
else n hi * sc_floor (n / hi)
sc_wrap_ni :: RealFrac a => a -> a -> a -> a
sc_wrap_ni lo hi n = sc_mod (n lo) (hi lo) + lo
wrap_hs :: RealFrac n => (n,n) -> n -> n
wrap_hs (i,j) n =
let r = j i + 1
in if n >= i && n <= j
then n
else n r * sc_floor ((n i) / r)
sc_wrap :: RealFrac n => n -> n -> n -> n
sc_wrap a b c = wrap_hs (b,c) a
generic_wrap :: (Ord a, Num a) => (a,a) -> a -> a
generic_wrap (l,r) n =
let d = r l + 1
f = generic_wrap (l,r)
in if n < l
then f (n + d)
else if n > r then f (n d) else n
bin_to_freq :: (Fractional n, Integral i) => n -> i -> i -> n
bin_to_freq sr n i = fromIntegral i * sr / fromIntegral n
midi_to_cps :: Floating a => a -> a
midi_to_cps i = 440.0 * (2.0 ** ((i 69.0) * (1.0 / 12.0)))
cps_to_midi :: Floating a => a -> a
cps_to_midi a = (logBase 2 (a * (1.0 / 440.0)) * 12.0) + 69.0
cps_to_oct :: Floating a => a -> a
cps_to_oct a = logBase 2 (a * (1.0 / 440.0)) + 4.75
oct_to_cps :: Floating a => a -> a
oct_to_cps a = 440.0 * (2.0 ** (a 4.75))
amp_to_db :: Floating a => a -> a
amp_to_db a = logBase 10 a * 20
db_to_amp :: Floating a => a -> a
db_to_amp a = 10 ** (a * 0.05)
midi_to_ratio :: Floating a => a -> a
midi_to_ratio a = 2.0 ** (a * (1.0 / 12.0))
ratio_to_midi :: Floating a => a -> a
ratio_to_midi a = 12.0 * logBase 2 a
urange :: Fractional a => a -> a -> a -> a
urange l r i = let m = r l in i * m + l
range_muladd :: Fractional t => t -> t -> (t,t)
range_muladd = linlin_muladd (1) 1
range :: Fractional a => a -> a -> a -> a
range l r i = let (m,a) = range_muladd l r in i * m + a
range_hs :: Fractional a => (a,a) -> a -> a
range_hs (l,r) = range l r
data Clip_Rule = Clip_None | Clip_Left | Clip_Right | Clip_Both
deriving (Enum,Bounded)
apply_clip_rule :: Ord n => Clip_Rule -> n -> n -> n -> n -> n -> Maybe n
apply_clip_rule clip_rule sl sr dl dr x =
case clip_rule of
Clip_None -> Nothing
Clip_Left -> if x <= sl then Just dl else Nothing
Clip_Right -> if x >= sr then Just dr else Nothing
Clip_Both -> if x <= sl then Just dl else if x >= sr then Just dr else Nothing
linlin_muladd :: Fractional t => t -> t -> t -> t -> (t,t)
linlin_muladd sl sr dl dr =
let m = (dr dl) / (sr sl)
a = dl (m * sl)
in (m,a)
linlin :: Fractional a => a -> a -> a -> a -> a -> a
linlin i sl sr dl dr = let (m,a) = linlin_muladd sl sr dl dr in i * m + a
linlin_hs :: Fractional a => (a, a) -> (a, a) -> a -> a
linlin_hs (sl,sr) (dl,dr) i = linlin i sl sr dl dr
linlin_enum' :: (Enum t,Enum u) => t -> u -> t -> u
linlin_enum' src dst n = toEnum (fromEnum dst + (fromEnum n fromEnum src))
linlin_enum :: (Enum t,Enum u) => (t,t) -> (u,u) -> t -> Maybe u
linlin_enum (l,r) (l',r') n =
if fromEnum n >= fromEnum l && fromEnum r fromEnum l == fromEnum r' fromEnum l'
then Just (linlin_enum' l l' n)
else Nothing
linlin_enum_err :: (Enum t,Enum u) => (t,t) -> (u,u) -> t -> u
linlin_enum_err src dst = fromMaybe (error "linlin_enum") . linlin_enum src dst
linlin_eq :: (Eq a, Num a) => (a,a) -> (a,a) -> a -> Maybe a
linlin_eq (l,r) (l',r') n =
let d = r l
d' = r' l'
in if d == d' then Just (l' + (n l)) else Nothing
linlin_eq_err :: (Eq a,Num a) => (a,a) -> (a,a) -> a -> a
linlin_eq_err src dst = fromMaybe (error "linlin_eq") . linlin_eq src dst
sc_linexp :: (Ord a, Floating a) => a -> a -> a -> a -> a -> a
sc_linexp src_l src_r dst_l dst_r x =
case apply_clip_rule Clip_Both src_l src_r dst_l dst_r x of
Just r -> r
Nothing -> ((dst_r / dst_l) ** ((x src_l) / (src_r src_l))) * dst_l
sc_explin :: (Ord a, Floating a) => a -> a -> a -> a -> a -> a
sc_explin src_l src_r dst_l dst_r x =
case apply_clip_rule Clip_Both src_l src_r dst_l dst_r x of
Just r -> r
Nothing -> (log (x / src_l)) / (log (src_r / src_l)) * (dst_r dst_l) + dst_l
sc_expexp :: (Ord a, Floating a) => a -> a -> a -> a -> a -> a
sc_expexp src_l src_r dst_l dst_r x =
case apply_clip_rule Clip_Both src_l src_r dst_l dst_r x of
Just r -> r
Nothing -> ((dst_r / dst_l) ** (log (x / src_l) / log (src_r / src_l))) * dst_l
sc_lincurve :: (Ord a, Floating a) => a -> a -> a -> a -> a -> a -> a
sc_lincurve curve src_l src_r dst_l dst_r x =
case apply_clip_rule Clip_Both src_l src_r dst_l dst_r x of
Just r -> r
Nothing ->
if abs curve < 0.001
then linlin_hs (src_l,src_r) (dst_l,dst_r) x
else let grow = exp curve
a = (dst_r dst_l) / (1.0 grow)
b = dst_l + a
scaled = (x src_l) / (src_r src_l)
in b (a * (grow ** scaled))
sc_curvelin :: (Ord a, Floating a) => a -> a -> a -> a -> a -> a -> a
sc_curvelin curve src_l src_r dst_l dst_r x =
case apply_clip_rule Clip_Both src_l src_r dst_l dst_r x of
Just r -> r
Nothing ->
if abs curve < 0.001
then linlin_hs (src_l,src_r) (dst_l,dst_r) x
else let grow = exp curve
a = (src_r src_l) / (1.0 grow)
b = src_l + a
in log ((b x) / a) * (dst_r dst_l) / curve + dst_l
linexp_hs :: Floating a => (a,a) -> (a,a) -> a -> a
linexp_hs (in_l,in_r) (out_l,out_r) x =
let rt = out_r / out_l
rn = 1.0 / (in_r in_l)
rr = rn * negate in_l
in out_l * (rt ** (x * rn + rr))
lin_exp :: Floating a => a -> a -> a -> a -> a -> a
lin_exp x in_l in_r out_l out_r = linexp_hs (in_l,in_r) (out_l,out_r) x
cps_to_incr :: Fractional a => a -> a -> a -> a
cps_to_incr sr r cps = (r / sr) * cps
incr_to_cps :: Fractional a => a -> a -> a -> a
incr_to_cps sr r ic = ic / (r / sr)
lin_pan2 :: Fractional t => t -> t -> (t, t)
lin_pan2 p q =
let q' = (q / 2) + 0.5
in (p * (1 q'),p * q')
sc3_properFraction :: RealFrac t => t -> (t,t)
sc3_properFraction a =
let (p,q) = properFraction a
in (fromInteger p,q)
sc_dif_sqr :: Num a => a -> a -> a
sc_dif_sqr a b = (a * a) (b * b)
sc_hypot :: Floating a => a -> a -> a
sc_hypot x y = sqrt (x * x + y * y)
sc_hypotx :: (Ord a, Floating a) => a -> a -> a
sc_hypotx x y = abs x + abs y ((sqrt 2 1) * min (abs x) (abs y))
foldToRange :: (Ord a,Num a) => a -> a -> a -> a
foldToRange i j =
let f n = if n > j
then f (j (n j))
else if n < i
then f (i (n i))
else n
in f
fold_ :: (Ord a,Num a) => a -> a -> a -> a
fold_ n i j = foldToRange i j n