module Synthesizer.State.Signal where
import qualified Synthesizer.Plain.Modifier as Modifier
import qualified Data.List as List
import qualified Algebra.Module as Module
import qualified Algebra.Additive as Additive
import Algebra.Additive (zero)
import Algebra.Module ((*>))
import qualified Synthesizer.Format as Format
import Control.Monad.Trans.State
(runState, StateT(StateT), runStateT, )
import Control.Monad (Monad, mplus, msum,
(>>), (>>=), fail, return, (=<<),
liftM2,
Functor, fmap, )
import Data.Monoid (Monoid, mappend, mempty, )
import qualified Synthesizer.Storable.Signal as SigSt
import qualified Data.StorableVector.Lazy.Pattern as SVL
import Foreign.Storable (Storable)
import qualified Data.List.HT as ListHT
import Data.Tuple.HT (mapFst, mapSnd, mapPair, fst3, snd3, thd3, )
import Data.Function.HT (nest, )
import Data.Maybe.HT (toMaybe, )
import NumericPrelude (fromInteger, )
import Text.Show (Show(showsPrec), showParen, showString, )
import Data.Maybe (Maybe(Just, Nothing), maybe, fromMaybe, )
import Prelude
((.), ($), ($!), id, const, flip, curry, uncurry, fst, snd, error,
(>), (>=), max, Ord,
succ, pred, Bool(True,False), not, Int,
)
data T a =
forall s.
Cons !(StateT s Maybe a)
!s
instance (Show y) => Show (T y) where
showsPrec p x =
showParen (p >= 10)
(showString "StateSignal.fromList " . showsPrec 11 (toList x))
instance Format.C T where
format = showsPrec
instance Functor T where
fmap = map
generate :: (acc -> Maybe (y, acc)) -> acc -> T y
generate f = Cons (StateT f)
unfoldR :: (acc -> Maybe (y, acc)) -> acc -> T y
unfoldR = generate
generateInfinite :: (acc -> (y, acc)) -> acc -> T y
generateInfinite f = generate (Just . f)
fromList :: [y] -> T y
fromList = generate ListHT.viewL
toList :: T y -> [y]
toList (Cons f x0) =
List.unfoldr (runStateT f) x0
fromStorableSignal ::
(Storable a) =>
SigSt.T a -> T a
fromStorableSignal =
generate SigSt.viewL
toStorableSignal ::
(Storable a) =>
SigSt.ChunkSize -> T a -> SigSt.T a
toStorableSignal size (Cons f a) =
SigSt.unfoldr size (runStateT f) a
toStorableSignalVary ::
(Storable a) =>
SVL.LazySize -> T a -> SigSt.T a
toStorableSignalVary size (Cons f a) =
fst $ SVL.unfoldrN size (runStateT f) a
iterate :: (a -> a) -> a -> T a
iterate f = generateInfinite (\x -> (x, f x))
iterateAssociative :: (a -> a -> a) -> a -> T a
iterateAssociative op x = iterate (op x) x
repeat :: a -> T a
repeat = iterate id
crochetL :: (x -> acc -> Maybe (y, acc)) -> acc -> T x -> T y
crochetL g b (Cons f a) =
Cons
(StateT (\(a0,b0) ->
do (x0,a1) <- runStateT f a0
(y0,b1) <- g x0 b0
Just (y0, (a1,b1))))
(a,b)
scanL :: (acc -> x -> acc) -> acc -> T x -> T acc
scanL f start =
cons start .
crochetL (\x acc -> let y = f acc x in Just (y, y)) start
scanLClip :: (acc -> x -> acc) -> acc -> T x -> T acc
scanLClip f start =
crochetL (\x acc -> Just (acc, f acc x)) start
map :: (a -> b) -> (T a -> T b)
map f = crochetL (\x _ -> Just (f x, ())) ()
unzip :: T (a,b) -> (T a, T b)
unzip x = (map fst x, map snd x)
unzip3 :: T (a,b,c) -> (T a, T b, T c)
unzip3 xs = (map fst3 xs, map snd3 xs, map thd3 xs)
delay1 :: a -> T a -> T a
delay1 = crochetL (flip (curry Just))
delay :: y -> Int -> T y -> T y
delay z n = append (replicate n z)
take :: Int -> T a -> T a
take = crochetL (\x n -> toMaybe (n>zero) (x, pred n))
takeWhile :: (a -> Bool) -> T a -> T a
takeWhile p = crochetL (\x _ -> toMaybe (p x) (x, ())) ()
replicate :: Int -> a -> T a
replicate n = take n . repeat
zipWith :: (a -> b -> c) -> (T a -> T b -> T c)
zipWith h (Cons f a) =
crochetL
(\x0 a0 ->
do (y0,a1) <- runStateT f a0
Just (h y0 x0, a1))
a
zipWithStorable :: (Storable b, Storable c) =>
(a -> b -> c) -> (T a -> SigSt.T b -> SigSt.T c)
zipWithStorable h (Cons f a) =
SigSt.crochetL
(\x0 a0 ->
do (y0,a1) <- runStateT f a0
Just (h y0 x0, a1))
a
zipWith3 :: (a -> b -> c -> d) -> (T a -> T b -> T c -> T d)
zipWith3 f s0 s1 =
zipWith (uncurry f) (zip s0 s1)
zipWith4 :: (a -> b -> c -> d -> e) -> (T a -> T b -> T c -> T d -> T e)
zipWith4 f s0 s1 =
zipWith3 (uncurry f) (zip s0 s1)
zip :: T a -> T b -> T (a,b)
zip = zipWith (,)
zip3 :: T a -> T b -> T c -> T (a,b,c)
zip3 = zipWith3 (,,)
zip4 :: T a -> T b -> T c -> T d -> T (a,b,c,d)
zip4 = zipWith4 (,,,)
foldL' :: (x -> acc -> acc) -> acc -> T x -> acc
foldL' g b =
switchL b (\ x xs -> foldL' g (g x $! b) xs)
foldL :: (acc -> x -> acc) -> acc -> T x -> acc
foldL f = foldL' (flip f)
length :: T a -> Int
length = foldL' (const succ) zero
foldR :: (x -> acc -> acc) -> acc -> T x -> acc
foldR g b =
switchL b (\ x xs -> g x (foldR g b xs))
null :: T a -> Bool
null =
switchL True (const (const False))
empty :: T a
empty = generate (const Nothing) ()
singleton :: a -> T a
singleton =
generate (fmap (\x -> (x, Nothing))) . Just
cons :: a -> T a -> T a
cons x xs =
generate
(\(mx0,xs0) ->
fmap (mapSnd ((,) Nothing)) $
maybe
(viewL xs0)
(\x0 -> Just (x0, xs0))
mx0) $
(Just x, xs)
viewL :: T a -> Maybe (a, T a)
viewL (Cons f a0) =
fmap
(mapSnd (Cons f))
(runStateT f a0)
viewR :: Storable a => T a -> Maybe (T a, a)
viewR = viewRSize SigSt.defaultChunkSize
viewRSize :: Storable a => SigSt.ChunkSize -> T a -> Maybe (T a, a)
viewRSize size =
fmap (mapFst fromStorableSignal) .
SigSt.viewR .
toStorableSignal size
switchL :: b -> (a -> T a -> b) -> T a -> b
switchL n j =
maybe n (uncurry j) . viewL
switchR :: Storable a => b -> (T a -> a -> b) -> T a -> b
switchR n j =
maybe n (uncurry j) . viewR
extendConstant :: T a -> T a
extendConstant xt0 =
switchL
empty
(\ x0 _ ->
generate
(\xt1@(x1,xs1) ->
Just $ switchL
(x1,xt1)
(\x xs -> (x, (x,xs)))
xs1)
(x0,xt0)) $
xt0
drop :: Int -> T a -> T a
drop n =
fromMaybe empty .
nest n (fmap snd . viewL =<<) .
Just
dropMarginRem :: Int -> Int -> T a -> (Int, T a)
dropMarginRem n m =
switchL (error "StateSignal.dropMaringRem: length xs < n") const .
dropMargin n m .
zipWithTails (,) (iterate pred m)
dropMargin :: Int -> Int -> T a -> T a
dropMargin n m xs =
dropMatch (take m (drop n xs)) xs
dropMatch :: T b -> T a -> T a
dropMatch xs ys =
fromMaybe ys $
liftM2 dropMatch
(fmap snd $ viewL xs)
(fmap snd $ viewL ys)
index :: Int -> T a -> a
index n =
switchL (error "State.Signal: index too large") const . drop n
splitAt :: Storable a =>
Int -> T a -> (T a, T a)
splitAt = splitAtSize SigSt.defaultChunkSize
splitAtSize :: Storable a =>
SigSt.ChunkSize -> Int -> T a -> (T a, T a)
splitAtSize size n =
mapPair (fromStorableSignal, fromStorableSignal) .
SigSt.splitAt n .
toStorableSignal size
dropWhile :: (a -> Bool) -> T a -> T a
dropWhile p xt =
switchL empty (\ x xs -> if p x then dropWhile p xs else xt) xt
span :: Storable a =>
(a -> Bool) -> T a -> (T a, T a)
span = spanSize SigSt.defaultChunkSize
spanSize :: Storable a =>
SigSt.ChunkSize -> (a -> Bool) -> T a -> (T a, T a)
spanSize size p =
mapPair (fromStorableSignal, fromStorableSignal) .
SigSt.span p .
toStorableSignal size
cycle :: T a -> T a
cycle xs =
switchL
(error "StateSignal.cycle: empty input")
(curry $ \yt -> generate (Just . fromMaybe yt . viewL) xs)
xs
mix :: Additive.C a => T a -> T a -> T a
mix = zipWithAppend (Additive.+)
sub :: Additive.C a => T a -> T a -> T a
sub xs ys = mix xs (neg ys)
neg :: Additive.C a => T a -> T a
neg = map Additive.negate
instance Additive.C y => Additive.C (T y) where
zero = empty
(+) = mix
() = sub
negate = neg
instance Module.C y yv => Module.C y (T yv) where
(*>) x y = map (x*>) y
infixr 5 `append`
append :: T a -> T a -> T a
append xs ys =
generate
(\(b,xs0) ->
mplus
(fmap (mapSnd ((,) b)) $ viewL xs0)
(if b
then Nothing
else fmap (mapSnd ((,) True)) $ viewL ys))
(False,xs)
appendStored :: Storable a =>
T a -> T a -> T a
appendStored = appendStoredSize SigSt.defaultChunkSize
appendStoredSize :: Storable a =>
SigSt.ChunkSize -> T a -> T a -> T a
appendStoredSize size xs ys =
fromStorableSignal $
SigSt.append
(toStorableSignal size xs)
(toStorableSignal size ys)
concat :: [T a] -> T a
concat =
generate
(msum .
List.map
(\ x -> ListHT.viewL x >>=
\(y,ys) -> viewL y >>=
\(z,zs) -> Just (z,zs:ys)) .
List.init . List.tails)
concatStored :: Storable a =>
[T a] -> T a
concatStored = concatStoredSize SigSt.defaultChunkSize
concatStoredSize :: Storable a =>
SigSt.ChunkSize -> [T a] -> T a
concatStoredSize size =
fromStorableSignal .
SigSt.concat .
List.map (toStorableSignal size)
reverse ::
T a -> T a
reverse =
fromList . List.reverse . toList
reverseStored :: Storable a =>
T a -> T a
reverseStored = reverseStoredSize SigSt.defaultChunkSize
reverseStoredSize :: Storable a =>
SigSt.ChunkSize -> T a -> T a
reverseStoredSize size =
fromStorableSignal .
SigSt.reverse .
toStorableSignal size
sum :: (Additive.C a) => T a -> a
sum = foldL' (Additive.+) Additive.zero
maximum :: (Ord a) => T a -> a
maximum =
switchL
(error "StateSignal.maximum: empty list")
(foldL' max)
init :: T y -> T y
init =
switchL
(error "StateSignal.init: empty list")
(crochetL (\x acc -> Just (acc,x)))
sliceVert :: Int -> T y -> [T y]
sliceVert n =
List.map (take n) . List.takeWhile (not . null) . List.iterate (drop n)
zapWith :: (a -> a -> b) -> T a -> T b
zapWith f =
switchL empty
(crochetL (\y x -> Just (f x y, y)))
zapWithAlt :: (a -> a -> b) -> T a -> T b
zapWithAlt f xs =
zipWith f xs (switchL empty (curry snd) xs)
modifyStatic :: Modifier.Simple s ctrl a b -> ctrl -> T a -> T b
modifyStatic modif control x =
crochetL
(\a acc ->
Just (runState (Modifier.step modif control a) acc))
(Modifier.init modif) x
modifyModulated :: Modifier.Simple s ctrl a b -> T ctrl -> T a -> T b
modifyModulated modif control x =
crochetL
(\ca acc ->
Just (runState (uncurry (Modifier.step modif) ca) acc))
(Modifier.init modif)
(zip control x)
linearComb ::
(Module.C t y) =>
T t -> T y -> y
linearComb ts ys =
sum $ zipWith (*>) ts ys
mapTails ::
(T y0 -> y1) -> T y0 -> T y1
mapTails f =
generate (\xs ->
do (_,ys) <- viewL xs
return (f xs, ys))
zipWithTails ::
(y0 -> T y1 -> y2) -> T y0 -> T y1 -> T y2
zipWithTails f =
curry $ generate (\(xs0,ys0) ->
do (x,xs) <- viewL xs0
(_,ys) <- viewL ys0
return (f x ys0, (xs,ys)))
zipWithAppend ::
(y -> y -> y) ->
T y -> T y -> T y
zipWithAppend f =
curry (unfoldR (zipStep f))
zipStep ::
(a -> a -> a) -> (T a, T a) -> Maybe (a, (T a, T a))
zipStep f (xt,yt) =
case (viewL xt, viewL yt) of
(Just (x,xs), Just (y,ys)) -> Just (f x y, (xs,ys))
(Nothing, Just (y,ys)) -> Just (y, (xt,ys))
(Just (x,xs), Nothing) -> Just (x, (xs,yt))
(Nothing, Nothing) -> Nothing
delayLoop ::
(T y -> T y)
-> T y
-> T y
delayLoop proc prefix =
let ys = fromList (toList prefix List.++ toList (proc ys))
in ys
delayLoopOverlap ::
(Additive.C y) =>
Int
-> (T y -> T y)
-> T y
-> T y
delayLoopOverlap time proc xs =
let ys = zipWith (Additive.+) xs (delay zero time (proc (fromList (toList ys))))
in ys
sequence_ :: Monad m => T (m a) -> m ()
sequence_ =
switchL (return ()) (\x xs -> x >> sequence_ xs)
mapM_ :: Monad m => (a -> m ()) -> T a -> m ()
mapM_ f = sequence_ . map f
monoidConcat :: Monoid m => T m -> m
monoidConcat = foldR mappend mempty
monoidConcatMap :: Monoid m => (a -> m) -> T a -> m
monoidConcatMap f = monoidConcat . map f
instance Monoid (T y) where
mempty = empty
mappend = append