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 ()
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)
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)
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