Signal.hs

{- OPTIONS_GHC -fglasgow-exts -}
{-
Unfortunately we have to use the SampledValue constraint also for lists,
which means that we can only use Storable values for signals.
Maybe we can improve this situation using associated types.
-}
module Synthesizer.Generic.Signal where

import qualified Algebra.Module   as Module
import qualified Algebra.Additive as Additive

import qualified Synthesizer.Generic.SampledValue as Sample

import qualified Synthesizer.Plain.Modifier as Modifier

import Control.Monad.State (State, runState, )

import qualified Data.List as List

import Synthesizer.Utility (fst3, snd3, thd3)
import Prelude
   (Bool, Int, Maybe(Just), maybe,
    fst, snd, flip, uncurry, (.), not, )


class C sig where
   empty :: (Sample.C y) => sig y
   null :: (Sample.C y) => sig y -> Bool
   cons :: (Sample.C y) => y -> sig y -> sig y
   fromList :: (Sample.C y) => [y] -> sig y
   toList :: (Sample.C y) => sig y -> [y]
   repeat :: (Sample.C y) => y -> sig y
   cycle :: (Sample.C y) => sig y -> sig y
   replicate :: (Sample.C y) => Int -> y -> sig y
   iterate :: (Sample.C y) => (y -> y) -> y -> sig y
   iterateAssoc :: (Sample.C y) => (y -> y -> y) -> y -> sig y
   unfoldR :: (Sample.C b) => (a -> Maybe (b,a)) -> a -> sig b
   map :: (Sample.C a, Sample.C b) => (a -> b) -> (sig a -> sig b)
   mix :: (Sample.C y, Additive.C y) => sig y -> sig y -> sig y
   zipWith :: (Sample.C a, Sample.C b, Sample.C c) =>
      (a -> b -> c) -> (sig a -> sig b -> sig c)
{-
   zipWithTails :: (Sample.C a, Sample.C b, Sample.C c) =>
      (a -> T b -> c) -> T a -> T b -> T c
-}
   scanL :: (Sample.C a, Sample.C b) =>
      (a -> b -> a) -> a -> sig b -> sig a
   foldL :: (Sample.C b) => (a -> b -> a) -> a -> sig b -> a
   viewL :: (Sample.C a) => sig a -> Maybe (a, sig a)
   viewR :: (Sample.C a) => sig a -> Maybe (sig a, a)
   length :: (Sample.C y) => sig y -> Int
   take :: (Sample.C y) => Int -> sig y -> sig y
   drop :: (Sample.C y) => Int -> sig y -> sig y
   dropMarginRem :: (Sample.C y) => Int -> Int -> sig y -> (Int, sig y)
   splitAt :: (Sample.C y) => Int -> sig y -> (sig y, sig y)
   takeWhile :: (Sample.C y) => (y -> Bool) -> sig y -> sig y
   dropWhile :: (Sample.C y) => (y -> Bool) -> sig y -> sig y
   span :: (Sample.C y) => (y -> Bool) -> sig y -> (sig y, sig y)
   append :: (Sample.C y) => sig y -> sig y -> sig y
   concat :: (Sample.C y) => [sig y] -> sig y
   reverse :: (Sample.C y) => sig y -> sig y
{-
   mapAccumL :: (Sample.C x, Sample.C y) =>
      (acc -> x -> (acc, y)) -> acc -> sig x -> (acc, sig y)
   mapAccumR :: (Sample.C x, Sample.C y) =>
      (acc -> x -> (acc, y)) -> acc -> sig x -> (acc, sig y)
-}
   crochetL :: (Sample.C x, Sample.C y) =>
      (x -> acc -> Maybe (y, acc)) -> acc -> sig x -> sig y


{-# INLINE sum #-}
sum :: (Additive.C a, Sample.C a, C sig) => sig a -> a
sum = foldL (Additive.+) Additive.zero

{-
{-# INLINE tails #-}
tails :: (Sample.C y, C sig) => sig y -> [sig y]
tails =
   List.unfoldr (fmap (\x -> (x, fmap snd (viewL x)))) . Just
-}

{-# INLINE zapWith #-}
zapWith :: (Sample.C a, Sample.C b, C sig) =>
   (a -> a -> b) -> sig a -> sig b
zapWith f xs0 =
   let xs1 = maybe empty snd (viewL xs0)
   in  zipWith f xs0 xs1

{-# INLINE zip #-}
zip :: (Sample.C a, Sample.C b, C sig) =>
   sig a -> sig b -> sig (a,b)
zip = zipWith (,)


{-# INLINE unzip #-}
unzip :: (Sample.C a, Sample.C b, C sig) =>
   sig (a,b) -> (sig a, sig b)
unzip xs =
   (map fst xs, map snd xs)

{-# INLINE unzip3 #-}
unzip3 :: (Sample.C a, Sample.C b, Sample.C c, C sig) =>
   sig (a,b,c) -> (sig a, sig b, sig c)
unzip3 xs =
   (map fst3 xs, map snd3 xs, map thd3 xs)


{-# INLINE modifyStatic #-}
modifyStatic :: (Sample.C a, Sample.C b, C sig) =>
   Modifier.Simple s ctrl a b -> ctrl -> sig a -> sig b
modifyStatic (Modifier.Simple state proc) control x =
   crochetL (\a acc -> Just (runState (proc control a) acc)) state x

{-| Here the control may vary over the time. -}
{-# INLINE modifyModulated #-}
modifyModulated :: (Sample.C a, Sample.C b, Sample.C ctrl, C sig) =>
   Modifier.Simple s ctrl a b -> sig ctrl -> sig a -> sig b
modifyModulated (Modifier.Simple state proc) control x =
   crochetL
      (\ca acc -> Just (runState (uncurry proc ca) acc))
      state (zip control x)


-- cf. Module.linearComb
{-# INLINE linearComb #-}
linearComb ::
   (Module.C t y, Sample.C t, Sample.C y, C sig) =>
   sig t -> sig y -> y
linearComb ts ys =
   sum (zipWith (Module.*>) ts ys)


{-# INLINE sliceVert #-}
sliceVert :: (Sample.C y, C sig) =>
   Int -> sig y -> [sig y]
sliceVert n =
   List.map (take n) . List.takeWhile (not . null) . List.iterate (drop n)


{-# INLINE extendConstant #-}
extendConstant :: (Sample.C y, C sig) =>
   sig y -> sig y
extendConstant xt =
   maybe empty
      (append xt . repeat . snd)
      (viewR xt)


-- comonadic 'bind'
-- only non-empty suffixes are processed
{-# INLINE mapTails #-}
mapTails :: (Sample.C a, Sample.C b, C sig) =>
   (sig a -> b) -> sig a -> sig b
mapTails f =
   unfoldR (\xs ->
      do (_,ys) <- viewL xs
         Just (f xs, ys))

-- only non-empty suffixes are processed
{-# INLINE zipWithTails #-}
zipWithTails :: (Sample.C a, Sample.C b, Sample.C c, C sig) =>
   (a -> sig b -> c) -> sig a -> sig b -> sig c
zipWithTails f =
   flip (crochetL (\x ys0 ->
      do (_,ys) <- viewL ys0
         Just (f x ys0, ys)))


{-
instance (Additive.C y, Sample.C y, C sig) => Additive.C (sig y) where
   (+) = mix
   negate = map Additive.negate
-}


{-
This does not work, because we can constrain only the instances of Data
but this is not checked when implementing methods of C.

class Data sig y where

class C sig where
   add :: (Data sig y, Additive.C y) => sig y -> sig y -> sig y
   map :: (Data sig a, Data sig b) => (a -> b) -> (sig a -> sig b)
   zipWith :: (Data sig a, Data sig b, Data sig c) =>
                  (a -> b -> c) -> (sig a -> sig b -> sig c)
-}

{-
This does not work, because we would need type parameters for all occuring element types.

class C sig y where
   add :: (Additive.C y) => sig y -> sig y -> sig y
   map :: C sig a => (a -> y) -> (sig a -> sig y)
   zipWith :: (a -> b -> y) -> (sig a -> sig b -> sig y)
-}