module Synthesizer.CausalIO.Gate (
   Chunk(Chunk), chunk,
   allToStorableVector,
   toStorableVector,
   allToChunkySize,
   toChunkySize,
   shorten,
   ) where

import qualified Synthesizer.CausalIO.Process as PIO
import qualified Synthesizer.Zip as Zip

import qualified Synthesizer.Generic.Cut as CutG
import qualified Synthesizer.Generic.Signal as SigG
import Synthesizer.PiecewiseConstant.Signal (StrictTime, )

import qualified Control.Monad.Trans.State as MS
import Control.Arrow (Arrow, arr, (^<<), )
import Control.Monad (when, )

import qualified Data.StorableVector as SV
import qualified Data.Monoid as Mn
import qualified Data.Semigroup as Sg
import Data.Maybe.HT (toMaybe, )

import qualified Numeric.NonNegative.Class as NonNeg
import qualified Numeric.NonNegative.Wrapper as NonNegW

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


{- |
Chunk represents a chunk of a Gate signal.

It means (Chunk chunkDuration sustainDuration).

sustainDuration means:
Just (t,a) -
   key is released at time t with attribute a,
   e.g. the note-off-velocity,
   t must be smaller than chunkDuration!
Nothing - key is in pressed or released state over the whole chunk
-}
data Chunk a = Chunk StrictTime (Maybe (StrictTime, a))
   deriving (Int -> Chunk a -> ShowS
[Chunk a] -> ShowS
Chunk a -> String
(Int -> Chunk a -> ShowS)
-> (Chunk a -> String) -> ([Chunk a] -> ShowS) -> Show (Chunk a)
forall a. Show a => Int -> Chunk a -> ShowS
forall a. Show a => [Chunk a] -> ShowS
forall a. Show a => Chunk a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Chunk a -> ShowS
showsPrec :: Int -> Chunk a -> ShowS
$cshow :: forall a. Show a => Chunk a -> String
show :: Chunk a -> String
$cshowList :: forall a. Show a => [Chunk a] -> ShowS
showList :: [Chunk a] -> ShowS
Show)

-- | smart constructor that checks the time constraints
chunk :: StrictTime -> Maybe (StrictTime, a) -> Chunk a
chunk :: forall a. StrictTime -> Maybe (StrictTime, a) -> Chunk a
chunk StrictTime
dur Maybe (StrictTime, a)
mrel =
   if Bool -> ((StrictTime, a) -> Bool) -> Maybe (StrictTime, a) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\(StrictTime
rel,a
_attr) -> StrictTime
relStrictTime -> StrictTime -> Bool
forall a. Ord a => a -> a -> Bool
<StrictTime
dur) Maybe (StrictTime, a)
mrel
     then StrictTime -> Maybe (StrictTime, a) -> Chunk a
forall a. StrictTime -> Maybe (StrictTime, a) -> Chunk a
Chunk StrictTime
dur Maybe (StrictTime, a)
mrel
     else String -> Chunk a
forall a. HasCallStack => String -> a
error String
"release time must be strictly before chunk end"


instance CutG.Read (Chunk a) where
   null :: Chunk a -> Bool
null (Chunk StrictTime
dur Maybe (StrictTime, a)
_) = StrictTime -> Bool
forall a. C a => a -> Bool
isZero StrictTime
dur
   length :: Chunk a -> Int
length (Chunk StrictTime
dur Maybe (StrictTime, a)
_) = StrictTime -> Int
forall a b. (C a, C b) => a -> b
fromIntegral StrictTime
dur

instance CutG.NormalForm (Chunk a) where
   evaluateHead :: Chunk a -> ()
evaluateHead (Chunk StrictTime
dur Maybe (StrictTime, a)
rel) =
      StrictTime
dur StrictTime -> () -> ()
forall a b. a -> b -> b
`seq` Maybe (StrictTime, a)
rel Maybe (StrictTime, a) -> () -> ()
forall a b. a -> b -> b
`seq` ()

instance Sg.Semigroup (Chunk a) where
   <> :: Chunk a -> Chunk a -> Chunk a
(<>) = String -> Chunk a -> Chunk a -> Chunk a
forall a. HasCallStack => String -> a
error String
"Gate.mappend cannot be defined"

instance Mn.Monoid (Chunk a) where
   mempty :: Chunk a
mempty = String -> Chunk a
forall a. HasCallStack => String -> a
error String
"Gate.mempty cannot be defined"
   mappend :: Chunk a -> Chunk a -> Chunk a
mappend = Chunk a -> Chunk a -> Chunk a
forall a. Semigroup a => a -> a -> a
(Sg.<>)

instance CutG.Transform (Chunk a) where
   take :: Int -> Chunk a -> Chunk a
take Int
n (Chunk StrictTime
dur Maybe (StrictTime, a)
mrel) =
      let nn :: StrictTime
nn = Integer -> StrictTime
forall a. (Ord a, Num a) => a -> T a
NonNegW.fromNumberClip (Integer -> StrictTime) -> Integer -> StrictTime
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a b. (C a, C b) => a -> b
fromIntegral Int
n
      in  StrictTime -> Maybe (StrictTime, a) -> Chunk a
forall a. StrictTime -> Maybe (StrictTime, a) -> Chunk a
Chunk (StrictTime -> StrictTime -> StrictTime
forall a. Ord a => a -> a -> a
min StrictTime
nn StrictTime
dur) (Maybe (StrictTime, a) -> Chunk a)
-> Maybe (StrictTime, a) -> Chunk a
forall a b. (a -> b) -> a -> b
$
          Maybe (StrictTime, a)
mrel Maybe (StrictTime, a)
-> ((StrictTime, a) -> Maybe (StrictTime, a))
-> Maybe (StrictTime, a)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(StrictTime, a)
rel -> Bool -> (StrictTime, a) -> Maybe (StrictTime, a)
forall a. Bool -> a -> Maybe a
toMaybe ((StrictTime, a) -> StrictTime
forall a b. (a, b) -> a
fst (StrictTime, a)
rel StrictTime -> StrictTime -> Bool
forall a. Ord a => a -> a -> Bool
< StrictTime
nn) (StrictTime, a)
rel
   drop :: Int -> Chunk a -> Chunk a
drop Int
n (Chunk StrictTime
dur Maybe (StrictTime, a)
mrel) =
      let nn :: StrictTime
nn = Integer -> StrictTime
forall a. (Ord a, Num a) => a -> T a
NonNegW.fromNumberClip (Integer -> StrictTime) -> Integer -> StrictTime
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a b. (C a, C b) => a -> b
fromIntegral Int
n
      in  StrictTime -> Maybe (StrictTime, a) -> Chunk a
forall a. StrictTime -> Maybe (StrictTime, a) -> Chunk a
Chunk (StrictTime
dur StrictTime -> StrictTime -> StrictTime
forall a. C a => a -> a -> a
NonNeg.-| StrictTime
nn) (Maybe (StrictTime, a) -> Chunk a)
-> Maybe (StrictTime, a) -> Chunk a
forall a b. (a -> b) -> a -> b
$
          Maybe (StrictTime, a)
mrel Maybe (StrictTime, a)
-> ((StrictTime, a) -> Maybe (StrictTime, a))
-> Maybe (StrictTime, a)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(StrictTime
rel,a
attr) -> Bool -> (StrictTime, a) -> Maybe (StrictTime, a)
forall a. Bool -> a -> Maybe a
toMaybe (StrictTime
nn StrictTime -> StrictTime -> Bool
forall a. Ord a => a -> a -> Bool
<= StrictTime
rel) (StrictTime
relStrictTime -> StrictTime -> StrictTime
forall a. C a => a -> a -> a
-StrictTime
nn, a
attr)
   splitAt :: Int -> Chunk a -> (Chunk a, Chunk a)
splitAt Int
n Chunk a
c = (Int -> Chunk a -> Chunk a
forall sig. Transform sig => Int -> sig -> sig
CutG.take Int
n Chunk a
c, Int -> Chunk a -> Chunk a
forall sig. Transform sig => Int -> sig -> sig
CutG.drop Int
n Chunk a
c)
   dropMarginRem :: Int -> Int -> Chunk a -> (Int, Chunk a)
dropMarginRem = String -> Int -> Int -> Chunk a -> (Int, Chunk a)
forall a. HasCallStack => String -> a
error String
"Gate.dropMarginRem is not defined"
   reverse :: Chunk a -> Chunk a
reverse = String -> Chunk a -> Chunk a
forall a. HasCallStack => String -> a
error String
"Gate.reverse cannot be defined"


allToStorableVector ::
   (Arrow arrow) =>
   arrow (Chunk a) (SV.Vector ())
allToStorableVector :: forall (arrow :: * -> * -> *) a.
Arrow arrow =>
arrow (Chunk a) (Vector ())
allToStorableVector = (Chunk a -> Vector ()) -> arrow (Chunk a) (Vector ())
forall b c. (b -> c) -> arrow b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((Chunk a -> Vector ()) -> arrow (Chunk a) (Vector ()))
-> (Chunk a -> Vector ()) -> arrow (Chunk a) (Vector ())
forall a b. (a -> b) -> a -> b
$
   (\(SigG.LazySize Int
n) -> Int -> () -> Vector ()
forall a. Storable a => Int -> a -> Vector a
SV.replicate Int
n ())
   (LazySize -> Vector ())
-> (Chunk a -> LazySize) -> Chunk a -> Vector ()
forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<<
   Chunk a -> LazySize
forall (arrow :: * -> * -> *) a.
Arrow arrow =>
arrow (Chunk a) LazySize
allToChunkySize

toStorableVector ::
   PIO.T (Chunk a) (SV.Vector ())
toStorableVector :: forall a. T (Chunk a) (Vector ())
toStorableVector =
   (\(SigG.LazySize Int
n) -> Int -> () -> Vector ()
forall a. Storable a => Int -> a -> Vector a
SV.replicate Int
n ())
   (LazySize -> Vector ())
-> T (Chunk a) LazySize -> T (Chunk a) (Vector ())
forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<<
   T (Chunk a) LazySize
forall a. T (Chunk a) LazySize
toChunkySize


allToChunkySize ::
   (Arrow arrow) =>
   arrow (Chunk a) SigG.LazySize
allToChunkySize :: forall (arrow :: * -> * -> *) a.
Arrow arrow =>
arrow (Chunk a) LazySize
allToChunkySize = (Chunk a -> LazySize) -> arrow (Chunk a) LazySize
forall b c. (b -> c) -> arrow b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((Chunk a -> LazySize) -> arrow (Chunk a) LazySize)
-> (Chunk a -> LazySize) -> arrow (Chunk a) LazySize
forall a b. (a -> b) -> a -> b
$
   \(Chunk StrictTime
time Maybe (StrictTime, a)
_) -> Int -> LazySize
SigG.LazySize (StrictTime -> Int
forall a b. (C a, C b) => a -> b
fromIntegral StrictTime
time)

toChunkySize ::
   PIO.T (Chunk a) SigG.LazySize
toChunkySize :: forall a. T (Chunk a) LazySize
toChunkySize =
   Bool -> (Chunk a -> State Bool LazySize) -> T (Chunk a) LazySize
forall state a b. state -> (a -> State state b) -> T a b
PIO.traverse Bool
True ((Chunk a -> State Bool LazySize) -> T (Chunk a) LazySize)
-> (Chunk a -> State Bool LazySize) -> T (Chunk a) LazySize
forall a b. (a -> b) -> a -> b
$
   \(Chunk StrictTime
time Maybe (StrictTime, a)
mRelease) -> do
      Bool
running <- StateT Bool Identity Bool
forall (m :: * -> *) s. Monad m => StateT s m s
MS.get
      if Bool -> Bool
not Bool
running
        then LazySize -> State Bool LazySize
forall a. a -> StateT Bool Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (LazySize -> State Bool LazySize)
-> LazySize -> State Bool LazySize
forall a b. (a -> b) -> a -> b
$ Int -> LazySize
SigG.LazySize Int
0
        else
          case Maybe (StrictTime, a)
mRelease of
             Maybe (StrictTime, a)
Nothing ->
                LazySize -> State Bool LazySize
forall a. a -> StateT Bool Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (LazySize -> State Bool LazySize)
-> LazySize -> State Bool LazySize
forall a b. (a -> b) -> a -> b
$ Int -> LazySize
SigG.LazySize (StrictTime -> Int
forall a b. (C a, C b) => a -> b
fromIntegral StrictTime
time)
             Just (StrictTime
relTime, a
_) -> do
                Bool -> StateT Bool Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
MS.put Bool
False
                LazySize -> State Bool LazySize
forall a. a -> StateT Bool Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (LazySize -> State Bool LazySize)
-> LazySize -> State Bool LazySize
forall a b. (a -> b) -> a -> b
$ Int -> LazySize
SigG.LazySize (StrictTime -> Int
forall a b. (C a, C b) => a -> b
fromIntegral StrictTime
relTime)


{- |
Pass the second signal while the gate is open.

For completeness we would need a data type analogously to ChunkySize,
that measures signal duration in CausalIO processes.
'shorten' could then be written as

> shorten = Zip.second ^<< Zip.arrowFirstShort Gate.toChunkySize
-}
shorten ::
   (CutG.Transform signal) =>
   PIO.T (Zip.T (Chunk a) signal) signal
shorten :: forall signal a. Transform signal => T (T (Chunk a) signal) signal
shorten =
   Bool
-> (T (Chunk a) signal -> State Bool signal)
-> T (T (Chunk a) signal) signal
forall state a b. state -> (a -> State state b) -> T a b
PIO.traverse Bool
True ((T (Chunk a) signal -> State Bool signal)
 -> T (T (Chunk a) signal) signal)
-> (T (Chunk a) signal -> State Bool signal)
-> T (T (Chunk a) signal) signal
forall a b. (a -> b) -> a -> b
$
   \(Zip.Cons (Chunk StrictTime
time Maybe (StrictTime, a)
mRelease) signal
sig) -> do
      Bool -> StateT Bool Identity () -> StateT Bool Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StrictTime -> Integer
forall a. T a -> a
NonNegW.toNumber StrictTime
time Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Int -> Integer
forall a b. (C a, C b) => a -> b
fromIntegral (signal -> Int
forall sig. Read sig => sig -> Int
CutG.length signal
sig))
         (String -> StateT Bool Identity ()
forall a. HasCallStack => String -> a
error String
"Gate.shorten: durations mismatch")
      Bool
running <- StateT Bool Identity Bool
forall (m :: * -> *) s. Monad m => StateT s m s
MS.get
      if Bool -> Bool
not Bool
running
        then signal -> State Bool signal
forall a. a -> StateT Bool Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return signal
forall sig. Monoid sig => sig
CutG.empty
        else
          case Maybe (StrictTime, a)
mRelease of
             Maybe (StrictTime, a)
Nothing ->
                signal -> State Bool signal
forall a. a -> StateT Bool Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (signal -> State Bool signal) -> signal -> State Bool signal
forall a b. (a -> b) -> a -> b
$ signal
sig
             Just (StrictTime
relTime, a
_) -> do
                Bool -> StateT Bool Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
MS.put Bool
False
                signal -> State Bool signal
forall a. a -> StateT Bool Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (signal -> State Bool signal) -> signal -> State Bool signal
forall a b. (a -> b) -> a -> b
$ Int -> signal -> signal
forall sig. Transform sig => Int -> sig -> sig
CutG.take (StrictTime -> Int
forall a b. (C a, C b) => a -> b
fromIntegral StrictTime
relTime) signal
sig