-- | A warp is a mapping from the space @[0,1]@ to a user defined space @[l,r]@.
module Sound.SC3.Common.Math.Warp where

import Numeric {- base -}

import qualified Sound.SC3.Common.Math as Math {- hsc3 -}

-- | A warp function is lhs -> rhs -> x -> y
type Warp_f t = t -> t -> t -> t

{- | Linear real value map.

> map (warp_lin 1 2) [0,1/2,1] == [1,3/2,2]
> map (warp_lin (-1) 1) [0,1/2,1] == [-1,0,1]
-}
warp_lin :: Fractional t => Warp_f t
warp_lin :: Warp_f t
warp_lin t
l t
r t
n = let z :: t
z = t
r t -> t -> t
forall a. Num a => a -> a -> a
- t
l in t
n t -> t -> t
forall a. Num a => a -> a -> a
* t
z t -> t -> t
forall a. Num a => a -> a -> a
+ t
l

{- | Inverse of 'warp_lin'

> map (warp_lin_inv 1 2) [1,3/2,2] == [0,1/2,1]
> map (warp_lin_inv (-1) 1) [-1,0,1] == [0,1/2,1]
-}
warp_lin_inv :: Fractional t => Warp_f t
warp_lin_inv :: Warp_f t
warp_lin_inv t
l t
r t
n = let z :: t
z = t
r t -> t -> t
forall a. Num a => a -> a -> a
- t
l in (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
l) t -> t -> t
forall a. Fractional a => a -> a -> a
/ t
z

{- | The left and right must both be non zero and have the same sign.

> map (warp_exp 1 2) [0,0.5,1] == [1,2 ** 0.5,2]
> import Sound.SC3.Plot {- hsc3-plot -}
> plot_p1_ln [map (warp_exp 1 2) [0,0.01 .. 1]]
-}
warp_exp :: Floating a => Warp_f a
warp_exp :: Warp_f a
warp_exp a
l a
r a
n = let z :: a
z = a
r a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
l in (a
z a -> a -> a
forall a. Floating a => a -> a -> a
** a
n) a -> a -> a
forall a. Num a => a -> a -> a
* a
l

warp_exp_inv :: Floating a => Warp_f a
warp_exp_inv :: Warp_f a
warp_exp_inv a
l a
r a
n = let z :: a
z = a
r a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
l in a -> a -> a
forall a. Floating a => a -> a -> a
logBase a
z (a
n a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
l)

{- | Cosine warp

> map (warp_cos 1 2) [0,0.25,0.5,0.75,1]
> plot_p1_ln [map (warp_cos 1 2) [0,0.01 .. 1]]
-}
warp_cos :: Floating t => Warp_f t
warp_cos :: Warp_f t
warp_cos t
l t
r t
n = Warp_f t
forall t. Fractional t => Warp_f t
warp_lin t
0 (t
r t -> t -> t
forall a. Num a => a -> a -> a
- t
l) (t
0.5 t -> t -> t
forall a. Num a => a -> a -> a
- (t -> t
forall a. Floating a => a -> a
cos (t
forall a. Floating a => a
pi t -> t -> t
forall a. Num a => a -> a -> a
* t
n) t -> t -> t
forall a. Fractional a => a -> a -> a
/ t
2))

warp_cos_inv :: Floating a => Warp_f a
warp_cos_inv :: Warp_f a
warp_cos_inv a
l a
r a
n = a -> a
forall a. Floating a => a -> a
acos (a
1.0 a -> a -> a
forall a. Num a => a -> a -> a
- (Warp_f a
forall t. Fractional t => Warp_f t
warp_lin_inv a
0 (a
r a -> a -> a
forall a. Num a => a -> a -> a
- a
l) a
n a -> a -> a
forall a. Num a => a -> a -> a
* a
2)) a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
forall a. Floating a => a
pi

{- | Sine warp

> map (warp_sin 1 2) [0,0.25,0.5,0.75,1]
> plot_p1_ln [map (warp_sin 1 2) [0,0.01 .. 1]]
-}
warp_sin :: Floating t => Warp_f t
warp_sin :: Warp_f t
warp_sin t
l t
r t
n = Warp_f t
forall t. Fractional t => Warp_f t
warp_lin t
0 (t
r t -> t -> t
forall a. Num a => a -> a -> a
- t
l) (t -> t
forall a. Floating a => a -> a
sin (t
forall a. Floating a => a
pi t -> t -> t
forall a. Num a => a -> a -> a
* t
0.5 t -> t -> t
forall a. Num a => a -> a -> a
* t
n))

warp_sin_inv :: Floating t => Warp_f t
warp_sin_inv :: Warp_f t
warp_sin_inv t
l t
r t
n = t -> t
forall a. Floating a => a -> a
asin (Warp_f t
forall t. Fractional t => Warp_f t
warp_lin_inv t
0 (t
r t -> t -> t
forall a. Num a => a -> a -> a
- t
l) t
n) t -> t -> t
forall a. Fractional a => a -> a -> a
/ (t
forall a. Floating a => a
pi t -> t -> t
forall a. Fractional a => a -> a -> a
/ t
2)

{- | Fader warp.  Left and right values are ordinarily zero and one.

> map (warp_amp 0 1) [0,0.5,1] == [0,0.25,1]

> plot_p1_ln [map (warp_amp 0 2) [0,0.01 .. 1]]
> plot_p1_ln [map (warp_amp_inv 0 1 . warp_amp 0 1) [0,0.01 .. 1]]
-}
warp_amp :: Num a => Warp_f a
warp_amp :: Warp_f a
warp_amp a
l a
r a
n = (a
n a -> a -> a
forall a. Num a => a -> a -> a
* a
n) a -> a -> a
forall a. Num a => a -> a -> a
* (a
r a -> a -> a
forall a. Num a => a -> a -> a
- a
l) a -> a -> a
forall a. Num a => a -> a -> a
+ a
l

warp_amp_inv :: Floating a => Warp_f a
warp_amp_inv :: Warp_f a
warp_amp_inv a
l a
r a
n = a -> a
forall a. Floating a => a -> a
sqrt ((a
n a -> a -> a
forall a. Num a => a -> a -> a
- a
l) a -> a -> a
forall a. Fractional a => a -> a -> a
/ (a
r a -> a -> a
forall a. Num a => a -> a -> a
- a
l))

{- | DB fader warp. Left and right values are ordinarily negative
infinity and zero.  An input of @0@ gives @-180@.

> map (round . warp_db (-180) 0) [0,0.5,1] == [-180,-12,0]

> plot_p1_ln [map (warp_db (-60) 0) [0,0.01 .. 1]]
> plot_p1_ln [map (warp_db_inv 0 60) [0 .. 60]]
-}
warp_db :: (Eq a, Floating a) => Warp_f a
warp_db :: Warp_f a
warp_db a
l a
r a
n =
  let n' :: a
n' = if a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 then -a
180 else a -> a
forall a. Floating a => a -> a
Math.amp_to_db (a
n a -> a -> a
forall a. Num a => a -> a -> a
* a
n)
  in a -> a -> Warp_f a
forall a. Fractional a => a -> a -> a -> a -> a -> a
Math.sc3_linlin a
n' (-a
180) a
0 a
l a
r

warp_db_inv :: Floating a => Warp_f a
warp_db_inv :: Warp_f a
warp_db_inv a
l a
r a
n = a -> a
forall a. Floating a => a -> a
sqrt (a -> a
forall a. Floating a => a -> a
Math.db_to_amp (a -> a -> Warp_f a
forall a. Fractional a => a -> a -> a -> a -> a -> a
Math.sc3_linlin a
n a
l a
r (-a
180) a
0))

{- | A curve warp given by a real /n/.

> warp_curve (-3) 1 2 0.25 == 1.5552791692202022
> warp_curve (-3) 1 2 0.50 == 1.8175744761936437

> plot_p1_ln [map (warp_curve (-3) 1 2) [0,0.01 .. 1]]
> plot_p1_ln (map (\c -> map (warp_curve c 1 2) [0,0.01 .. 1]) [0,3,6,9])
> plot_p1_ln [map (warp_curve_inv 7 20 20000 . warp_curve 7 20 20000) [0,0.01 .. 1]]
-}
warp_curve :: (Ord a, Floating a) => a -> Warp_f a
warp_curve :: a -> Warp_f a
warp_curve a
k a
l a
r a
n =
  if a -> a
forall a. Num a => a -> a
abs a
k a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0.001
  then Warp_f a
forall t. Fractional t => Warp_f t
warp_lin a
l a
r a
n
  else let e :: a
e = a -> a
forall a. Floating a => a -> a
exp a
k
           a :: a
a = (a
r a -> a -> a
forall a. Num a => a -> a -> a
- a
l) a -> a -> a
forall a. Fractional a => a -> a -> a
/ (a
1 a -> a -> a
forall a. Num a => a -> a -> a
- a
e)
           b :: a
b = a
l a -> a -> a
forall a. Num a => a -> a -> a
+ a
a
       in a
b a -> a -> a
forall a. Num a => a -> a -> a
- ((a
e a -> a -> a
forall a. Floating a => a -> a -> a
** a
n) a -> a -> a
forall a. Num a => a -> a -> a
* a
a)

warp_curve_inv :: (Ord a, Floating a) => a -> Warp_f a
warp_curve_inv :: a -> Warp_f a
warp_curve_inv a
k a
l a
r a
n =
  if a -> a
forall a. Num a => a -> a
abs a
k a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0.001
  then Warp_f a
forall t. Fractional t => Warp_f t
warp_lin a
l a
r a
n
  else let e :: a
e = a -> a
forall a. Floating a => a -> a
exp a
k
           a :: a
a = (a
r a -> a -> a
forall a. Num a => a -> a -> a
- a
l) a -> a -> a
forall a. Fractional a => a -> a -> a
/ (a
1 a -> a -> a
forall a. Num a => a -> a -> a
- a
e)
           b :: a
b = a
l a -> a -> a
forall a. Num a => a -> a -> a
+ a
a
       in a -> a
forall a. Floating a => a -> a
log ((a
b a -> a -> a
forall a. Num a => a -> a -> a
- a
n) a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
a) a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
k

{- | Select warp functions by name.  Numerical names are interpreted as /curve/ values for 'warpCurve'.

> let Just w = warp_named "lin"
> let Just w = warp_named "-3"
> let Just w = warp_named "6"
> plot_p1_ln [map ((fst w) 1 2) [0,0.01 .. 1]]
-}
warp_named :: (Floating t, RealFrac t) => String -> Maybe (Warp_f t, Warp_f t)
warp_named :: String -> Maybe (Warp_f t, Warp_f t)
warp_named String
nm =
    case String
nm of
      String
"lin" -> (Warp_f t, Warp_f t) -> Maybe (Warp_f t, Warp_f t)
forall a. a -> Maybe a
Just (Warp_f t
forall t. Fractional t => Warp_f t
warp_lin,Warp_f t
forall t. Fractional t => Warp_f t
warp_lin_inv)
      String
"exp" -> (Warp_f t, Warp_f t) -> Maybe (Warp_f t, Warp_f t)
forall a. a -> Maybe a
Just (Warp_f t
forall a. Floating a => Warp_f a
warp_exp,Warp_f t
forall a. Floating a => Warp_f a
warp_exp_inv)
      String
"sin" -> (Warp_f t, Warp_f t) -> Maybe (Warp_f t, Warp_f t)
forall a. a -> Maybe a
Just (Warp_f t
forall a. Floating a => Warp_f a
warp_sin,Warp_f t
forall a. Floating a => Warp_f a
warp_sin_inv)
      String
"cos" -> (Warp_f t, Warp_f t) -> Maybe (Warp_f t, Warp_f t)
forall a. a -> Maybe a
Just (Warp_f t
forall a. Floating a => Warp_f a
warp_cos,Warp_f t
forall a. Floating a => Warp_f a
warp_cos_inv)
      String
"amp" -> (Warp_f t, Warp_f t) -> Maybe (Warp_f t, Warp_f t)
forall a. a -> Maybe a
Just (Warp_f t
forall a. Num a => Warp_f a
warp_amp,Warp_f t
forall a. Floating a => Warp_f a
warp_amp_inv)
      String
"db" -> (Warp_f t, Warp_f t) -> Maybe (Warp_f t, Warp_f t)
forall a. a -> Maybe a
Just (Warp_f t
forall a. (Eq a, Floating a) => Warp_f a
warp_db,Warp_f t
forall a. Floating a => Warp_f a
warp_db_inv)
      String
_ -> case ReadS t -> ReadS t
forall a. Real a => ReadS a -> ReadS a
readSigned ReadS t
forall a. RealFrac a => ReadS a
readFloat String
nm of
             [(t
c,String
"")] -> (Warp_f t, Warp_f t) -> Maybe (Warp_f t, Warp_f t)
forall a. a -> Maybe a
Just (t -> Warp_f t
forall a. (Ord a, Floating a) => a -> Warp_f a
warp_curve t
c,t -> Warp_f t
forall a. (Ord a, Floating a) => a -> Warp_f a
warp_curve_inv t
c)
             [(t, String)]
_ -> Maybe (Warp_f t, Warp_f t)
forall a. Maybe a
Nothing