module Synthesizer.Storable.Cut (
   arrange,

   -- for MIDI.CausalIO.Process
   addChunkToBuffer,

   -- for testing
   arrangeEquidist,
   arrangeAdaptive,
   arrangeList,
   ) where

import qualified Synthesizer.Storable.Signal as Sig

import qualified Data.StorableVector           as SV
import qualified Data.StorableVector.Lazy      as SVL
import qualified Data.StorableVector.ST.Strict as SVST
import Foreign.Storable (Storable)

import Control.Monad.ST.Strict (ST, runST, )
import Control.Monad.Trans.State (runState, modify, gets, put, )

import qualified Data.EventList.Relative.TimeBody  as EventList
import qualified Data.EventList.Relative.TimeMixed as EventListTM
import qualified Data.EventList.Absolute.TimeBody  as AbsEventList
import Data.Tuple.HT (mapSnd, )

import qualified Algebra.Additive as Additive
import qualified Number.NonNegative as NonNeg

import NumericPrelude.Numeric
import NumericPrelude.Base
import Prelude ()


{-# INLINE arrange #-}
arrange :: (Storable v, Additive.C v) =>
       Sig.ChunkSize
    -> EventList.T NonNeg.Int (Sig.T v)
            {-^ A list of pairs: (relative start time, signal part),
                The start time is relative to the start time
                of the previous event. -}
    -> Sig.T v
            {-^ The mixed signal. -}
arrange :: forall v. (Storable v, C v) => ChunkSize -> T Int (T v) -> T v
arrange =
   forall v. (Storable v, C v) => ChunkSize -> T Int (T v) -> T v
arrangeEquidist

{- |
Chunk sizes are adapted to the time differences.
Explicit ChunkSize parameter is only required for zero padding.
Since no ST monad is needed, this can be generalized to Generic.Signal.Transform class.
-}
arrangeAdaptive :: (Storable v, Additive.C v) =>
       Sig.ChunkSize
    -> EventList.T NonNeg.Int (Sig.T v)
            {-^ A list of pairs: (relative start time, signal part),
                The start time is relative to the start time
                of the previous event. -}
    -> Sig.T v
            {-^ The mixed signal. -}
arrangeAdaptive :: forall v. (Storable v, C v) => ChunkSize -> T Int (T v) -> T v
arrangeAdaptive ChunkSize
size =
   forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Storable a => Vector a -> Vector a -> Vector a
Sig.append forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> (a, s)
runState forall a. Storable a => Vector a
Sig.empty forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Storable a => [Vector a] -> Vector a
Sig.concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall time body. T time body -> [time]
EventList.getTimes) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall (m :: * -> *) time0 time1 body0 body1.
Monad m =>
(time0 -> m time1)
-> (body0 -> m body1) -> T time0 body0 -> m (T time1 body1)
EventList.mapM
      (\Int
timeNN ->
           let time :: Int
time = forall a. T a -> a
NonNeg.toNumber Int
timeNN
           in  do (Vector v
prefix,Vector v
suffix) <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (forall x.
(C x, Storable x) =>
ChunkSize -> Int -> T x -> (T x, T x)
Sig.splitAtPad ChunkSize
size Int
time)
                  forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Vector v
suffix
                  forall (m :: * -> *) a. Monad m => a -> m a
return Vector v
prefix)
      (\Vector v
body ->
           forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (forall x. (C x, Storable x) => T x -> T x -> T x
Sig.mixSndPattern Vector v
body))


{- |
This function also uses the time differences as chunk sizes,
but may occasionally use smaller chunk sizes due to the chunk structure
of an input signal until the next signal starts.
-}
arrangeList :: (Storable v, Additive.C v) =>
       Sig.ChunkSize
    -> EventList.T NonNeg.Int (Sig.T v)
            {-^ A list of pairs: (relative start time, signal part),
                The start time is relative to the start time
                of the previous event. -}
    -> Sig.T v
            {-^ The mixed signal. -}
arrangeList :: forall v. (Storable v, C v) => ChunkSize -> T Int (T v) -> T v
arrangeList ChunkSize
size T Int (T v)
evs =
   let xs :: [T v]
xs = forall time body. T time body -> [body]
EventList.getBodies T Int (T v)
evs
   in  case forall time body. T time body -> [time]
EventList.getTimes T Int (T v)
evs of
          Int
t:[Int]
ts -> forall a. Storable a => ChunkSize -> Int -> a -> Vector a
Sig.replicate ChunkSize
size (forall a. T a -> a
NonNeg.toNumber Int
t) forall a. C a => a
zero forall a. Storable a => Vector a -> Vector a -> Vector a
`Sig.append`
                  forall a. (Storable a, C a) => ChunkSize -> [Int] -> [T a] -> T a
addShiftedMany ChunkSize
size [Int]
ts [T v]
xs
          []   -> forall a. Storable a => Vector a
Sig.empty


addShiftedMany :: (Storable a, Additive.C a) =>
   Sig.ChunkSize -> [NonNeg.Int] -> [Sig.T a] -> Sig.T a
addShiftedMany :: forall a. (Storable a, C a) => ChunkSize -> [Int] -> [T a] -> T a
addShiftedMany ChunkSize
size [Int]
ds [T a]
xss =
   forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall a.
(Storable a, C a) =>
ChunkSize -> Int -> T a -> T a -> T a
addShifted ChunkSize
size)) forall a. Storable a => Vector a
Sig.empty (forall a b. [a] -> [b] -> [(a, b)]
zip ([Int]
dsforall a. [a] -> [a] -> [a]
++[Int
0]) [T a]
xss)


{-
It is crucial that 'mix' uses the chunk size structure of the second operand.
This way we avoid unnecessary and even infinite look-ahead.
-}
addShifted :: (Storable a, Additive.C a) =>
   Sig.ChunkSize -> NonNeg.Int -> Sig.T a -> Sig.T a -> Sig.T a
addShifted :: forall a.
(Storable a, C a) =>
ChunkSize -> Int -> T a -> T a -> T a
addShifted ChunkSize
size Int
delNN T a
px T a
py =
   let del :: Int
del = forall a. T a -> a
NonNeg.toNumber Int
delNN
   in  forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Storable a => Vector a -> Vector a -> Vector a
Sig.append forall a b. (a -> b) -> a -> b
$
       forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall x. (C x, Storable x) => T x -> T x -> T x
Sig.mixSndPattern T a
py) forall a b. (a -> b) -> a -> b
$
       forall x.
(C x, Storable x) =>
ChunkSize -> Int -> T x -> (T x, T x)
Sig.splitAtPad ChunkSize
size Int
del T a
px


{-
arrangeEquidist (Sig.chunkSize 2) (EventList.fromPairList [(10, SVL.pack SVL.defaultChunkSize [1..8::Double]), (2, SVL.pack (Sig.chunkSize 2) $ [4,3,2,1::Double] ++ undefined)])
-}
{- |
The result is a Lazy StorableVector with chunks of the given size.
-}
{-# INLINE arrangeEquidist #-}
arrangeEquidist :: (Storable v, Additive.C v) =>
       Sig.ChunkSize
    -> EventList.T NonNeg.Int (Sig.T v)
            {-^ A list of pairs: (relative start time, signal part),
                The start time is relative to the start time
                of the previous event. -}
    -> Sig.T v
            {-^ The mixed signal. -}
arrangeEquidist :: forall v. (Storable v, C v) => ChunkSize -> T Int (T v) -> T v
arrangeEquidist (SVL.ChunkSize Int
sz) =
   let sznn :: Int
sznn = forall a. (Ord a, C a) => String -> a -> T a
NonNeg.fromNumberMsg String
"arrangeEquidist" Int
sz
       go :: [Vector a] -> T Int (Vector a) -> [Vector a]
go [Vector a]
acc T Int (Vector a)
evs =
          let (T Int (Vector a)
now,T Int (Vector a)
future) = forall time body.
C time =>
time -> T time body -> (T time body, T time body)
EventListTM.splitAtTime Int
sznn T Int (Vector a)
evs
              xs :: [(Int, Vector a)]
xs =
                 forall a b. T a b -> [(a, b)]
AbsEventList.toPairList forall a b. (a -> b) -> a -> b
$
                 forall time body. Num time => time -> T time body -> T time body
EventList.toAbsoluteEventList Int
0 forall a b. (a -> b) -> a -> b
$
                 forall time body a. (T time body -> time -> a) -> T time body -> a
EventListTM.switchTimeR forall a b. a -> b -> a
const T Int (Vector a)
now
              (Vector a
chunk,[(Int, Vector a)]
newAcc) =
                 forall a. (forall s. ST s a) -> a
runST
                    (do Vector s a
v <- forall e s. Storable e => Int -> e -> ST s (Vector s e)
SVST.new Int
sz forall a. C a => a
zero
                        [(Int, Vector a)]
newAcc0 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a s.
(Storable a, C a) =>
Vector s a -> Int -> T a -> ST s (Int, T a)
addToBuffer Vector s a
v Int
0) [Vector a]
acc
--                        newAcc1 <- AbsEventList.mapM (addToBuffer v) xs
                        [(Int, Vector a)]
newAcc1 <-
                           forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Int
i,Vector a
s) -> forall a s.
(Storable a, C a) =>
Vector s a -> Int -> T a -> ST s (Int, T a)
addToBuffer Vector s a
v (forall a. T a -> a
NonNeg.toNumber Int
i) Vector a
s) [(Int, Vector a)]
xs
                        Vector a
vf <- forall e s. Storable e => Vector s e -> ST s (Vector e)
SVST.freeze Vector s a
v
                        forall (m :: * -> *) a. Monad m => a -> m a
return (Vector a
vf, [(Int, Vector a)]
newAcc0forall a. [a] -> [a] -> [a]
++[(Int, Vector a)]
newAcc1))
              ([Int]
ends, [Vector a]
suffixes) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ [(Int, Vector a)]
newAcc
              prefix :: Vector a
prefix =
                 {- if there are more events to come,
                    we must pad with zeros -}
                 if forall time body. T time body -> Bool
EventList.null T Int (Vector a)
future
                   then forall a. Storable a => Int -> Vector a -> Vector a
SV.take (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall a. Ord a => a -> a -> a
max Int
0 [Int]
ends) Vector a
chunk
                   else Vector a
chunk
          in  if forall a. Vector a -> Bool
SV.null Vector a
prefix
                then []
                else Vector a
prefix forall a. a -> [a] -> [a]
: [Vector a] -> T Int (Vector a) -> [Vector a]
go (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => Vector a -> Bool
Sig.null) [Vector a]
suffixes) T Int (Vector a)
future
   in  forall a. Storable a => [Vector a] -> Vector a
Sig.fromChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}.
(C a, Storable a) =>
[Vector a] -> T Int (Vector a) -> [Vector a]
go []


{-
{-# INLINE addToBuffer #-}
addToBuffer :: (Storable a, Additive.C a) =>
   SVST.Vector s a -> Int -> Sig.T a -> ST s (Int, Sig.T a)
addToBuffer v start =
   let n = SVST.length v
       go i [] = return (i, [])
       go i (c:cs) =
          let end = i + SV.length c
          in  addChunkToBuffer v i c >>
              if end<n
                then go end cs
                else return (n, SV.drop (end-n) c : cs)
   in  fmap (mapSnd SigSt.fromChunks) . go start . SigSt.chunks

addChunkToBuffer :: (Storable a, Additive.C a) =>
   SVST.Vector s a -> Int -> SV.Vector a -> ST s ()
addChunkToBuffer v start xs =
   let n = SVST.length v
   in  SV.foldr
          (\x continue i ->
             SVST.modify v i (x +) >>
             continue (succ i))
          (\_i -> return ())
          (Sig.take (n Additive.- start) xs)
          start
-}

{-# INLINE addToBuffer #-}
addToBuffer :: (Storable a, Additive.C a) =>
   SVST.Vector s a -> Int -> Sig.T a -> ST s (Int, Sig.T a)
addToBuffer :: forall a s.
(Storable a, C a) =>
Vector s a -> Int -> T a -> ST s (Int, T a)
addToBuffer Vector s a
v Int
start T a
xs =
   let n :: Int
n = forall s e. Vector s e -> Int
SVST.length Vector s a
v
       (T a
now,T a
future) = forall a. Storable a => Int -> Vector a -> (Vector a, Vector a)
Sig.splitAt (Int
n forall a. C a => a -> a -> a
Additive.- Int
start) T a
xs
       go :: Int -> [Vector a] -> ST s Int
go Int
i [] = forall (m :: * -> *) a. Monad m => a -> m a
return Int
i
       go Int
i (Vector a
c:[Vector a]
cs) =
          forall a s.
(Storable a, C a) =>
Vector s a -> Int -> Vector a -> ST s ()
unsafeAddChunkToBuffer Vector s a
v Int
i Vector a
c forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
          Int -> [Vector a] -> ST s Int
go (Int
i forall a. C a => a -> a -> a
+ forall a. Vector a -> Int
SV.length Vector a
c) [Vector a]
cs
   in  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) T a
future) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Vector a] -> ST s Int
go Int
start forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Vector a -> [Vector a]
Sig.chunks forall a b. (a -> b) -> a -> b
$ T a
now

{-# INLINE addChunkToBuffer #-}
addChunkToBuffer :: (Storable a, Additive.C a) =>
   SVST.Vector s a -> Int -> SV.Vector a -> ST s ()
addChunkToBuffer :: forall a s.
(Storable a, C a) =>
Vector s a -> Int -> Vector a -> ST s ()
addChunkToBuffer Vector s a
v Int
start Vector a
xs =
   if Int
start forall a. C a => a -> a -> a
+ forall a. Vector a -> Int
SV.length Vector a
xs forall a. Ord a => a -> a -> Bool
<= forall s e. Vector s e -> Int
SVST.length Vector s a
v
     then forall a s.
(Storable a, C a) =>
Vector s a -> Int -> Vector a -> ST s ()
unsafeAddChunkToBuffer Vector s a
v Int
start Vector a
xs
     else forall a. HasCallStack => String -> a
error String
"Storable.addChunkToBuffer: chunk too large"

{- | chunk must fit into the buffer -}
{- This implementation will be faster as long as 'SV.foldr' is inefficient. -}
{-# INLINE unsafeAddChunkToBuffer #-}
unsafeAddChunkToBuffer :: (Storable a, Additive.C a) =>
   SVST.Vector s a -> Int -> SV.Vector a -> ST s ()
unsafeAddChunkToBuffer :: forall a s.
(Storable a, C a) =>
Vector s a -> Int -> Vector a -> ST s ()
unsafeAddChunkToBuffer Vector s a
v Int
start Vector a
xs =
   let go :: Int -> Int -> ST s ()
go Int
i Int
j =
          if Int
j forall a. Ord a => a -> a -> Bool
>= forall a. Vector a -> Int
SV.length Vector a
xs
            then forall (m :: * -> *) a. Monad m => a -> m a
return ()
            else
              forall e s. Storable e => Vector s e -> Int -> (e -> e) -> ST s ()
SVST.unsafeModify Vector s a
v Int
i (forall a. Storable a => Vector a -> Int -> a
SV.index Vector a
xs Int
j forall a. C a => a -> a -> a
+) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
              Int -> Int -> ST s ()
go (Int
i forall a. C a => a -> a -> a
+ Int
1) (Int
j forall a. C a => a -> a -> a
+ Int
1)
   in  Int -> Int -> ST s ()
go Int
start Int
0

{- | chunk must fit into the buffer -}
{-# INLINE _unsafeAddChunkToBufferFoldr #-}
_unsafeAddChunkToBufferFoldr :: (Storable a, Additive.C a) =>
   SVST.Vector s a -> Int -> SV.Vector a -> ST s ()
_unsafeAddChunkToBufferFoldr :: forall a s.
(Storable a, C a) =>
Vector s a -> Int -> Vector a -> ST s ()
_unsafeAddChunkToBufferFoldr Vector s a
v Int
start Vector a
xs =
   forall a b. Storable a => (a -> b -> b) -> b -> Vector a -> b
SV.foldr
      (\a
x Int -> ST s ()
continue Int
i ->
         forall e s. Storable e => Vector s e -> Int -> (e -> e) -> ST s ()
SVST.unsafeModify Vector s a
v Int
i (a
x forall a. C a => a -> a -> a
+) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
         Int -> ST s ()
continue (forall a. Enum a => a -> a
succ Int
i))
      (\Int
_i -> forall (m :: * -> *) a. Monad m => a -> m a
return ())
      Vector a
xs Int
start


-- most elegant solution, but slow because StorableVector.foldr is slow
{-# INLINE _addToBufferFoldr #-}
_addToBufferFoldr :: (Storable a, Additive.C a) =>
   SVST.Vector s a -> Int -> Sig.T a -> ST s (Int, Sig.T a)
_addToBufferFoldr :: forall a s.
(Storable a, C a) =>
Vector s a -> Int -> T a -> ST s (Int, T a)
_addToBufferFoldr Vector s a
v Int
start T a
xs =
   let n :: Int
n = forall s e. Vector s e -> Int
SVST.length Vector s a
v
       (T a
now,T a
future) = forall a. Storable a => Int -> Vector a -> (Vector a, Vector a)
Sig.splitAt (Int
n forall a. C a => a -> a -> a
Additive.- Int
start) T a
xs
   in  forall b a. Storable b => (b -> a -> a) -> a -> Vector b -> a
Sig.foldr
          (\a
x Int -> ST s (Int, T a)
continue Int
i ->
             forall e s. Storable e => Vector s e -> Int -> (e -> e) -> ST s ()
SVST.modify Vector s a
v Int
i (a
x forall a. C a => a -> a -> a
+) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
             Int -> ST s (Int, T a)
continue (forall a. Enum a => a -> a
succ Int
i))
          (\Int
i -> forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, T a
future))
          T a
now Int
start


{-
Using @Sig.switchL@ in an inner loop
is slower than using @Sig.foldr@.
Using a StorableVectorPointer would be faster,
but I think still slower than @foldr@.
-}
_addToBufferSwitchL :: (Storable a, Additive.C a) =>
   SVST.Vector s a -> Int -> Sig.T a -> ST s (Int, Sig.T a)
_addToBufferSwitchL :: forall a s.
(Storable a, C a) =>
Vector s a -> Int -> T a -> ST s (Int, T a)
_addToBufferSwitchL Vector s a
v Int
start =
   let n :: Int
n = forall s e. Vector s e -> Int
SVST.length Vector s a
v
       {-# INLINE go #-}
       go :: Int -> Vector a -> ST s (Int, Vector a)
go Int
i =
          if Int
iforall a. Ord a => a -> a -> Bool
>=Int
n
            then forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) Int
i
            else
              forall a b.
Storable a =>
b -> (a -> Vector a -> b) -> Vector a -> b
Sig.switchL
                 (forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, forall a. Storable a => Vector a
Sig.empty))
                 (\a
x Vector a
xs ->
                     forall e s. Storable e => Vector s e -> Int -> (e -> e) -> ST s ()
SVST.modify Vector s a
v Int
i (a
x forall a. C a => a -> a -> a
+) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                     Int -> Vector a -> ST s (Int, Vector a)
go (forall a. Enum a => a -> a
succ Int
i) Vector a
xs)
   in  Int -> Vector a -> ST s (Int, Vector a)
go Int
start