Signal.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{- |

Copyright   :  (c) Henning Thielemann 2006, 2008
License     :  GPL

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

-}
module Synthesizer.Inference.Func.Signal where

import qualified Synthesizer.Physical.Signal as SigP
import qualified Synthesizer.SampleRateContext.Signal as SigC

-- import qualified Algebra.OccasionallyScalar as OccScalar
-- import qualified Algebra.Module         as Module
-- import qualified Algebra.Field          as Field
-- import qualified Algebra.Ring           as Ring

-- import Algebra.OccasionallyScalar (toScalar)

import Control.Monad.Fix (fix, )
import Data.Maybe (catMaybes, isJust, )
import Data.List  (transpose, )
import Data.List.HT (shearTranspose, )

-- import NumericPrelude
import PreludeBase as P

{- |
Each process must work the following way:
If the signal processor has a fixed sample rate or amplitude
either implied by its parameters or its inputs
then this parameter should be set as @Just@
in the corresponding fields of @SigP.T@.
These fields must be computed
independently from the function argument of type @(t',y')@.
This function argument is the pair of eventually used signal parameters
sample rate and amplitude.
If you set signal parameters to @Just@ with a value,
then you can expect that the corresponding pair member has the same value.
-}
newtype T t t' y y' yv =
   Cons {eval :: (t',y') -> Evaluated t t' y y' yv}

type Evaluated t t' y y' yv = SigP.T t (Parameter t') y (Parameter y') yv
{- |
Since all 'Just' values must contain the same value,
we could also use the data structure '(Peano, a)'
just like in the @unique-logic@ package.
-}
newtype Parameter a = Parameter {parameterDesc :: [Maybe a]}

liftParam2 ::
   ([Maybe a] -> [Maybe b] -> [Maybe c]) ->
   Parameter a -> Parameter b -> Parameter c
liftParam2 f (Parameter x) (Parameter y) = Parameter (f x y)

cons :: ((t',y') -> SigP.T t (Parameter t') y (Parameter y') yv) -> T t t' y y' yv
cons = Cons


contextFixAmplitude ::
      y'
   -> Evaluated t t' y y' yv
   -> SigC.T y y' yv
contextFixAmplitude amp =
   SigC.replaceAmplitude amp . SigP.content

fromContextFreeAmplitude ::
      Parameter t'
   -> SigC.T y y' yv
   -> Evaluated t t' y y' yv
fromContextFreeAmplitude sr (SigC.Cons _amp ss) =
   SigP.cons sr anyParameter ss

fromContextCheckAmplitude :: (Eq y') =>
      Parameter t'
   -> y'
   -> SigC.T y y' yv
   -> Evaluated t t' y y' yv
fromContextCheckAmplitude sr iamp (SigC.Cons amp ss) =
   SigP.cons sr (justParameter amp)
      (if iamp==amp then ss else error "fromContextCheckAmplitude: amplitudes differ")


anyParameter :: Parameter q
anyParameter = Parameter []

justParameter :: q -> Parameter q
justParameter x = Parameter [Just x]

inSampleRate :: (t',y') -> t'
inSampleRate = fst

inAmplitude :: (t',y') -> y'
inAmplitude = snd



{-
vectorSamples :: (Eq t', Module.C y yv) =>
   (y' -> y) -> T t t' y y' yv -> (t' -> [yv])
vectorSamples toAmpScalar sig =
   \inferedSampleRate ->
      let x'   = eval sig (inferedSampleRate, amp')
          amp' = guessParameter
                    "vectorSamples: input amplitude"
                    (SigP.amplitude x')
          amp = toAmpScalar amp' `SigP.asTypeOfAmplitude` x'
      in  amp *> SigP.samples x'

scalarSamples :: (Eq t', Ring.C y) =>
   (y' -> y) -> T t t' y y' y -> (t' -> [y])
scalarSamples toAmpScalar sig =
   \inferedSampleRate ->
      let x'  = sig (inferParameter inferedSampleRate (SigP.sampleRate x'),
                     amp')
          amp' = fromMaybe (error "scalarSamples: undetermined input amplitude")
                           (SigP.amplitude x')
          amp = toAmpScalar amp' `SigP.asTypeOfAmplitude` x'
      in  map (amp*) (SigP.samples x')



inferParameter :: Eq q => q -> Maybe q -> q
inferParameter infered =
   maybe infered
      (\x -> if x == infered
               then x
               else error ("inferParameter:" ++
                           " requested value and infered one differ"))
-}

equalParameter :: Eq q => String -> Maybe q -> Maybe q -> Maybe q
equalParameter name x y =
   case (x,y) of
      (Nothing,_) -> y
      (_,Nothing) -> x
      (Just xv, Just yv) ->
         if xv == yv
           then Just xv
           else error ("equalParameter: " ++ name ++ " differ")

equalSampleRate :: Eq t' => Maybe t' -> Maybe t' -> Maybe t'
equalSampleRate = equalParameter "sample rate"


zipJut :: (a -> a -> a) -> [a] -> [a] -> [a]
zipJut f =
   let aux (x:xs) (y:ys) = f x y : aux xs ys
       aux []     ys     = ys
       aux xs     []     = xs
   in  aux

{-|
  Merge the @Just@s of two lists.
  It does not check for validity of the data.
-}
mergeParameter :: Parameter q -> Parameter q -> Parameter q
mergeParameter =
   liftParam2 (zipJut (\x y -> if isJust x then x else y))

mergeSampleRate ::
   Evaluated t t' y0 y0' yv0 -> Evaluated t t' y1 y1' yv1 -> Parameter t'
mergeSampleRate x y =
   mergeParameter (SigP.sampleRate x) (SigP.sampleRate y)


mergeParameterEq :: Eq q => String -> Parameter q -> Parameter q -> Parameter q
mergeParameterEq name =
   liftParam2 (zipJut (equalParameter name))

mergeSampleRateEq :: Eq t' => Parameter t' -> Parameter t' -> Parameter t'
mergeSampleRateEq = mergeParameterEq "sample rate"

-- cf. Examples.merge
merge :: [a] -> [a] -> [a]
merge (x:xs) ys = x : merge ys xs
merge []     ys = ys

propMerge :: Eq a => [a] -> [a] -> Bool
propMerge xs ys  =  merge xs ys == concat (transpose [xs,ys])

mergeParameter' :: Parameter t' -> Parameter t' -> Parameter t'
mergeParameter' = liftParam2 merge

checkParameter :: Eq q => String -> q -> Maybe q -> q
checkParameter name x =
   maybe x (\y -> if x == y
                    then x
                    else error ("checkParameter: deviation from common " ++ name))

checkSampleRate :: Eq t' => t' -> Maybe t' -> t'
checkSampleRate = checkParameter "sample rate"

checkAmplitude :: Eq y' => y' -> Maybe y' -> y'
checkAmplitude = checkParameter "amplitude"


{-|
  This routine is prepared for infinite lists.
  In order to handle them we employ a Cantor diagonalization scheme.
  It does not check for validity of the data
  (i.e. equal @Just@ values)
  but it does only keep some @Just@s,
  and thus allows for a quick search of a guess of a parameter value.
-}
mergeParameters :: [Parameter q] -> Parameter q
mergeParameters =
   Parameter . map (head . (++[Nothing]) . filter isJust)
      . shearTranspose . map parameterDesc

mergeSampleRates :: [Evaluated t t' y y' yv] -> Parameter t'
mergeSampleRates =
   mergeParameters . map SigP.sampleRate

mergeParametersEq :: Eq q => String -> [Parameter q] -> Parameter q
mergeParametersEq name =
   Parameter . map (foldl (equalParameter name) Nothing)
      . shearTranspose . map parameterDesc

mergeSampleRatesEq :: Eq t' => [Parameter t'] -> Parameter t'
mergeSampleRatesEq = mergeParametersEq "sample rate"

{- |
This is a simple working version of 'mergeParameters',
which does not need @Eq@ constraint.
However, flattening a three-dimensional list
does handle different dimensions differently,
that is slower than the others.
-}
mergeParameters' :: [Parameter q] -> Parameter q
mergeParameters' =
   Parameter . concat . shearTranspose . map parameterDesc


{-
equalParameters :: Eq q => String -> [Parameter q] -> Parameter q
equalParameters name xs =
   let cxs = catMaybes xs
   in  if and (zipWith (==) cxs (tail cxs))
         then listToMaybe cxs
         else error ("equalParameters: " ++ name ++ " differ")

equalSampleRates :: Eq t' => [Maybe t'] -> Maybe t'
equalSampleRates = equalParameters "sample rates"
-}

guessParameter :: String -> Parameter q -> q
guessParameter context =
   head . (++ error (context ++ " undetermined")) . catMaybes . parameterDesc

guessSampleRate :: Evaluated t t' y y' yv -> t'
guessSampleRate = guessParameter "sample rate" . SigP.sampleRate

guessAmplitude :: Evaluated t t' y y' yv -> y'
guessAmplitude = guessParameter "amplitude" . SigP.amplitude



{- |
  A complex signal graph can be built without ever mentioning a sampling rate.
  However when it comes to playing or writing a file,
  we must determine the sampling rate eventually.
  This function simply passes a signal through
  while forcing it to the given sampling rate.
-}
fixSampleRate :: (Eq t') =>
      t'                {-^ sample rate -}
   -> T t t' y y' yv    {-^ passed through signal -}
   -> T t t' y y' yv
fixSampleRate forcedSampleRate input =
   Cons $ \infered ->
      let inputSig = eval input infered
      in  SigP.cons
             (justParameter forcedSampleRate)
             (SigP.amplitude inputSig)
             (if inSampleRate infered == forcedSampleRate
                then SigP.samples inputSig
                else error "fixSampleRate: sampleRates differ")

-- ***** Is this one correct? Has the usage of 'infered' a cycle?
{- | Create a loop (feedback) from one node to another one.
     That is, compute the fix point of a process iteration. -}
loop :: (Eq t') =>
      (T t t' y y' yv -> T t t' y y' yv)
                        {-^ process chain that shall be looped -}
   ->  T t t' y y' yv
loop f =
   fix (\x -> f (Cons $ \infered ->
          SigP.cons anyParameter anyParameter
                    (SigP.samples (eval x infered))))

-- example: loop (\y -> x + delay y)