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
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
showList :: [Chunk a] -> ShowS
$cshowList :: forall a. Show a => [Chunk a] -> ShowS
show :: Chunk a -> String
$cshow :: forall a. Show a => Chunk a -> String
showsPrec :: Int -> Chunk a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> 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 forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\(StrictTime
rel,a
_attr) -> StrictTime
relforall a. Ord a => a -> a -> Bool
<StrictTime
dur) Maybe (StrictTime, a)
mrel
     then forall a. StrictTime -> Maybe (StrictTime, a) -> Chunk a
Chunk StrictTime
dur Maybe (StrictTime, a)
mrel
     else 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)
_) = forall a. C a => a -> Bool
isZero StrictTime
dur
   length :: Chunk a -> Int
length (Chunk StrictTime
dur Maybe (StrictTime, a)
_) = 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 seq :: forall a b. a -> b -> b
`seq` Maybe (StrictTime, a)
rel seq :: forall a b. a -> b -> b
`seq` ()

instance Sg.Semigroup (Chunk a) where
   <> :: 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 = forall a. HasCallStack => String -> a
error String
"Gate.mempty cannot be defined"
   mappend :: Chunk a -> Chunk a -> Chunk a
mappend = 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 = forall a. (Ord a, Num a) => a -> T a
NonNegW.fromNumberClip forall a b. (a -> b) -> a -> b
$ forall a b. (C a, C b) => a -> b
fromIntegral Int
n
      in  forall a. StrictTime -> Maybe (StrictTime, a) -> Chunk a
Chunk (forall a. Ord a => a -> a -> a
min StrictTime
nn StrictTime
dur) forall a b. (a -> b) -> a -> b
$
          Maybe (StrictTime, a)
mrel forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(StrictTime, a)
rel -> forall a. Bool -> a -> Maybe a
toMaybe (forall a b. (a, b) -> a
fst (StrictTime, a)
rel 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 = forall a. (Ord a, Num a) => a -> T a
NonNegW.fromNumberClip forall a b. (a -> b) -> a -> b
$ forall a b. (C a, C b) => a -> b
fromIntegral Int
n
      in  forall a. StrictTime -> Maybe (StrictTime, a) -> Chunk a
Chunk (StrictTime
dur forall a. C a => a -> a -> a
NonNeg.-| StrictTime
nn) forall a b. (a -> b) -> a -> b
$
          Maybe (StrictTime, a)
mrel forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(StrictTime
rel,a
attr) -> forall a. Bool -> a -> Maybe a
toMaybe (StrictTime
nn forall a. Ord a => a -> a -> Bool
<= StrictTime
rel) (StrictTime
relforall a. C a => a -> a -> a
-StrictTime
nn, a
attr)
   splitAt :: Int -> Chunk a -> (Chunk a, Chunk a)
splitAt Int
n Chunk a
c = (forall sig. Transform sig => Int -> sig -> sig
CutG.take Int
n Chunk a
c, forall sig. Transform sig => Int -> sig -> sig
CutG.drop Int
n Chunk a
c)
   dropMarginRem :: Int -> Int -> Chunk a -> (Int, Chunk a)
dropMarginRem = forall a. HasCallStack => String -> a
error String
"Gate.dropMarginRem is not defined"
   reverse :: Chunk a -> Chunk a
reverse = 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 = forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a b. (a -> b) -> a -> b
$
   (\(SigG.LazySize Int
n) -> forall a. Storable a => Int -> a -> Vector a
SV.replicate Int
n ())
   forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<<
   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) -> forall a. Storable a => Int -> a -> Vector a
SV.replicate Int
n ())
   forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<<
   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 = forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a b. (a -> b) -> a -> b
$
   \(Chunk StrictTime
time Maybe (StrictTime, a)
_) -> Int -> LazySize
SigG.LazySize (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 =
   forall state a b. state -> (a -> State state b) -> T a b
PIO.traverse Bool
True forall a b. (a -> b) -> a -> b
$
   \(Chunk StrictTime
time Maybe (StrictTime, a)
mRelease) -> do
      Bool
running <- forall (m :: * -> *) s. Monad m => StateT s m s
MS.get
      if Bool -> Bool
not Bool
running
        then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> LazySize
SigG.LazySize Int
0
        else
          case Maybe (StrictTime, a)
mRelease of
             Maybe (StrictTime, a)
Nothing ->
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> LazySize
SigG.LazySize (forall a b. (C a, C b) => a -> b
fromIntegral StrictTime
time)
             Just (StrictTime
relTime, a
_) -> do
                forall (m :: * -> *) s. Monad m => s -> StateT s m ()
MS.put Bool
False
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> LazySize
SigG.LazySize (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 =
   forall state a b. state -> (a -> State state b) -> T a b
PIO.traverse Bool
True forall a b. (a -> b) -> a -> b
$
   \(Zip.Cons (Chunk StrictTime
time Maybe (StrictTime, a)
mRelease) signal
sig) -> do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. T a -> a
NonNegW.toNumber StrictTime
time forall a. Eq a => a -> a -> Bool
/= forall a b. (C a, C b) => a -> b
fromIntegral (forall sig. Read sig => sig -> Int
CutG.length signal
sig))
         (forall a. HasCallStack => String -> a
error String
"Gate.shorten: durations mismatch")
      Bool
running <- forall (m :: * -> *) s. Monad m => StateT s m s
MS.get
      if Bool -> Bool
not Bool
running
        then forall (m :: * -> *) a. Monad m => a -> m a
return forall sig. Monoid sig => sig
CutG.empty
        else
          case Maybe (StrictTime, a)
mRelease of
             Maybe (StrictTime, a)
Nothing ->
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ signal
sig
             Just (StrictTime
relTime, a
_) -> do
                forall (m :: * -> *) s. Monad m => s -> StateT s m ()
MS.put Bool
False
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall sig. Transform sig => Int -> sig -> sig
CutG.take (forall a b. (C a, C b) => a -> b
fromIntegral StrictTime
relTime) signal
sig