module Synthesizer.FusionList.Signal where
import qualified Synthesizer.Plain.Signal as Sig
import qualified Synthesizer.Plain.Modifier as Modifier
import qualified Data.List as List
import qualified Data.StorableVector.Lazy as Vector
import Data.StorableVector.Lazy (ChunkSize, Vector)
import Foreign.Storable (Storable, )
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, )
import Data.Monoid (Monoid, mempty, mappend, )
import qualified Data.List.HT as ListHT
import Data.Tuple.HT (mapFst, mapSnd, mapPair, fst3, snd3, thd3, )
import Data.Maybe.HT (toMaybe)
import NumericPrelude (fromInteger, )
import Text.Show (Show(showsPrec), showParen, showString, )
import Data.Maybe (Maybe(Just, Nothing), maybe)
import Prelude
((.), ($), id, const, flip, curry, uncurry, fst, snd, error,
(>), (>=), max, Ord,
succ, pred, Bool, not, Int, Functor, fmap,
(>>), (>>=), fail, return, (=<<),
)
newtype T y = Cons {decons :: [y]}
instance (Show y) => Show (T y) where
showsPrec p x =
showParen (p >= 10)
(showString "FusionList.fromList " . showsPrec 11 (toList x))
instance Format.C T where
format = showsPrec
instance Functor T where
fmap = map
instance Monoid (T y) where
mempty = empty
mappend = append
generate :: (acc -> Maybe (y, acc)) -> acc -> T y
generate f = Cons . snd . Sig.unfoldR 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 = decons
toStorableSignal :: Storable y => ChunkSize -> T y -> Vector y
toStorableSignal size = Vector.pack size . decons
fromStorableSignal :: Storable y => Vector y -> T y
fromStorableSignal = Cons . Vector.unpack
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 f a = Cons . Sig.crochetL f a . decons
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 f s0 s1 =
Cons $ List.zipWith f (decons s0) (decons s1)
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 (,,,)
reduceL :: (x -> acc -> Maybe acc) -> acc -> T x -> acc
reduceL f x = Sig.reduceL f x . decons
foldL' :: (x -> acc -> acc) -> acc -> T x -> acc
foldL' f = reduceL (\x -> Just . f x)
foldL :: (acc -> x -> acc) -> acc -> T x -> acc
foldL f = foldL' (flip f)
lengthSlow :: T a -> Int
lengthSlow = foldL' (const succ) zero
zipWithGenerate ::
(a -> b -> c)
-> (acc -> Maybe (a, acc))
-> acc
-> T b -> T c
zipWithGenerate h f a y =
crochetL (\y0 a0 ->
do (x0,a1) <- f a0
Just (h x0 y0, a1)) a y
zipWithCrochetL ::
(a -> b -> c)
-> (x -> acc -> Maybe (a, acc))
-> acc
-> T x -> T b -> T c
zipWithCrochetL h f a x y =
crochetL (\(x0,y0) a0 ->
do (z0,a1) <- f x0 a0
Just (h z0 y0, a1))
a (zip x y)
mixGenerate :: (Additive.C a) =>
(a -> a -> a)
-> (acc -> Maybe (a, acc))
-> acc
-> T a -> T a
mixGenerate plus f a =
crochetL
(\y0 a0 ->
Just (maybe
(y0, Nothing)
(\(x0,a1) -> (plus x0 y0, Just a1))
(f =<< a0)))
(Just a)
crochetLCons ::
(a -> acc -> Maybe (b, acc))
-> acc
-> a -> T a -> T b
crochetLCons f a0 x xs =
maybe
empty
(\(y,a1) -> cons y (crochetL f a1 xs))
(f x a0)
reduceLCons ::
(a -> acc -> Maybe acc)
-> acc
-> a -> T a -> acc
reduceLCons f a0 x xs =
maybe a0 (flip (reduceL f) xs) (f x a0)
zipWithCons ::
(a -> b -> c)
-> a -> T a -> T b -> T c
zipWithCons f x xs =
maybe
empty
(\(y,ys) -> cons (f x y) (zipWith f xs ys))
. viewL
null :: T a -> Bool
null = List.null . decons
empty :: T a
empty = Cons []
singleton :: a -> T a
singleton = Cons . (: [])
cons :: a -> T a -> T a
cons x = Cons . (x :) . decons
length :: T a -> Int
length = List.length . decons
viewL :: T a -> Maybe (a, T a)
viewL =
fmap (mapSnd Cons) . ListHT.viewL . decons
viewR :: T a -> Maybe (T a, a)
viewR =
fmap (mapFst Cons) . ListHT.viewR . decons
extendConstant :: T a -> T a
extendConstant xt =
maybe empty (append xt . repeat . snd) $
viewR xt
tail :: T a -> T a
tail = Cons . List.tail . decons
head :: T a -> a
head = List.head . decons
drop :: Int -> T a -> T a
drop n = Cons . List.drop n . decons
dropMarginRem :: Int -> Int -> T a -> (Int, T a)
dropMarginRem n m = mapSnd Cons . Sig.dropMarginRem n m . decons
dropMargin :: Int -> Int -> T a -> T a
dropMargin n m = Cons . Sig.dropMargin n m . decons
index :: Int -> T a -> a
index n = (List.!! n) . decons
splitAt :: Int -> T a -> (T a, T a)
splitAt n = mapPair (Cons, Cons) . List.splitAt n . decons
dropWhile :: (a -> Bool) -> T a -> T a
dropWhile p = Cons . List.dropWhile p . decons
span :: (a -> Bool) -> T a -> (T a, T a)
span p = mapPair (Cons, Cons) . List.span p . decons
mapAccumL :: (acc -> x -> (acc, y)) -> acc -> T x -> (acc, T y)
mapAccumL f acc = mapSnd Cons . List.mapAccumL f acc . decons
mapAccumR :: (acc -> x -> (acc, y)) -> acc -> T x -> (acc, T y)
mapAccumR f acc = mapSnd Cons . List.mapAccumR f acc . decons
cycle :: T a -> T a
cycle = Cons . List.cycle . decons
mix :: Additive.C a => T a -> T a -> T a
mix (Cons xs) (Cons ys) = Cons (xs Additive.+ ys)
sub :: Additive.C a => T a -> T a -> T a
sub (Cons xs) (Cons ys) = Cons (xs Additive.- ys)
neg :: Additive.C a => T a -> T a
neg (Cons xs) = Cons (Additive.negate xs)
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 (Cons xs) (Cons ys) = Cons (xs List.++ ys)
concat :: [T a] -> T a
concat = Cons . List.concat . List.map decons
reverse :: T a -> T a
reverse = Cons . List.reverse . decons
sum :: (Additive.C a) => T a -> a
sum = foldL' (Additive.+) Additive.zero
maximum :: (Ord a) => T a -> a
maximum =
maybe
(error "FusionList.maximum: empty list")
(uncurry (foldL' max))
. viewL
tails :: T y -> [T y]
tails = List.map Cons . List.tails . decons
init :: T y -> T y
init = Cons . List.init . decons
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 xs0 =
let xs1 = maybe empty snd (viewL xs0)
in zipWith f xs0 xs1
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)))
zipWithRest ::
(y0 -> y0 -> y1) ->
T y0 -> T y0 ->
(T y1, (Bool, T y0))
zipWithRest f xs ys =
mapPair (fromList, mapSnd fromList) $
Sig.zipWithRest f
(toList xs) (toList ys)
zipWithAppend ::
(y -> y -> y) ->
T y -> T y -> T y
zipWithAppend f xs ys =
uncurry append $ mapSnd snd $ zipWithRest f xs ys
delayLoop ::
(T y -> T y)
-> T y
-> T y
delayLoop proc prefix =
let ys = append prefix (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 ys))
in ys
recourse :: (acc -> Maybe acc) -> acc -> acc
recourse f =
let aux x = maybe x aux (f x)
in aux