Signal2.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{- |
Type class for several signal storage types
that allows alter element types.
There is some overlap between the two @Transform@ classes.
This was done in order to save us
from ubiquitous @Transform sig y y@ constraints.
-}
module Synthesizer.Generic.Signal2 where

import Synthesizer.Generic.Signal (Read, viewL, sum, )
import qualified Synthesizer.Generic.Signal as SigG

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

import qualified Synthesizer.State.Signal as SigS
import qualified Synthesizer.Plain.Signal as Sig
-- import qualified Synthesizer.Storable.Signal as SigSt
import qualified Data.StorableVector.Lazy as Vector

import qualified Synthesizer.Plain.Modifier as Modifier

import Foreign.Storable (Storable)

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

import qualified Data.List as List

import Data.Tuple.HT (fst3, snd3, thd3, )
import Prelude
   (Bool, Int, Maybe(Just), maybe, fst, snd,
    flip, ($), (.),
    return, )


class (SigG.Transform sig y0, SigG.Transform sig y1) =>
          Transform sig y0 y1 where
   map :: (y0 -> y1) -> (sig y0 -> sig y1)
   scanL :: (y1 -> y0 -> y1) -> y1 -> sig y0 -> sig y1
   crochetL :: (y0 -> s -> Maybe (y1, s)) -> s -> sig y0 -> sig y1


instance (Storable y0, Storable y1) => Transform Vector.Vector y0 y1 where
   {-# INLINE map #-}
   map = Vector.map
   {-# INLINE scanL #-}
   scanL = Vector.scanl
   {-# INLINE crochetL #-}
   crochetL = Vector.crochetL


instance Transform [] y0 y1 where
   {-# INLINE map #-}
   map = List.map
   {-# INLINE scanL #-}
   scanL = List.scanl
   {-# INLINE crochetL #-}
   crochetL = Sig.crochetL


instance Transform SigS.T y0 y1 where
   {-# INLINE map #-}
   map = SigS.map
   {-# INLINE scanL #-}
   scanL = SigS.scanL
   {-# INLINE crochetL #-}
   crochetL = SigS.crochetL


{-# INLINE zipWith #-}
zipWith :: (Read sig a, Transform sig b c) =>
   (a -> b -> c) -> (sig a -> sig b -> sig c)
zipWith h =
   zipWithState h . SigG.toState

{-# INLINE mapAdjacent #-}
mapAdjacent :: (Transform sig a b) =>
   (a -> a -> b) -> sig a -> sig b
mapAdjacent f xs0 =
   let xs1 = maybe xs0 snd (viewL xs0)
   in  zipWith f xs0 xs1


{-# INLINE zip #-}
zip :: (Read sig a, Transform sig b (a,b)) =>
   sig a -> sig b -> sig (a,b)
zip = zipWith (,)


{-# INLINE zipWith3 #-}
zipWith3 :: (Read sig a, Read sig b, Transform sig c d) =>
   (a -> b -> c -> d) -> (sig a -> sig b -> sig c -> sig d)
zipWith3 h a b =
   zipWithState3 h
      (SigG.toState a)
      (SigG.toState b)

{-# INLINE zip3 #-}
zip3 :: (Read sig a, Read sig b, Transform sig c (a,b,c)) =>
   sig a -> sig b -> sig c -> sig (a,b,c)
zip3 = zipWith3 (,,)


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

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



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

{-| Here the control may vary over the time. -}
{-# INLINE modifyModulated #-}
modifyModulated :: (Transform sig a b, Read sig ctrl) =>
   Modifier.Simple s ctrl a b -> sig ctrl -> sig a -> sig b
modifyModulated (Modifier.Simple state proc) control =
   SigG.runViewL control (\next s0 ->
   crochetL
      (\x (acc0,cs0) ->
         do (c,cs1) <- next cs0
            let (y,acc1) = runState (proc c x) acc0
            return (y,(acc1,cs1)))
      (state, s0))

linearComb ::
   (Module.C t y, Read sig t, Transform sig y y) =>
   sig t -> sig y -> y
linearComb ts ys =
   sum (zipWith (Module.*>) ts ys)

mapTails :: (Transform sig a b) =>
   (sig a -> b) -> sig a -> sig b
mapTails f x =
   crochetL (\_ xs0 ->
      do (_,xs1) <- viewL xs0
         Just (f xs0, xs1))
      x x

{-# INLINE zipWithTails #-}
zipWithTails :: (SigG.Transform sig b, Transform sig a c) =>
   (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)))

{-# INLINE zipWith2Tails #-}
zipWith2Tails :: (SigG.Transform sig b, SigG.Transform sig c, Transform sig a d) =>
   (a -> sig b -> sig c -> d) -> sig a -> sig b -> sig c -> sig d
zipWith2Tails f as bs cs =
   crochetL (\x (ys0,zs0) ->
      do (_,ys1) <- viewL ys0
         (_,zs1) <- viewL zs0
         Just (f x ys0 zs0, (ys1,zs1)))
      (bs,cs) as

{-# INLINE zipWithState #-}
zipWithState :: (Transform sig b c) =>
   (a -> b -> c) -> SigS.T a -> sig b -> sig c
zipWithState f =
   flip SigS.runViewL (\next ->
   crochetL (\b as0 ->
      do (a,as1) <- next as0
         Just (f a b, as1)))

{-# INLINE zipWithState3 #-}
zipWithState3 :: (Transform sig c d) =>
   (a -> b -> c -> d) -> (SigS.T a -> SigS.T b -> sig c -> sig d)
zipWithState3 h a b =
   zipWithState ($) (SigS.zipWith h a b)