{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{- |
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.Storable.Signal as SigSt
import qualified Data.StorableVector.Lazy as Vector

import qualified Synthesizer.Plain.Modifier as Modifier

import qualified Algebra.NonNegative as NonNeg

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

import qualified Data.EventList.Relative.BodyTime as EventList

import qualified Numeric.NonNegative.Class as NonNeg98

import Foreign.Storable (Storable)

import Control.Monad.Trans.State (runState, runStateT, )
import Data.Monoid (Monoid, mappend, mempty, )

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

-- import NumericPrelude.Numeric
import qualified Prelude as P
import Prelude
   (Bool, Int, Maybe(Just), maybe, snd,
    (==), (<), (>), (<=), (>=),
    flip, uncurry, const, (.), ($), (&&), id, (++),
    fmap, return, error, show,
    Eq, Ord, Show, max, min, )


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
   foldR :: (y -> s -> s) -> s -> sig y -> s
   index :: sig y -> Int -> y

class (Read sig y, Cut.Transform (sig y)) => Transform sig y where
   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)

   {- |
   When using 'viewL' for traversing a signal,
   it is certainly better to convert to State signal first,
   since this might involve optimized traversing
   like in case of Storable signals.
   -}
   viewL :: sig y -> Maybe (y, sig y)
   viewR :: sig y -> Maybe (sig y, 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
   deriving (Eq, Ord, Show, Additive.C)

instance Monoid.C LazySize where
   idt = LazySize 0
   LazySize a <*> LazySize b = LazySize (a Additive.+ b)

instance NonNeg.C LazySize where
   split = NonNeg.splitDefault (\(LazySize n) -> n) LazySize

{- |
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 foldL #-}
   foldL = Vector.foldl
   {-# INLINE foldR #-}
   foldR = Vector.foldr
   {-# INLINE index #-}
   index = Vector.index

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 viewL #-}
   viewL = Vector.viewL
   {-# INLINE viewR #-}
   viewR = Vector.viewR

   {-# 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 foldL #-}
   foldL = List.foldl
   {-# INLINE foldR #-}
   foldR = List.foldr
   {-# INLINE index #-}
   index = (List.!!)

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

   {-# INLINE viewL #-}
   viewL = ListHT.viewL
   {-# INLINE viewR #-}
   viewR = ListHT.viewR

   {-# 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 SigS.T y where
   {-# INLINE toList #-}
   toList = SigS.toList
   {-# INLINE toState #-}
   toState = id
   {-# INLINE foldL #-}
   foldL = SigS.foldL
   {-# INLINE foldR #-}
   foldR = SigS.foldR
   {-# INLINE index #-}
   index = indexByDrop

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 viewL #-}
   viewL = SigS.viewL
   {-# INLINE viewR #-}
   viewR =
      -- This implementation is slow. Better leave it unimplemented?
      fmap (mapFst SigS.fromList) .
      ListHT.viewR . 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


instance (NonNeg98.C time, P.Integral time) =>
      Read (EventList.T time) y where
   {-# INLINE toList #-}
   toList =
      List.concatMap (uncurry (flip List.genericReplicate)) .
      EventList.toPairList
   {-# INLINE toState #-}
   toState = SigS.fromPiecewiseConstant
   {-# INLINE foldL #-}
   foldL f x = SigS.foldL f x . toState
   {-# INLINE foldR #-}
   foldR f x = SigS.foldR f x . toState
   {-# INLINE index #-}
   index sig n =
      EventList.foldrPair
         (\b t go k ->
            if k < t
              then b
              else go (t NonNeg98.-| k))
         (error $ "EventList.index: positions " ++ show n ++ " out of range")
         sig
         (P.fromIntegral n)

instance (NonNeg98.C time, P.Integral time) =>
      Transform (EventList.T time) y where
   {-# INLINE cons #-}
   cons b = EventList.cons b (P.fromInteger 1)
   {-# INLINE takeWhile #-}
   takeWhile p =
      EventList.foldrPair
         (\b t rest ->
            if p b
              then EventList.cons b t rest
              else EventList.empty)
         EventList.empty
   {-# INLINE dropWhile #-}
   dropWhile p =
      let recourse xs =
             flip (EventList.switchL EventList.empty) xs $ \b _t rest ->
             if p b
               then recourse rest
               else xs
      in  recourse
   {-# INLINE span #-}
   span p =
      let recourse xs =
             flip (EventList.switchL (EventList.empty,EventList.empty)) xs $ \b t rest ->
             if p b
               then mapFst (EventList.cons b t) $ recourse rest
               else (EventList.empty, xs)
      in  recourse

   {-# INLINE viewL #-}
   viewL xs = do
      ((b,t),ys) <- EventList.viewL xs
      if t>0
        then Just (b, if t==1 then ys else EventList.cons b (t NonNeg98.-|1) ys)
        else viewL ys
   {-# INLINE viewR #-}
   viewR =
      let dropTrailingZeros =
             EventList.foldrPair
                (\b t rest ->
                   if t==0 && EventList.null rest
                     then EventList.empty
                     else EventList.cons b t rest)
                EventList.empty
          recourse (b,t) =
             EventList.switchL
                (if t<=1
                   then EventList.empty
                   else EventList.singleton b (t NonNeg98.-| 1),
                 b)
                (\b0 t0 xs0 ->
                   mapFst (EventList.cons b t) $ recourse (b0,t0) xs0)
      in  fmap (uncurry recourse) . EventList.viewL . dropTrailingZeros

   {-# INLINE map #-}
   map = fmap
   {-# INLINE scanL #-}
   scanL f x =
      fromState (LazySize 1) . SigS.scanL f x . toState
   {-# INLINE crochetL #-}
   crochetL f x =
      fromState (LazySize 1) . SigS.crochetL f x . toState
   {-# INLINE zipWithAppend #-}
   zipWithAppend f =
      let recourse xs ys =
             flip (EventList.switchL ys) xs $ \x xn xs0 ->
             flip (EventList.switchL xs) ys $ \y yn ys0 ->
             let n = min xn yn
                 drop_ a an as0 =
                    if n>=an
                      then as0
                      else EventList.cons a (an NonNeg98.-| n) as0
             in  EventList.cons (f x y) n $
                 recourse
                    (drop_ x xn xs0)
                    (drop_ y yn ys0)
      in  recourse



instance (NonNeg98.C time, P.Integral time) => Write (EventList.T time) y where
   {-# INLINE fromList #-}
   fromList _ =
      EventList.fromPairList .
      List.map (flip (,) (P.fromInteger 1))
   {-# INLINE repeat #-}
   repeat (LazySize n) a =
      let xs = EventList.cons a (P.fromIntegral n) xs
      in  xs
   {-# INLINE replicate #-}
   replicate size m a =
      Cut.take m (repeat size a)
   {-# INLINE iterate #-}
   iterate size f =
      fromState size . SigS.iterate f
   {-# INLINE unfoldR #-}
   unfoldR _size f =
      let recourse =
             maybe EventList.empty
                (\(x,s) -> EventList.cons x
                   (P.fromInteger 1) (recourse s)) . f
      in  recourse
   {-# INLINE iterateAssociative #-}
   iterateAssociative size f x = iterate size (f x) x


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

{-# INLINE switchR #-}
switchR :: (Transform sig y) =>
   a -> (sig y -> y -> a) -> sig y -> a
switchR nothing just =
   maybe nothing (uncurry just) . viewR

{-# INLINE runViewL #-}
runViewL ::
   (Read sig y) =>
   sig y ->
   (forall s. (s -> Maybe (y, s)) -> s -> x) ->
   x
runViewL =
   SigS.runViewL . toState

{-# INLINE runSwitchL #-}
runSwitchL ::
   (Read sig y) =>
   sig y ->
   (forall s. (forall z. z -> (y -> s -> z) -> s -> z) -> s -> x) ->
   x
runSwitchL =
   SigS.runSwitchL . toState


{-# 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 =
   flip runViewL (\next ->
      crochetL
         (\x0 a0 ->
             do (y0,a1) <- next a0
                Just (h y0 x0, a1)))

{-# INLINE zipWithState #-}
zipWithState :: (Transform sig b) =>
   (a -> b -> b) -> SigS.T a -> sig b -> sig b
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) =>
   (a -> b -> c -> c) -> (SigS.T a -> SigS.T b -> sig c -> sig c)
zipWithState3 h a b =
   zipWithState ($) (SigS.zipWith h a b)

{-# 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 monoidConcatMap #-}
monoidConcatMap :: (Read sig a, Monoid m) => (a -> m) -> sig a -> m
monoidConcatMap f =
   foldR (mappend . f) mempty


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

{- |
Like 'tail', but for an empty signal it simply returns an empty signal.
-}
{-# INLINE laxTail #-}
laxTail :: (Transform sig y) => sig y -> sig y
laxTail xs =
   switchL xs (flip const) xs

{-# 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 =
   runViewL control (\next c0 ->
   crochetL
      (\x (acc0,cs0) ->
         do (c,cs1) <- next cs0
            let (y,acc1) = runState (proc c x) acc0
            return (y,(acc1,cs1)))
      (state, c0))
{-
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 ::
   (Transform 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 :: (Transform 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
-}


indexByDrop :: (Transform sig a) => sig a -> Int -> a
indexByDrop xs n =
   if n<0
     then error $ "Generic.index: negative index " ++ show n
     else switchL
             (error $ "Generic.index: index too large " ++ show n)
             const
             (Cut.drop n xs)


{-
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)
-}