module Synthesizer.Generic.Signal
(module Synthesizer.Generic.Signal,
Cut.null,
Cut.length,
Cut.empty,
Cut.cycle,
Cut.append,
Cut.concat,
Cut.take,
Cut.drop,
Cut.dropMarginRem,
Cut.splitAt,
Cut.reverse,
Cut.lengthAtLeast,
Cut.lengthAtMost,
Cut.sliceVertical,
) where
import Synthesizer.Generic.Cut (append, )
import qualified Synthesizer.Generic.Cut as Cut
import qualified Synthesizer.Plain.Signal as Sig
import qualified Synthesizer.State.Signal as SigS
import qualified Synthesizer.Storable.Signal as SigSt
import qualified Data.StorableVector.Lazy as Vector
import qualified Synthesizer.Plain.Modifier as Modifier
import qualified Algebra.NonNegative as NonNeg
import qualified Algebra.Module as Module
import qualified Algebra.Additive as Additive
import qualified Algebra.Monoid as Monoid
import qualified Data.EventList.Relative.BodyTime as EventList
import qualified Numeric.NonNegative.Class as NonNeg98
import Foreign.Storable (Storable)
import Control.Monad.Trans.State (runState, runStateT, )
import Data.Monoid (Monoid, mappend, mempty, )
import Data.Function (fix, )
import qualified Data.List.HT as ListHT
import qualified Data.List.Stream as List
import Data.Tuple.HT (mapPair, mapFst, )
import qualified Prelude as P
import Prelude
(Bool, Int, Maybe(Just), maybe, snd,
(==), (<), (>), (<=), (>=),
flip, uncurry, const, (.), ($), (&&), id, (++),
fmap, return, error, show,
Eq, Ord, Show, max, min, )
class Cut.Read (sig y) => Read sig y where
toList :: sig y -> [y]
toState :: sig y -> SigS.T y
foldL :: (s -> y -> s) -> s -> sig y -> s
foldR :: (y -> s -> s) -> s -> sig y -> s
index :: sig y -> Int -> y
class (Read sig y, Cut.Transform (sig y)) => Transform sig y where
cons :: y -> sig y -> sig y
takeWhile :: (y -> Bool) -> sig y -> sig y
dropWhile :: (y -> Bool) -> sig y -> sig y
span :: (y -> Bool) -> sig y -> (sig y, sig y)
viewL :: sig y -> Maybe (y, sig y)
viewR :: sig y -> Maybe (sig y, y)
map :: (y -> y) -> (sig y -> sig y)
scanL :: (y -> y -> y) -> y -> sig y -> sig y
crochetL :: (y -> s -> Maybe (y, s)) -> s -> sig y -> sig y
zipWithAppend :: (y -> y -> y) -> sig y -> sig y -> sig y
newtype LazySize = LazySize Int
deriving (Eq, Ord, Show, Additive.C)
instance Monoid.C LazySize where
idt = LazySize 0
LazySize a <*> LazySize b = LazySize (a Additive.+ b)
instance NonNeg.C LazySize where
split = NonNeg.splitDefault (\(LazySize n) -> n) LazySize
defaultLazySize :: LazySize
defaultLazySize =
let (Vector.ChunkSize size) = Vector.defaultChunkSize
in LazySize size
class Transform sig y => Write sig y where
fromList :: LazySize -> [y] -> sig y
repeat :: LazySize -> y -> sig y
replicate :: LazySize -> Int -> y -> sig y
iterate :: LazySize -> (y -> y) -> y -> sig y
iterateAssociative :: LazySize -> (y -> y -> y) -> y -> sig y
unfoldR :: LazySize -> (s -> Maybe (y,s)) -> s -> sig y
instance Storable y => Read Vector.Vector y where
toList = Vector.unpack
toState = SigS.fromStorableSignal
foldL = Vector.foldl
foldR = Vector.foldr
index = Vector.index
instance Storable y => Transform Vector.Vector y where
cons = Vector.cons
takeWhile = Vector.takeWhile
dropWhile = Vector.dropWhile
span = Vector.span
viewL = Vector.viewL
viewR = Vector.viewR
map = Vector.map
scanL = Vector.scanl
crochetL = Vector.crochetL
zipWithAppend = SigSt.zipWithAppend
withStorableContext ::
(Vector.ChunkSize -> a) -> (LazySize -> a)
withStorableContext f =
\(LazySize size) -> f (Vector.ChunkSize size)
instance Storable y => Write Vector.Vector y where
fromList = withStorableContext $ \size -> Vector.pack size
repeat = withStorableContext $ \size -> Vector.repeat size
replicate = withStorableContext $ \size -> Vector.replicate size
iterate = withStorableContext $ \size -> Vector.iterate size
unfoldR = withStorableContext $ \size -> Vector.unfoldr size
iterateAssociative = withStorableContext $ \size op x -> Vector.iterate size (op x) x
instance Read [] y where
toList = id
toState = SigS.fromList
foldL = List.foldl
foldR = List.foldr
index = (List.!!)
instance Transform [] y where
cons = (:)
takeWhile = List.takeWhile
dropWhile = List.dropWhile
span = List.span
viewL = ListHT.viewL
viewR = ListHT.viewR
map = List.map
scanL = List.scanl
crochetL = Sig.crochetL
zipWithAppend = Sig.zipWithAppend
instance Write [] y where
fromList _ = id
repeat _ = List.repeat
replicate _ = List.replicate
iterate _ = List.iterate
unfoldR _ = List.unfoldr
iterateAssociative _ = ListHT.iterateAssociative
instance Read SigS.T y where
toList = SigS.toList
toState = id
foldL = SigS.foldL
foldR = SigS.foldR
index = indexByDrop
instance Transform SigS.T y where
cons = SigS.cons
takeWhile = SigS.takeWhile
dropWhile = SigS.dropWhile
span p =
mapPair (SigS.fromList, SigS.fromList) .
List.span p . SigS.toList
viewL = SigS.viewL
viewR =
fmap (mapFst SigS.fromList) .
ListHT.viewR . SigS.toList
map = SigS.map
scanL = SigS.scanL
crochetL = SigS.crochetL
zipWithAppend = SigS.zipWithAppend
instance Write SigS.T y where
fromList _ = SigS.fromList
repeat _ = SigS.repeat
replicate _ = SigS.replicate
iterate _ = SigS.iterate
unfoldR _ = SigS.unfoldR
iterateAssociative _ = SigS.iterateAssociative
instance (NonNeg98.C time, P.Integral time) =>
Read (EventList.T time) y where
toList =
List.concatMap (uncurry (flip List.genericReplicate)) .
EventList.toPairList
toState = SigS.fromPiecewiseConstant
foldL f x = SigS.foldL f x . toState
foldR f x = SigS.foldR f x . toState
index sig n =
EventList.foldrPair
(\b t go k ->
if k < t
then b
else go (t NonNeg98.-| k))
(error $ "EventList.index: positions " ++ show n ++ " out of range")
sig
(P.fromIntegral n)
instance (NonNeg98.C time, P.Integral time) =>
Transform (EventList.T time) y where
cons b = EventList.cons b (P.fromInteger 1)
takeWhile p =
EventList.foldrPair
(\b t rest ->
if p b
then EventList.cons b t rest
else EventList.empty)
EventList.empty
dropWhile p =
let recourse xs =
flip (EventList.switchL EventList.empty) xs $ \b _t rest ->
if p b
then recourse rest
else xs
in recourse
span p =
let recourse xs =
flip (EventList.switchL (EventList.empty,EventList.empty)) xs $ \b t rest ->
if p b
then mapFst (EventList.cons b t) $ recourse rest
else (EventList.empty, xs)
in recourse
viewL xs = do
((b,t),ys) <- EventList.viewL xs
if t>0
then Just (b, if t==1 then ys else EventList.cons b (t NonNeg98.-|1) ys)
else viewL ys
viewR =
let dropTrailingZeros =
EventList.foldrPair
(\b t rest ->
if t==0 && EventList.null rest
then EventList.empty
else EventList.cons b t rest)
EventList.empty
recourse (b,t) =
EventList.switchL
(if t<=1
then EventList.empty
else EventList.singleton b (t NonNeg98.-| 1),
b)
(\b0 t0 xs0 ->
mapFst (EventList.cons b t) $ recourse (b0,t0) xs0)
in fmap (uncurry recourse) . EventList.viewL . dropTrailingZeros
map = fmap
scanL f x =
fromState (LazySize 1) . SigS.scanL f x . toState
crochetL f x =
fromState (LazySize 1) . SigS.crochetL f x . toState
zipWithAppend f =
let recourse xs ys =
flip (EventList.switchL ys) xs $ \x xn xs0 ->
flip (EventList.switchL xs) ys $ \y yn ys0 ->
let n = min xn yn
drop_ a an as0 =
if n>=an
then as0
else EventList.cons a (an NonNeg98.-| n) as0
in EventList.cons (f x y) n $
recourse
(drop_ x xn xs0)
(drop_ y yn ys0)
in recourse
instance (NonNeg98.C time, P.Integral time) => Write (EventList.T time) y where
fromList _ =
EventList.fromPairList .
List.map (flip (,) (P.fromInteger 1))
repeat (LazySize n) a =
let xs = EventList.cons a (P.fromIntegral n) xs
in xs
replicate size m a =
Cut.take m (repeat size a)
iterate size f =
fromState size . SigS.iterate f
unfoldR _size f =
let recourse =
maybe EventList.empty
(\(x,s) -> EventList.cons x
(P.fromInteger 1) (recourse s)) . f
in recourse
iterateAssociative size f x = iterate size (f x) x
switchL :: (Transform sig y) =>
a -> (y -> sig y -> a) -> sig y -> a
switchL nothing just =
maybe nothing (uncurry just) . viewL
switchR :: (Transform sig y) =>
a -> (sig y -> y -> a) -> sig y -> a
switchR nothing just =
maybe nothing (uncurry just) . viewR
runViewL ::
(Read sig y) =>
sig y ->
(forall s. (s -> Maybe (y, s)) -> s -> x) ->
x
runViewL =
SigS.runViewL . toState
runSwitchL ::
(Read sig y) =>
sig y ->
(forall s. (forall z. z -> (y -> s -> z) -> s -> z) -> s -> x) ->
x
runSwitchL =
SigS.runSwitchL . toState
mix :: (Additive.C y, Transform sig y) =>
sig y -> sig y -> sig y
mix = zipWithAppend (Additive.+)
zipWith :: (Read sig a, Transform sig b) =>
(a -> b -> b) -> (sig a -> sig b -> sig b)
zipWith h =
flip runViewL (\next ->
crochetL
(\x0 a0 ->
do (y0,a1) <- next a0
Just (h y0 x0, a1)))
zipWithState :: (Transform sig b) =>
(a -> b -> b) -> SigS.T a -> sig b -> sig b
zipWithState f =
flip SigS.runViewL (\next ->
crochetL (\b as0 ->
do (a,as1) <- next as0
Just (f a b, as1)))
zipWithState3 :: (Transform sig c) =>
(a -> b -> c -> c) -> (SigS.T a -> SigS.T b -> sig c -> sig c)
zipWithState3 h a b =
zipWithState ($) (SigS.zipWith h a b)
delay :: (Write sig y) =>
LazySize -> y -> Int -> sig y -> sig y
delay size z n =
append (replicate size n z)
delayLoop ::
(Transform sig y) =>
(sig y -> sig y)
-> sig y
-> sig y
delayLoop proc prefix =
fix (append prefix . proc)
delayLoopOverlap ::
(Additive.C y, Write sig y) =>
Int
-> (sig y -> sig y)
-> sig y
-> sig y
delayLoopOverlap time proc xs =
fix (zipWith (Additive.+) xs .
delay defaultLazySize Additive.zero time . proc)
sum :: (Additive.C a, Read sig a) => sig a -> a
sum = foldL (Additive.+) Additive.zero
monoidConcatMap :: (Read sig a, Monoid m) => (a -> m) -> sig a -> m
monoidConcatMap f =
foldR (mappend . f) mempty
tails :: (Transform sig y) => sig y -> SigS.T (sig y)
tails =
SigS.unfoldR (fmap (\x -> (x, fmap snd (viewL x)))) . Just
laxTail :: (Transform sig y) => sig y -> sig y
laxTail xs =
switchL xs (flip const) xs
mapAdjacent :: (Read sig a, Transform sig a) =>
(a -> a -> a) -> sig a -> sig a
mapAdjacent f xs0 =
let xs1 = maybe xs0 snd (viewL xs0)
in zipWith f xs0 xs1
modifyStatic :: (Transform sig a) =>
Modifier.Simple s ctrl a a -> ctrl -> sig a -> sig a
modifyStatic (Modifier.Simple state proc) control =
crochetL (\a acc -> Just (runState (proc control a) acc)) state
modifyModulated :: (Transform sig a, Read sig ctrl) =>
Modifier.Simple s ctrl a a -> sig ctrl -> sig a -> sig a
modifyModulated (Modifier.Simple state proc) control =
runViewL control (\next c0 ->
crochetL
(\x (acc0,cs0) ->
do (c,cs1) <- next cs0
let (y,acc1) = runState (proc c x) acc0
return (y,(acc1,cs1)))
(state, c0))
linearComb ::
(Module.C t y, Read sig t, Read sig y) =>
sig t -> sig y -> y
linearComb ts ys =
SigS.sum (SigS.zipWith (Module.*>) (toState ts) (toState ys))
fromState :: (Write sig y) =>
LazySize -> SigS.T y -> sig y
fromState size (SigS.Cons f x) =
unfoldR size (runStateT f) x
extendConstant :: (Write sig y) =>
LazySize -> sig y -> sig y
extendConstant size xt =
maybe
xt
(append xt . repeat size . snd)
(viewR xt)
mapTails :: (Transform sig a) =>
(sig a -> a) -> sig a -> sig a
mapTails f x =
crochetL (\_ xs0 ->
do (_,xs1) <- viewL xs0
Just (f xs0, xs1))
x x
mapTailsAlt ::
(Transform sig a, Write sig b) =>
LazySize -> (sig a -> b) -> sig a -> sig b
mapTailsAlt size f =
unfoldR size (\xs ->
do (_,ys) <- viewL xs
Just (f xs, ys))
zipWithTails :: (Transform sig b, Transform sig a) =>
(a -> sig b -> a) -> sig a -> sig b -> sig a
zipWithTails f =
flip (crochetL (\x ys0 ->
do (_,ys) <- viewL ys0
Just (f x ys0, ys)))
indexByDrop :: (Transform sig a) => sig a -> Int -> a
indexByDrop xs n =
if n<0
then error $ "Generic.index: negative index " ++ show n
else switchL
(error $ "Generic.index: index too large " ++ show n)
const
(Cut.drop n xs)