{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{- |
Type classes that give a uniform interface to
storable signals, stateful signals, lists, fusable lists.
Some of the signal types require constraints on the element type.
Storable signals require Storable elements.
Thus we need multiparameter type classes.
In this module we collect functions
where the element type is not altered by the function.
-}
module Synthesizer.Generic.Signal
   (module Synthesizer.Generic.Signal,
    Cut.null,
    Cut.length,
    Cut.empty,
    Cut.cycle,
    Cut.append,
    Cut.concat,
    Cut.take,
    Cut.drop,
    Cut.dropMarginRem,
    Cut.splitAt,
    Cut.reverse,
    Cut.lengthAtLeast,
    Cut.lengthAtMost,
    Cut.sliceVertical,
   ) where

import Synthesizer.Generic.Cut (append, )
import qualified Synthesizer.Generic.Cut as Cut

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

import qualified Synthesizer.Plain.Modifier as Modifier

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

import Foreign.Storable (Storable)

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

import Data.Function (fix, )
import qualified Data.List.HT as ListHT
import qualified Data.List as List
import Data.Tuple.HT (mapPair, mapFst, )

import Prelude
   (Bool, Int, Maybe(Just), maybe, snd,
    flip, uncurry, (.), ($), id,
    fmap, return, )


class Cut.Read (sig y) => Read sig y where
   toList :: sig y -> [y]
   toState :: sig y -> SigS.T y
--   toState :: StateT (sig y) Maybe y
   foldL :: (s -> y -> s) -> s -> sig y -> s
-- better move to Transform class?
   viewL :: sig y -> Maybe (y, sig y)
   viewR :: sig y -> Maybe (sig y, y)

class (Read sig y, Cut.Transform (sig y)) => Transform sig y where
   {- |
   This function belongs logically to the Write class,
   but since an empty signal contains no data,
   the maximum package size is irrelevant.
   This makes e.g. the definition of mixMulti more general.
   -}
   cons :: y -> sig y -> sig y
   takeWhile :: (y -> Bool) -> sig y -> sig y
   dropWhile :: (y -> Bool) -> sig y -> sig y
   span :: (y -> Bool) -> sig y -> (sig y, sig y)
   -- functions from Transform2 that are oftenly used with only one type variable
   map :: (y -> y) -> (sig y -> sig y)
   scanL :: (y -> y -> y) -> y -> sig y -> sig y
   crochetL :: (y -> s -> Maybe (y, s)) -> s -> sig y -> sig y
   zipWithAppend :: (y -> y -> y) -> sig y -> sig y -> sig y


{- |
This type is used for specification of the maximum size of strict packets.
Packets can be smaller, can have different sizes in one signal.
In some kinds of streams, like lists and stateful generators,
the packet size is always 1.
The packet size is not just a burden caused by efficiency,
but we need control over packet size in applications with feedback.
-}
newtype LazySize = LazySize Int

{- |
This can be used for internal signals
that have no observable effect on laziness.
E.g. when you construct a list
by @repeat defaultLazySize zero@
we assume that 'zero' is defined for all Additive types.
-}
defaultLazySize :: LazySize
defaultLazySize =
   let (Vector.ChunkSize size) = Vector.defaultChunkSize
   in  LazySize size

{- |
We could provide the 'LazySize' by a Reader monad,
but we don't do that because we expect that the choice of the lazy size
is more local than say the choice of the sample rate.
E.g. there is no need to have the same laziness coarseness
for multiple signal processors.
-}
class Transform sig y => Write sig y where
   fromList :: LazySize -> [y] -> sig y
--   fromState :: LazySize -> SigS.T y -> sig y
--   fromState :: LazySize -> StateT s Maybe y -> s -> sig y
   repeat :: LazySize -> y -> sig y
   replicate :: LazySize -> Int -> y -> sig y
   iterate :: LazySize -> (y -> y) -> y -> sig y
   iterateAssociative :: LazySize -> (y -> y -> y) -> y -> sig y
   unfoldR :: LazySize -> (s -> Maybe (y,s)) -> s -> sig y


-- instance Storable y => Read SigSt.T y where
instance Storable y => Read Vector.Vector y where
   {-# INLINE toList #-}
   toList = Vector.unpack
   {-# INLINE toState #-}
   toState = SigS.fromStorableSignal
   {-# INLINE viewL #-}
   viewL = Vector.viewL
   {-# INLINE viewR #-}
   viewR = Vector.viewR
   {-# INLINE foldL #-}
   foldL = Vector.foldl

instance Storable y => Transform Vector.Vector y where
   {-# INLINE cons #-}
   cons = Vector.cons
   {-# INLINE takeWhile #-}
   takeWhile = Vector.takeWhile
   {-# INLINE dropWhile #-}
   dropWhile = Vector.dropWhile
   {-# INLINE span #-}
   span = Vector.span

   {-# INLINE map #-}
   map = Vector.map
   {-# INLINE scanL #-}
   scanL = Vector.scanl
   {-# INLINE crochetL #-}
   crochetL = Vector.crochetL
   {-# INLINE zipWithAppend #-}
   zipWithAppend = SigSt.zipWithAppend



withStorableContext ::
   (Vector.ChunkSize -> a) -> (LazySize -> a)
withStorableContext f =
   \(LazySize size) -> f (Vector.ChunkSize size)

instance Storable y => Write Vector.Vector y where
   {-# INLINE fromList #-}
   fromList = withStorableContext $ \size -> Vector.pack size
   {-# INLINE repeat #-}
   repeat = withStorableContext $ \size -> Vector.repeat size
   {-# INLINE replicate #-}
   replicate = withStorableContext $ \size -> Vector.replicate size
   {-# INLINE iterate #-}
   iterate = withStorableContext $ \size -> Vector.iterate size
   {-# INLINE unfoldR #-}
   unfoldR = withStorableContext $ \size -> Vector.unfoldr size
   {-# INLINE iterateAssociative #-}
   iterateAssociative = withStorableContext $ \size op x -> Vector.iterate size (op x) x -- should be optimized



instance Read [] y where
   {-# INLINE toList #-}
   toList = id
   {-# INLINE toState #-}
   toState = SigS.fromList
   {-# INLINE viewL #-}
   viewL = ListHT.viewL
   {-# INLINE viewR #-}
   viewR = ListHT.viewR
   {-# INLINE foldL #-}
   foldL = List.foldl

instance Transform [] y where
   {-# INLINE cons #-}
   cons = (:)
   {-# INLINE takeWhile #-}
   takeWhile = List.takeWhile
   {-# INLINE dropWhile #-}
   dropWhile = List.dropWhile
   {-# INLINE span #-}
   span = List.span

   {-# INLINE map #-}
   map = List.map
   {-# INLINE scanL #-}
   scanL = List.scanl
   {-# INLINE crochetL #-}
   crochetL = Sig.crochetL
   {-# INLINE zipWithAppend #-}
   zipWithAppend = Sig.zipWithAppend


instance Write [] y where
   {-# INLINE fromList #-}
   fromList _ = id
   {-# INLINE repeat #-}
   repeat _ = List.repeat
   {-# INLINE replicate #-}
   replicate _ = List.replicate
   {-# INLINE iterate #-}
   iterate _ = List.iterate
   {-# INLINE unfoldR #-}
   unfoldR _ = List.unfoldr
   {-# INLINE iterateAssociative #-}
   iterateAssociative _ = ListHT.iterateAssociative



instance Read SigFL.T y where
   {-# INLINE toList #-}
   toList = SigFL.toList
   {-# INLINE toState #-}
   toState = SigS.fromList . SigFL.toList
   {-# INLINE viewL #-}
   viewL = SigFL.viewL
   {-# INLINE viewR #-}
   viewR = SigFL.viewR
   {-# INLINE foldL #-}
   foldL = SigFL.foldL

instance Transform SigFL.T y where
   {-# INLINE cons #-}
   cons = SigFL.cons
   {-# INLINE takeWhile #-}
   takeWhile = SigFL.takeWhile
   {-# INLINE dropWhile #-}
   dropWhile = SigFL.dropWhile
   {-# INLINE span #-}
   span = SigFL.span

   {-# INLINE map #-}
   map = SigFL.map
   {-# INLINE scanL #-}
   scanL = SigFL.scanL
   {-# INLINE crochetL #-}
   crochetL = SigFL.crochetL
   {-# INLINE zipWithAppend #-}
   zipWithAppend = SigFL.zipWithAppend


instance Write SigFL.T y where
   {-# INLINE fromList #-}
   fromList _ = SigFL.fromList
   {-# INLINE repeat #-}
   repeat _ = SigFL.repeat
   {-# INLINE replicate #-}
   replicate _ = SigFL.replicate
   {-# INLINE iterate #-}
   iterate _ = SigFL.iterate
   {-# INLINE unfoldR #-}
   unfoldR _ = SigFL.unfoldR
   {-# INLINE iterateAssociative #-}
   iterateAssociative _ = SigFL.iterateAssociative



instance Read SigS.T y where
   {-# INLINE toList #-}
   toList = SigS.toList
   {-# INLINE toState #-}
   toState = id
   {-# INLINE viewL #-}
   viewL = SigS.viewL
   {-# INLINE viewR #-}
   viewR =
      -- This implementation is slow. Better leave it unimplemented?
      fmap (mapFst SigS.fromList) .
      ListHT.viewR . SigS.toList
   {-# INLINE foldL #-}
   foldL = SigS.foldL

instance Transform SigS.T y where
   {-# INLINE cons #-}
   cons = SigS.cons
   {-# INLINE takeWhile #-}
   takeWhile = SigS.takeWhile
   {-# INLINE dropWhile #-}
   dropWhile = SigS.dropWhile
   {-# INLINE span #-}
   span p =
      -- This implementation is slow. Better leave it unimplemented?
      mapPair (SigS.fromList, SigS.fromList) .
      List.span p . SigS.toList

   {-# INLINE map #-}
   map = SigS.map
   {-# INLINE scanL #-}
   scanL = SigS.scanL
   {-# INLINE crochetL #-}
   crochetL = SigS.crochetL
   {-# INLINE zipWithAppend #-}
   zipWithAppend = SigS.zipWithAppend


instance Write SigS.T y where
   {-# INLINE fromList #-}
   fromList _ = SigS.fromList
   {-# INLINE repeat #-}
   repeat _ = SigS.repeat
   {-# INLINE replicate #-}
   replicate _ = SigS.replicate
   {-# INLINE iterate #-}
   iterate _ = SigS.iterate
   {-# INLINE unfoldR #-}
   unfoldR _ = SigS.unfoldR
   {-# INLINE iterateAssociative #-}
   iterateAssociative _ = SigS.iterateAssociative



{-# INLINE switchL #-}
switchL :: (Read sig y) =>
   a -> (y -> sig y -> a) -> sig y -> a
switchL nothing just =
   maybe nothing (uncurry just) . viewL

{-# INLINE mix #-}
mix :: (Additive.C y, Transform sig y) =>
   sig y -> sig y -> sig y
mix = zipWithAppend (Additive.+)

{-# INLINE zipWith #-}
zipWith :: (Read sig a, Transform sig b) =>
   (a -> b -> b) -> (sig a -> sig b -> sig b)
zipWith h a =
   crochetL
      (\x0 a0 ->
          do (y0,a1) <- viewL a0
             Just (h y0 x0, a1))
      a


{-# INLINE delay #-}
delay :: (Write sig y) =>
   LazySize -> y -> Int -> sig y -> sig y
delay size z n =
   append (replicate size n z)

{-# INLINE delayLoop #-}
delayLoop ::
   (Transform sig y) =>
      (sig y -> sig y)
            -- ^ processor that shall be run in a feedback loop
   -> sig y -- ^ prefix of the output, its length determines the delay
   -> sig y
delayLoop proc prefix =
   fix (append prefix . proc)


{-# INLINE delayLoopOverlap #-}
delayLoopOverlap ::
   (Additive.C y, Write sig y) =>
      Int
   -> (sig y -> sig y)
            {- ^ Processor that shall be run in a feedback loop.
                 It's absolutely necessary that this function preserves the chunk structure
                 and that it does not look a chunk ahead.
                 That's guaranteed for processes that do not look ahead at all,
                 like 'Vector.map', 'Vector.crochetL' and
                 all of type @Causal.Process@. -}
   -> sig y -- ^ input
   -> sig y -- ^ output has the same length as the input
delayLoopOverlap time proc xs =
   fix (zipWith (Additive.+) xs .
        delay defaultLazySize Additive.zero time . proc)



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

{-# INLINE tails #-}
tails :: (Transform sig y) => sig y -> SigS.T (sig y)
tails =
   SigS.unfoldR (fmap (\x -> (x, fmap snd (viewL x)))) . Just

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

{-# INLINE modifyStatic #-}
modifyStatic :: (Transform sig a) =>
   Modifier.Simple s ctrl a a -> ctrl -> sig a -> sig a
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, Read sig ctrl) =>
   Modifier.Simple s ctrl a a -> sig ctrl -> sig a -> sig a
modifyModulated (Modifier.Simple state proc) control =
   crochetL
      (\x (acc0,cs0) ->
         do (c,cs1) <- viewL cs0
            let (y,acc1) = runState (proc c x) acc0
            return (y,(acc1,cs1)))
      (state,control)
{-
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, Read sig t, Read sig y) =>
   sig t -> sig y -> y
linearComb ts ys =
   SigS.sum (SigS.zipWith (Module.*>) (toState ts) (toState ys))


fromState :: (Write sig y) =>
   LazySize -> SigS.T y -> sig y
fromState size (SigS.Cons f x) =
   unfoldR size (runStateT f) x

{-# INLINE extendConstant #-}
extendConstant :: (Write sig y) =>
   LazySize -> sig y -> sig y
extendConstant size xt =
   maybe
      xt
      (append xt . repeat size . snd)
      (viewR xt)


-- comonadic 'bind'
-- only non-empty suffixes are processed
{-# INLINE mapTails #-}
mapTails :: (Transform sig a) =>
   (sig a -> a) -> sig a -> sig a
mapTails f x =
   crochetL (\_ xs0 ->
      do (_,xs1) <- viewL xs0
         Just (f xs0, xs1))
      x x
{-
Implementation with unfoldR is more natural,
but it could not preserve the chunk structure of the input signal.
Thus we prefer crochetL, although we do not consume single elements of the input signal.
-}
mapTailsAlt ::
   (Read sig a, Write sig b) =>
   LazySize -> (sig a -> b) -> sig a -> sig b
mapTailsAlt size f =
   unfoldR size (\xs ->
      do (_,ys) <- viewL xs
         Just (f xs, ys))

{- |
Only non-empty suffixes are processed.
More oftenly we might need

> zipWithTails :: (Read sig b, Transform2 sig a) =>
>    (b -> sig a -> a) -> sig b -> sig a -> sig a

this would preserve the chunk structure of @sig a@,
but it is a bit more hassle to implement that.
-}
{-# INLINE zipWithTails #-}
zipWithTails :: (Read sig b, Transform sig a) =>
   (a -> sig b -> a) -> sig a -> sig b -> sig a
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)
-}