{-# LANGUAGE Rank2Types #-}
{- |
Copyright   :  (c) Henning Thielemann 2008-2009
License     :  GPL

Maintainer  :  synthesizer@henning-thielemann.de
Stability   :  provisional
Portability :  requires multi-parameter type classes
               and local universal quantification


Light-weight sample parameter inference which will fit most needs.
We only do \"poor man's inference\", only for sample rates.
The sample rate will be provided as an argument of a special type 'T'.
This argument will almost never be passed explicitly
but should be handled by operators analogous to '($)' and '(.)'.

In contrast to the run-time inference approach,
we have the static guarantee that the sample rate is fixed
before passing a signal to the outside world.
However we still need to make it safe that signals
that are rendered for one sample rate
are not processed with another sample rate.
-}
module Synthesizer.Dimensional.Process (
      T(..),
      run, {-share,-} withParam, getSampleRate,
      toTimeScalar,    toFrequencyScalar,
      toTimeDimension, toFrequencyDimension,
      intFromTime, intFromTime98,
      DimensionGradient, toGradientScalar,
      loop, pure,
      ($:), ($::), ($^), ($#),
      (.:), (.^),
      liftP, liftP2, liftP3, liftP4,
   ) where

import qualified Number.DimensionTerm        as DN
import qualified Algebra.DimensionTerm       as Dim

import Number.DimensionTerm ((*&), (&/&), ) -- ((&*&), )

import qualified Algebra.RealRing      as RealRing
import qualified Algebra.Field          as Field
import qualified Algebra.Ring           as Ring

import Control.Monad.Fix (MonadFix(mfix), )
-- import Control.Monad.Trans.Reader ()
import Synthesizer.ApplicativeUtility
import qualified Control.Applicative as App
import Control.Applicative (Applicative)

import NumericPrelude.Numeric
import NumericPrelude.Base

import qualified Prelude as P
import Prelude (RealFrac)


{- |
This wraps a function which computes a sample rate dependent result.
Sample rate tells how many values per unit are stored
for representation of a signal.

The process is labeled with a type variable @s@ which is part the signals.
This way we can ensure that signals are only used
with the sample rate they are created for.
-}
newtype T s u t a = Cons {forall s u t a. T s u t a -> T (Recip u) t -> a
process :: DN.T (Dim.Recip u) t -> a}

instance Functor (T s u t) where
   fmap :: forall a b. (a -> b) -> T s u t a -> T s u t b
fmap a -> b
f (Cons T (Recip u) t -> a
g) = forall s u t a. (T (Recip u) t -> a) -> T s u t a
Cons (a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. T (Recip u) t -> a
g)

instance Applicative (T s u t) where
   pure :: forall a. a -> T s u t a
pure  = forall a s u t. a -> T s u t a
pure
   <*> :: forall a b. T s u t (a -> b) -> T s u t a -> T s u t b
(<*>) = forall s u t a b. T s u t (a -> b) -> T s u t a -> T s u t b
apply

instance Monad (T s u t) where
   return :: forall a. a -> T s u t a
return = forall a s u t. a -> T s u t a
pure
   >>= :: forall a b. T s u t a -> (a -> T s u t b) -> T s u t b
(>>=)  = forall s u t a b. T s u t a -> (a -> T s u t b) -> T s u t b
bind

instance MonadFix (T s u t) where
   mfix :: forall a. (a -> T s u t a) -> T s u t a
mfix = forall (f :: * -> *) a. Functor f => f (a -> a) -> f a
loop forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s u t b. (a -> T s u t b) -> T s u t (a -> b)
withParam


{-# INLINE pure #-}
pure :: a -> T s u t a
pure :: forall a s u t. a -> T s u t a
pure = forall s u t a. (T (Recip u) t -> a) -> T s u t a
Cons forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const

{-# INLINE apply #-}
apply :: T s u t (a -> b) -> T s u t a -> T s u t b
apply :: forall s u t a b. T s u t (a -> b) -> T s u t a -> T s u t b
apply (Cons T (Recip u) t -> a -> b
f) T s u t a
arg = forall s u t a. (T (Recip u) t -> a) -> T s u t a
Cons forall a b. (a -> b) -> a -> b
$ \T (Recip u) t
sr -> T (Recip u) t -> a -> b
f T (Recip u) t
sr (forall s u t a. T s u t a -> T (Recip u) t -> a
process T s u t a
arg T (Recip u) t
sr)


{- |
Get results from the Process monad.
You can obtain only signals (or other values)
that do not implicitly depend on the sample rate,
that is value without the @s@ type parameter.
-}
{-# INLINE run #-}
run :: (Dim.C u) => DN.T (Dim.Recip u) t -> (forall s. T s u t a) -> a
run :: forall u t a. C u => T (Recip u) t -> (forall s. T s u t a) -> a
run T (Recip u) t
sampleRate forall s. T s u t a
f = forall s u t a. T s u t a -> T (Recip u) t -> a
process forall s. T s u t a
f T (Recip u) t
sampleRate

{-
{- |
You can write
@x >>= (\x0 -> Cut.zip $# x0 $# x0)@
or
@share x (\x0 -> Cut.zip $: x0 $: x0)@.
'share' allows for more consistent usage of @($:)@.
-}
share :: T s u t a -> (T s u t a -> T s u t b) -> T s u t b
share x y  =  y . return =<< x
-}

{-# INLINE bind #-}
bind :: T s u t a -> (a -> T s u t b) -> T s u t b
bind :: forall s u t a b. T s u t a -> (a -> T s u t b) -> T s u t b
bind (Cons T (Recip u) t -> a
f) a -> T s u t b
mg =
   forall s u t a. (T (Recip u) t -> a) -> T s u t a
Cons forall a b. (a -> b) -> a -> b
$ \ T (Recip u) t
sr -> forall s u t a. T s u t a -> T (Recip u) t -> a
process (a -> T s u t b
mg (T (Recip u) t -> a
f T (Recip u) t
sr)) T (Recip u) t
sr

-- same as Inference.Reader.Process.injectParam
{-# INLINE withParam #-}
withParam :: (a -> T s u t b) -> T s u t (a -> b)
withParam :: forall a s u t b. (a -> T s u t b) -> T s u t (a -> b)
withParam a -> T s u t b
f = forall s u t a. (T (Recip u) t -> a) -> T s u t a
Cons (\T (Recip u) t
sr a
a -> forall s u t a. T s u t a -> T (Recip u) t -> a
process (a -> T s u t b
f a
a) T (Recip u) t
sr)


{-# INLINE getSampleRate #-}
getSampleRate :: Dim.C u => T s u t (DN.T (Dim.Recip u) t)
getSampleRate :: forall u s t. C u => T s u t (T (Recip u) t)
getSampleRate = forall s u t a. (T (Recip u) t -> a) -> T s u t a
Cons forall a. a -> a
id


{-# INLINE toTimeScalar #-}
toTimeScalar {- , (~*&) -} :: (Ring.C t, Dim.C u) =>
   DN.T u t -> T s u t t
toTimeScalar :: forall t u s. (C t, C u) => T u t -> T s u t t
toTimeScalar T u t
time =
   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall u a. (C u, C a) => T u a -> T (Recip u) a -> a
DN.mulToScalar T u t
time) forall u s t. C u => T s u t (T (Recip u) t)
getSampleRate

{-# INLINE toFrequencyScalar #-}
toFrequencyScalar {- , (~/&) -} :: (Field.C t, Dim.C u) =>
   DN.T (Dim.Recip u) t -> T s u t t
toFrequencyScalar :: forall t u s. (C t, C u) => T (Recip u) t -> T s u t t
toFrequencyScalar T (Recip u) t
freq =
   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall u a. (C u, C a) => T u a -> T u a -> a
DN.divToScalar T (Recip u) t
freq) forall u s t. C u => T s u t (T (Recip u) t)
getSampleRate


{-# INLINE toTimeDimension #-}
toTimeDimension :: (Field.C t, Dim.C u) =>
   t -> T s u t (DN.T u t)
toTimeDimension :: forall t u s. (C t, C u) => t -> T s u t (T u t)
toTimeDimension t
t =
   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\T (Recip u) t
sampleRate -> t
t forall u a. (C u, C a) => a -> T u a -> T u a
*& forall u a. (C u, C a) => T (Recip u) a -> T u a
DN.unrecip T (Recip u) t
sampleRate) forall u s t. C u => T s u t (T (Recip u) t)
getSampleRate

{-# INLINE toFrequencyDimension #-}
toFrequencyDimension :: (Ring.C t, Dim.C u) =>
   t -> T s u t (DN.T (Dim.Recip u) t)
toFrequencyDimension :: forall t u s. (C t, C u) => t -> T s u t (T (Recip u) t)
toFrequencyDimension t
f =
   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\T (Recip u) t
sampleRate -> t
f forall u a. (C u, C a) => a -> T u a -> T u a
*& T (Recip u) t
sampleRate) forall u s t. C u => T s u t (T (Recip u) t)
getSampleRate


type DimensionGradient u v = Dim.Mul (Dim.Recip u) v

{-# INLINE toGradientScalar #-}
toGradientScalar :: (Field.C q, Dim.C u, Dim.C v) =>
   DN.T v q -> DN.T (DimensionGradient u v) q -> T s u q q
toGradientScalar :: forall q u v s.
(C q, C u, C v) =>
T v q -> T (DimensionGradient u v) q -> T s u q q
toGradientScalar T v q
amp T (Mul (Recip u) v) q
steepness =
   forall t u s. (C t, C u) => T (Recip u) t -> T s u t t
toFrequencyScalar
   (forall u v a. (C u, C v) => (u -> v) -> T u a -> T v a
DN.rewriteDimension (forall u. C u => Mul u Scalar -> u
Dim.identityRight forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall u0 u1 v.
(C u0, C u1, C v) =>
(u0 -> u1) -> Mul v u0 -> Mul v u1
Dim.applyRightMul forall u. C u => Mul u (Recip u) -> Scalar
Dim.cancelRight forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall u0 u1 u2.
(C u0, C u1, C u2) =>
Mul (Mul u0 u1) u2 -> Mul u0 (Mul u1 u2)
Dim.associateRight) forall a b. (a -> b) -> a -> b
$
    T (Mul (Recip u) v) q
steepness forall u v a.
(C u, C v, C a) =>
T u a -> T v a -> T (Mul u (Recip v)) a
&/& T v q
amp)

{-
infixl 7 ~*&, ~/&

(~*&) = toTimeScalar
(~/&) = toFrequencyScalar
-}


checkedChunkSize ::
   String -> Int -> Int
checkedChunkSize :: String -> Int -> Int
checkedChunkSize String
funcName Int
cs =
   if Int
csforall a. Ord a => a -> a -> Bool
>Int
0
     then Int
cs
     else forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
funcName forall a. [a] -> [a] -> [a]
++ String
": negative chunkSize"

intFromTime ::
   (RealRing.C t, Dim.C u) =>
   String ->
   DN.T u t ->
   T s u t Int
intFromTime :: forall t u s. (C t, C u) => String -> T u t -> T s u t Int
intFromTime String
funcName T u t
t =
   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Int -> Int
checkedChunkSize String
funcName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (C a, C b) => a -> b
RealRing.ceiling) forall a b. (a -> b) -> a -> b
$ forall t u s. (C t, C u) => T u t -> T s u t t
toTimeScalar T u t
t

intFromTime98 ::
   (Ring.C t, RealFrac t, Dim.C u) =>
   String ->
   DN.T u t ->
   T s u t Int
intFromTime98 :: forall t u s.
(C t, RealFrac t, C u) =>
String -> T u t -> T s u t Int
intFromTime98 String
funcName T u t
t =
   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Int -> Int
checkedChunkSize String
funcName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
P.ceiling) forall a b. (a -> b) -> a -> b
$ forall t u s. (C t, C u) => T u t -> T s u t t
toTimeScalar T u t
t