module Synthesizer.FusionList.Signal where
import qualified Synthesizer.Generic.Signal as SigG
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.State (State, runState, )
import Synthesizer.Utility
(viewListL, viewListR, mapFst, mapSnd, mapPair, fst3, snd3, thd3)
import NumericPrelude.Condition (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 SigG.C T where
empty = empty
null = null
cons = cons
fromList = fromList
toList = toList
repeat = repeat
cycle = cycle
replicate = replicate
iterate = iterate
iterateAssoc op x = iterate (op x) x
unfoldR = generate
map = map
mix = mix
zipWith = zipWith
scanL = scanL
viewL = viewL
viewR = viewR
foldL = foldL
length = length
take = take
drop = drop
splitAt = splitAt
dropMarginRem = dropMarginRem
takeWhile = takeWhile
dropWhile = dropWhile
span = span
append = append
concat = concat
reverse = reverse
crochetL = crochetL
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 viewListL
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))
iterateAssoc :: (a -> a -> a) -> a -> T a
iterateAssoc 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) . viewListL . decons
viewR :: T a -> Maybe (T a, a)
viewR =
fmap (mapFst Cons) . viewListR . 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)))
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
recurse :: (acc -> Maybe acc) -> acc -> acc
recurse f =
let aux x = maybe x aux (f x)
in aux