module Synthesizer.State.Cut (
takeUntilPause,
takeUntilInterval,
selectBool,
select,
arrange,
arrangeList,
) where
import qualified Synthesizer.State.Signal as Sig
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 qualified Data.Array as Array
import Data.Array (Array, Ix, (!), elems, )
import Control.Applicative (Applicative, )
import Data.Traversable (sequenceA, )
import Data.Tuple.HT (mapSnd, )
import Data.Maybe (fromMaybe, )
import qualified Number.NonNegative as NonNeg
import NumericPrelude.Base
import NumericPrelude.Numeric
takeUntilPause :: (RealRing.C a) => a -> Int -> Sig.T a -> Sig.T a
takeUntilPause y =
takeUntilInterval ((<=y) . abs)
takeUntilInterval :: (a -> Bool) -> Int -> Sig.T a -> Sig.T a
takeUntilInterval p n xs =
Sig.map fst $
Sig.takeWhile ((<n) . snd) $
Sig.zip xs $
Sig.drop n $
Sig.append (Sig.scanL (\acc x -> if p x then succ acc else 0) 0 xs) $
Sig.repeat 0
selectBool :: (Sig.T a, Sig.T a) -> Sig.T Bool -> Sig.T a
selectBool =
Sig.zipWith (\(xf,xt) c -> if c then xt else xf) .
uncurry Sig.zip
select :: Ix i => Array i (Sig.T a) -> Sig.T i -> Sig.T a
select =
Sig.crochetL
(\xi arr ->
do arr0 <- sequenceArray (fmap Sig.viewL arr)
return (fst (arr0!xi), fmap snd arr0))
sequenceArray ::
(Applicative f, Ix i) =>
Array i (f a) -> f (Array i a)
sequenceArray arr =
fmap (Array.listArray (Array.bounds arr)) $
sequenceA (Array.elems arr)
arrangeList :: (Additive.C v) =>
EventList.T NonNeg.Int (Sig.T v)
-> Sig.T v
arrangeList evs =
let xs = map Sig.toList (EventList.getBodies evs)
in case map NonNeg.toNumber (EventList.getTimes evs) of
t:ts -> Sig.replicate t zero `Sig.append`
Sig.fromList (Laurent.addShiftedMany ts xs)
[] -> Sig.empty
arrange :: (Additive.C v) =>
EventList.T NonNeg.Int (Sig.T v)
-> Sig.T v
arrange evs =
let xs = EventList.getBodies evs
in case map NonNeg.toNumber (EventList.getTimes evs) of
t:ts -> Sig.replicate t zero `Sig.append`
addShiftedMany ts xs
[] -> Sig.empty
addShiftedMany :: (Additive.C a) => [Int] -> [Sig.T a] -> Sig.T a
addShiftedMany ds xss =
foldr (uncurry addShifted) Sig.empty (zip (ds++[zero]) xss)
addShifted :: Additive.C a => Int -> Sig.T a -> Sig.T a -> Sig.T a
addShifted del xs ys =
if del < 0
then error "State.Signal.addShifted: negative shift"
else
Sig.runViewL xs (\nextX xs2 ->
Sig.runViewL ys (\nextY ys2 ->
Sig.unfoldR
(\((d,ys0),xs0) ->
if d==zero
then
fmap
(mapSnd (\(xs1,ys1) -> ((zero,ys1),xs1)))
(Sig.zipStep nextX nextY (+) (xs0, ys0))
else
Just $ mapSnd ((,) (pred d, ys0)) $
fromMaybe (zero, xs0) $ nextX xs0)
((del,ys2),xs2)
))