{-# LANGUAGE NoImplicitPrelude #-}
module Synthesizer.State.Cut (
takeUntilPause,
takeUntilInterval,
chopStorable,
chopChunkySize,
selectBool,
select,
arrange,
arrangeList,
) where
import qualified Synthesizer.State.Signal as Sig
import qualified Synthesizer.Storable.Signal as SigSt
import qualified Synthesizer.Generic.CutChunky as CutChunky
import qualified Synthesizer.Generic.Cut as Cut
import Foreign.Storable (Storable)
import qualified Data.EventList.Relative.TimeBody as EventList
import qualified MathObj.LaurentPolynomial as Laurent
import qualified Algebra.RealRing as RealRing
import qualified Algebra.Additive as Additive
import Control.Applicative (Applicative, )
import qualified Data.List.HT as ListHT
import qualified Data.Array as Array
import Data.Traversable (sequenceA, )
import Data.Tuple.HT (mapFst, mapSnd, )
import Data.Array (Array, Ix, (!), )
import Data.Maybe (fromMaybe, )
import qualified Synthesizer.ChunkySize as ChunkySize
import qualified Number.NonNegative as NonNegW
import NumericPrelude.Numeric
import NumericPrelude.Base
{-# INLINE takeUntilPause #-}
takeUntilPause :: (RealRing.C a) => a -> Int -> Sig.T a -> Sig.T a
takeUntilPause :: forall a. C a => a -> Int -> T a -> T a
takeUntilPause a
y =
(a -> Bool) -> Int -> T a -> T a
forall a. (a -> Bool) -> Int -> T a -> T a
takeUntilInterval ((a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<=a
y) (a -> Bool) -> (a -> a) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
forall a. C a => a -> a
abs)
{-# INLINE takeUntilInterval #-}
takeUntilInterval :: (a -> Bool) -> Int -> Sig.T a -> Sig.T a
takeUntilInterval :: forall a. (a -> Bool) -> Int -> T a -> T a
takeUntilInterval a -> Bool
p Int
n T a
xs =
((a, Int) -> a) -> T (a, Int) -> T a
forall a b. (a -> b) -> T a -> T b
Sig.map (a, Int) -> a
forall a b. (a, b) -> a
fst (T (a, Int) -> T a) -> T (a, Int) -> T a
forall a b. (a -> b) -> a -> b
$
((a, Int) -> Bool) -> T (a, Int) -> T (a, Int)
forall a. (a -> Bool) -> T a -> T a
Sig.takeWhile ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
n) (Int -> Bool) -> ((a, Int) -> Int) -> (a, Int) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Int) -> Int
forall a b. (a, b) -> b
snd) (T (a, Int) -> T (a, Int)) -> T (a, Int) -> T (a, Int)
forall a b. (a -> b) -> a -> b
$
T a -> T Int -> T (a, Int)
forall a b. T a -> T b -> T (a, b)
Sig.zip T a
xs (T Int -> T (a, Int)) -> T Int -> T (a, Int)
forall a b. (a -> b) -> a -> b
$
Int -> T Int -> T Int
forall a. Int -> T a -> T a
Sig.drop Int
n (T Int -> T Int) -> T Int -> T Int
forall a b. (a -> b) -> a -> b
$
T Int -> T Int -> T Int
forall a. T a -> T a -> T a
Sig.append ((Int -> a -> Int) -> Int -> T a -> T Int
forall acc x. (acc -> x -> acc) -> acc -> T x -> T acc
Sig.scanL (\Int
acc a
x -> if a -> Bool
p a
x then Int -> Int
forall a. Enum a => a -> a
succ Int
acc else Int
0) Int
0 T a
xs) (T Int -> T Int) -> T Int -> T Int
forall a b. (a -> b) -> a -> b
$
Int -> T Int
forall a. a -> T a
Sig.repeat Int
0
{-# INLINE selectBool #-}
selectBool :: (Sig.T a, Sig.T a) -> Sig.T Bool -> Sig.T a
selectBool :: forall a. (T a, T a) -> T Bool -> T a
selectBool =
((a, a) -> Bool -> a) -> T (a, a) -> T Bool -> T a
forall a b c. (a -> b -> c) -> T a -> T b -> T c
Sig.zipWith (\(a
xf,a
xt) Bool
c -> if Bool
c then a
xt else a
xf) (T (a, a) -> T Bool -> T a)
-> ((T a, T a) -> T (a, a)) -> (T a, T a) -> T Bool -> T a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(T a -> T a -> T (a, a)) -> (T a, T a) -> T (a, a)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry T a -> T a -> T (a, a)
forall a b. T a -> T b -> T (a, b)
Sig.zip
{-# INLINE select #-}
select :: Ix i => Array i (Sig.T a) -> Sig.T i -> Sig.T a
select :: forall i a. Ix i => Array i (T a) -> T i -> T a
select =
(i -> Array i (T a) -> Maybe (a, Array i (T a)))
-> Array i (T a) -> T i -> T a
forall x acc y. (x -> acc -> Maybe (y, acc)) -> acc -> T x -> T y
Sig.crochetL
(\i
xi Array i (T a)
arr ->
do Array i (a, T a)
arr0 <- Array i (Maybe (a, T a)) -> Maybe (Array i (a, T a))
forall (f :: * -> *) i a.
(Applicative f, Ix i) =>
Array i (f a) -> f (Array i a)
sequenceArray ((T a -> Maybe (a, T a))
-> Array i (T a) -> Array i (Maybe (a, T a))
forall a b. (a -> b) -> Array i a -> Array i b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap T a -> Maybe (a, T a)
forall a. T a -> Maybe (a, T a)
Sig.viewL Array i (T a)
arr)
(a, Array i (T a)) -> Maybe (a, Array i (T a))
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, T a) -> a
forall a b. (a, b) -> a
fst (Array i (a, T a)
arr0Array i (a, T a) -> i -> (a, T a)
forall i e. Ix i => Array i e -> i -> e
!i
xi), ((a, T a) -> T a) -> Array i (a, T a) -> Array i (T a)
forall a b. (a -> b) -> Array i a -> Array i b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, T a) -> T a
forall a b. (a, b) -> b
snd Array i (a, T a)
arr0))
{-# INLINE sequenceArray #-}
sequenceArray ::
(Applicative f, Ix i) =>
Array i (f a) -> f (Array i a)
sequenceArray :: forall (f :: * -> *) i a.
(Applicative f, Ix i) =>
Array i (f a) -> f (Array i a)
sequenceArray Array i (f a)
arr =
([a] -> Array i a) -> f [a] -> f (Array i a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((i, i) -> [a] -> Array i a
forall i e. Ix i => (i, i) -> [e] -> Array i e
Array.listArray (Array i (f a) -> (i, i)
forall i e. Array i e -> (i, i)
Array.bounds Array i (f a)
arr)) (f [a] -> f (Array i a)) -> f [a] -> f (Array i a)
forall a b. (a -> b) -> a -> b
$
[f a] -> f [a]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA (Array i (f a) -> [f a]
forall i e. Array i e -> [e]
Array.elems Array i (f a)
arr)
{-# INLINE arrangeList #-}
arrangeList :: (Additive.C v) =>
EventList.T NonNegW.Int (Sig.T v)
-> Sig.T v
arrangeList :: forall v. C v => T Int (T v) -> T v
arrangeList T Int (T v)
evs =
let xs :: [[v]]
xs = (T v -> [v]) -> [T v] -> [[v]]
forall a b. (a -> b) -> [a] -> [b]
map T v -> [v]
forall y. T y -> [y]
Sig.toList (T Int (T v) -> [T v]
forall time body. T time body -> [body]
EventList.getBodies T Int (T v)
evs)
in case (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Int
forall a. T a -> a
NonNegW.toNumber (T Int (T v) -> [Int]
forall time body. T time body -> [time]
EventList.getTimes T Int (T v)
evs) of
Int
t:[Int]
ts -> Int -> v -> T v
forall a. Int -> a -> T a
Sig.replicate Int
t v
forall a. C a => a
zero T v -> T v -> T v
forall a. T a -> T a -> T a
`Sig.append`
[v] -> T v
forall y. [y] -> T y
Sig.fromList ([Int] -> [[v]] -> [v]
forall a. C a => [Int] -> [[a]] -> [a]
Laurent.addShiftedMany [Int]
ts [[v]]
xs)
[] -> T v
forall a. T a
Sig.empty
{-# INLINE arrange #-}
arrange :: (Additive.C v) =>
EventList.T NonNegW.Int (Sig.T v)
-> Sig.T v
arrange :: forall v. C v => T Int (T v) -> T v
arrange T Int (T v)
evs =
let xs :: [T v]
xs = T Int (T v) -> [T v]
forall time body. T time body -> [body]
EventList.getBodies T Int (T v)
evs
in case (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Int
forall a. T a -> a
NonNegW.toNumber (T Int (T v) -> [Int]
forall time body. T time body -> [time]
EventList.getTimes T Int (T v)
evs) of
Int
t:[Int]
ts -> Int -> v -> T v
forall a. Int -> a -> T a
Sig.replicate Int
t v
forall a. C a => a
zero T v -> T v -> T v
forall a. T a -> T a -> T a
`Sig.append`
[Int] -> [T v] -> T v
forall a. C a => [Int] -> [T a] -> T a
addShiftedMany [Int]
ts [T v]
xs
[] -> T v
forall a. T a
Sig.empty
{-# INLINE addShiftedMany #-}
addShiftedMany :: (Additive.C a) => [Int] -> [Sig.T a] -> Sig.T a
addShiftedMany :: forall a. C a => [Int] -> [T a] -> T a
addShiftedMany [Int]
ds [T a]
xss =
((Int, T a) -> T a -> T a) -> T a -> [(Int, T a)] -> T a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Int -> T a -> T a -> T a) -> (Int, T a) -> T a -> T a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> T a -> T a -> T a
forall a. C a => Int -> T a -> T a -> T a
addShifted) T a
forall a. T a
Sig.empty ([Int] -> [T a] -> [(Int, T a)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Int]
ds[Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++[Int
forall a. C a => a
zero]) [T a]
xss)
{-# INLINE addShifted #-}
addShifted :: Additive.C a => Int -> Sig.T a -> Sig.T a -> Sig.T a
addShifted :: forall a. C a => Int -> T a -> T a -> T a
addShifted Int
del T a
xs T a
ys =
if Int
del Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
then [Char] -> T a
forall a. HasCallStack => [Char] -> a
error [Char]
"State.Signal.addShifted: negative shift"
else
T a -> (forall s. (s -> Maybe (a, s)) -> s -> T a) -> T a
forall y x. T y -> (forall s. (s -> Maybe (y, s)) -> s -> x) -> x
Sig.runViewL T a
xs (\s -> Maybe (a, s)
nextX s
xs2 ->
T a -> (forall s. (s -> Maybe (a, s)) -> s -> T a) -> T a
forall y x. T y -> (forall s. (s -> Maybe (y, s)) -> s -> x) -> x
Sig.runViewL T a
ys (\s -> Maybe (a, s)
nextY s
ys2 ->
(((Int, s), s) -> Maybe (a, ((Int, s), s))) -> ((Int, s), s) -> T a
forall acc y. (acc -> Maybe (y, acc)) -> acc -> T y
Sig.unfoldR
(\((Int
d,s
ys0),s
xs0) ->
if Int
dInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
forall a. C a => a
zero
then
((a, (s, s)) -> (a, ((Int, s), s)))
-> Maybe (a, (s, s)) -> Maybe (a, ((Int, s), s))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
(((s, s) -> ((Int, s), s)) -> (a, (s, s)) -> (a, ((Int, s), s))
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd (\(s
xs1,s
ys1) -> ((Int
forall a. C a => a
zero,s
ys1),s
xs1)))
((s -> Maybe (a, s))
-> (s -> Maybe (a, s))
-> (a -> a -> a)
-> (s, s)
-> Maybe (a, (s, s))
forall s a t.
(s -> Maybe (a, s))
-> (t -> Maybe (a, t))
-> (a -> a -> a)
-> (s, t)
-> Maybe (a, (s, t))
Sig.zipStep s -> Maybe (a, s)
nextX s -> Maybe (a, s)
nextY a -> a -> a
forall a. C a => a -> a -> a
(+) (s
xs0, s
ys0))
else
(a, ((Int, s), s)) -> Maybe (a, ((Int, s), s))
forall a. a -> Maybe a
Just ((a, ((Int, s), s)) -> Maybe (a, ((Int, s), s)))
-> (a, ((Int, s), s)) -> Maybe (a, ((Int, s), s))
forall a b. (a -> b) -> a -> b
$ (s -> ((Int, s), s)) -> (a, s) -> (a, ((Int, s), s))
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd ((,) (Int -> Int
forall a. Enum a => a -> a
pred Int
d, s
ys0)) ((a, s) -> (a, ((Int, s), s))) -> (a, s) -> (a, ((Int, s), s))
forall a b. (a -> b) -> a -> b
$
(a, s) -> Maybe (a, s) -> (a, s)
forall a. a -> Maybe a -> a
fromMaybe (a
forall a. C a => a
zero, s
xs0) (Maybe (a, s) -> (a, s)) -> Maybe (a, s) -> (a, s)
forall a b. (a -> b) -> a -> b
$ s -> Maybe (a, s)
nextX s
xs0)
((Int
del,s
ys2),s
xs2)
))
chopStorable :: Storable a => Sig.T Bool -> SigSt.T a -> [SigSt.T a]
chopStorable :: forall a. Storable a => T Bool -> T a -> [T a]
chopStorable = T Bool -> T a -> [T a]
forall chunky. C chunky => T Bool -> chunky -> [chunky]
chop
chopChunkySize :: Sig.T Bool -> ChunkySize.T -> [ChunkySize.T]
chopChunkySize :: T Bool -> T -> [T]
chopChunkySize = T Bool -> T -> [T]
forall chunky. C chunky => T Bool -> chunky -> [chunky]
chop
chop :: CutChunky.C chunky => Sig.T Bool -> chunky -> [chunky]
chop :: forall chunky. C chunky => T Bool -> chunky -> [chunky]
chop T Bool
bs =
T Bool
-> (forall {s}. (s -> Maybe (Bool, s)) -> s -> chunky -> [chunky])
-> chunky
-> [chunky]
forall y x. T y -> (forall s. (s -> Maybe (y, s)) -> s -> x) -> x
Sig.runViewL T Bool
bs ((forall {s}. (s -> Maybe (Bool, s)) -> s -> chunky -> [chunky])
-> chunky -> [chunky])
-> (forall {s}. (s -> Maybe (Bool, s)) -> s -> chunky -> [chunky])
-> chunky
-> [chunky]
forall a b. (a -> b) -> a -> b
$ \s -> Maybe (Bool, s)
f s
s ->
let go :: s -> [Chunk a] -> (a, [a])
go s
_ [] = (a
forall sig. Monoid sig => sig
Cut.empty, [])
go s
s0 (Chunk a
chunk:[Chunk a]
chunks) =
case (s -> Maybe (Bool, s)) -> Chunk a -> s -> ([Chunk a], Maybe s)
forall chunk s.
Transform chunk =>
(s -> Maybe (Bool, s)) -> chunk -> s -> ([chunk], Maybe s)
chopChunk s -> Maybe (Bool, s)
f Chunk a
chunk s
s0 of
([Chunk a]
split, Maybe s
ms) ->
[Chunk a] -> (a, [a]) -> (a, [a])
forall chunky.
C chunky =>
[Chunk chunky] -> (chunky, [chunky]) -> (chunky, [chunky])
prependChunks [Chunk a]
split ((a, [a]) -> (a, [a])) -> (a, [a]) -> (a, [a])
forall a b. (a -> b) -> a -> b
$
case Maybe s
ms of
Maybe s
Nothing -> ([Chunk a] -> a
forall chunky. C chunky => [Chunk chunky] -> chunky
CutChunky.fromChunks [Chunk a]
chunks, [])
Just s
s1 -> s -> [Chunk a] -> (a, [a])
go s
s1 [Chunk a]
chunks
in (chunky -> [chunky] -> [chunky]) -> (chunky, [chunky]) -> [chunky]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:) ((chunky, [chunky]) -> [chunky])
-> (chunky -> (chunky, [chunky])) -> chunky -> [chunky]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> [Chunk chunky] -> (chunky, [chunky])
forall {a}. C a => s -> [Chunk a] -> (a, [a])
go s
s ([Chunk chunky] -> (chunky, [chunky]))
-> (chunky -> [Chunk chunky]) -> chunky -> (chunky, [chunky])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. chunky -> [Chunk chunky]
forall chunky. C chunky => chunky -> [Chunk chunky]
CutChunky.toChunks
prependChunks ::
CutChunky.C chunky =>
[CutChunky.Chunk chunky] ->
(chunky, [chunky]) ->
(chunky, [chunky])
prependChunks :: forall chunky.
C chunky =>
[Chunk chunky] -> (chunky, [chunky]) -> (chunky, [chunky])
prependChunks [] (chunky, [chunky])
xs = (chunky, [chunky])
xs
prependChunks (Chunk chunky
chunk:[Chunk chunky]
chunks) (chunky, [chunky])
xs =
let go :: Chunk chunky -> [Chunk chunky] -> (chunky, [chunky])
go Chunk chunky
c0 [Chunk chunky]
css =
(chunky -> chunky) -> (chunky, [chunky]) -> (chunky, [chunky])
forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst
(\chunky
y ->
if Chunk chunky -> Bool
forall sig. Read sig => sig -> Bool
Cut.null Chunk chunky
c0
then chunky
y
else [Chunk chunky] -> chunky
forall chunky. C chunky => [Chunk chunky] -> chunky
CutChunky.fromChunks ([Chunk chunky] -> chunky) -> [Chunk chunky] -> chunky
forall a b. (a -> b) -> a -> b
$ Chunk chunky
c0 Chunk chunky -> [Chunk chunky] -> [Chunk chunky]
forall a. a -> [a] -> [a]
: chunky -> [Chunk chunky]
forall chunky. C chunky => chunky -> [Chunk chunky]
CutChunky.toChunks chunky
y)
(case [Chunk chunky]
css of
[] -> (chunky, [chunky])
xs
(Chunk chunky
c1:[Chunk chunky]
cs) -> (chunky
forall sig. Monoid sig => sig
Cut.empty, (chunky -> [chunky] -> [chunky]) -> (chunky, [chunky]) -> [chunky]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:) (Chunk chunky -> [Chunk chunky] -> (chunky, [chunky])
go Chunk chunky
c1 [Chunk chunky]
cs)))
in Chunk chunky -> [Chunk chunky] -> (chunky, [chunky])
go Chunk chunky
chunk [Chunk chunky]
chunks
chopChunk ::
Cut.Transform chunk =>
(s -> Maybe (Bool, s)) ->
chunk -> s -> ([chunk], Maybe s)
chopChunk :: forall chunk s.
Transform chunk =>
(s -> Maybe (Bool, s)) -> chunk -> s -> ([chunk], Maybe s)
chopChunk s -> Maybe (Bool, s)
f chunk
vs =
let go :: Int -> s -> ([Int], Maybe s)
go Int
j s
s0 =
if Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= chunk -> Int
forall sig. Read sig => sig -> Int
Cut.length chunk
vs
then ([Int
j], s -> Maybe s
forall a. a -> Maybe a
Just s
s0)
else
case s -> Maybe (Bool, s)
f s
s0 of
Maybe (Bool, s)
Nothing -> ([Int
j, chunk -> Int
forall sig. Read sig => sig -> Int
Cut.length chunk
vs], Maybe s
forall a. Maybe a
Nothing)
Just (Bool
b,s
s1) ->
(if Bool
b
then ([Int] -> [Int]) -> ([Int], Maybe s) -> ([Int], Maybe s)
forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst (Int
jInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:)
else ([Int], Maybe s) -> ([Int], Maybe s)
forall a. a -> a
id) (([Int], Maybe s) -> ([Int], Maybe s))
-> ([Int], Maybe s) -> ([Int], Maybe s)
forall a b. (a -> b) -> a -> b
$
Int -> s -> ([Int], Maybe s)
go (Int -> Int
forall a. Enum a => a -> a
succ Int
j) s
s1
in ([Int] -> [chunk]) -> ([Int], Maybe s) -> ([chunk], Maybe s)
forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst
((Int -> Int -> chunk) -> [Int] -> [chunk]
forall a b. (a -> a -> b) -> [a] -> [b]
ListHT.mapAdjacent (\Int
from Int
to -> Int -> chunk -> chunk
forall sig. Transform sig => Int -> sig -> sig
Cut.drop Int
from (chunk -> chunk) -> chunk -> chunk
forall a b. (a -> b) -> a -> b
$ Int -> chunk -> chunk
forall sig. Transform sig => Int -> sig -> sig
Cut.take Int
to chunk
vs) ([Int] -> [chunk]) -> ([Int] -> [Int]) -> [Int] -> [chunk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
0Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:)) (([Int], Maybe s) -> ([chunk], Maybe s))
-> (s -> ([Int], Maybe s)) -> s -> ([chunk], Maybe s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Int -> s -> ([Int], Maybe s)
go Int
0