{-# OPTIONS_GHC -O -fglasgow-exts #-} {- glasgow-exts are for the rules -} module Sound.Signal where import Synthesizer.Utility (viewListL) import NumericPrelude.Condition (toMaybe) import Prelude hiding ((++), iterate, foldl, map, repeat, replicate, zipWith, zipWith3, take, takeWhile) {- Signals can be lazy, but not necessarily element-wise lazy. All values of signals must be defined. In future it may re-use functionality from "Data.Foldable" and "Data.Traversable". Functions with accumulators always have a 'Maybe' result, in order to be able to fuse them. -} class C s where singleton :: a -> s a unfoldR :: (acc -> Maybe (y, acc)) -> acc -> (acc, s y) reduceL :: (x -> acc -> Maybe acc) -> acc -> s x -> acc mapAccumL :: (x -> acc -> Maybe (y, acc)) -> acc -> s x -> (acc, s y) (++) :: s a -> s a -> s a zipWith :: (a -> b -> c) -> s a -> s b -> s c {- Typical examples for neither generate nor crochet: data from disk toList (this is a foldR) reverse drop resample Fourier transform (++) (it could be fused, but the fused variant needs checking a phase state each cycle which is certainly less efficient than separate loops) -} {- Typical examples for zipWith: mixer controlled recursive filter -} {- Typical examples for foldL: volume computation DC offset histogram -} {- 'generate' could be expressed as 'crochetL' on an empty signal (type @s ()@). This would reduce the number of rules, but at the end of optimization there shouldn't be such 'crochetL's left that can represented as 'generate', because 'generate' is more efficient. Typical examples for generate: fromList uncontrolled oscillator constant curve linear curve exponential curve noise generation -} generate :: C s => (acc -> Maybe (y, acc)) -> acc -> s y generate f = snd . unfoldR f {-# INLINE fromList #-} fromList :: C s => [y] -> s y fromList = generate viewListL {-# INLINE iterate #-} iterate :: C s => (a -> a) -> a -> s a iterate f = generate (\x -> Just (x, f x)) {-# INLINE repeat #-} repeat :: C s => a -> s a repeat = iterate id cycle :: C s => s a -> s a cycle x = let result = x ++ result in result {-# INLINE foldL' #-} foldL' :: C s => (x -> acc -> acc) -> acc -> s x -> acc foldL' f = reduceL (\x -> Just . f x) {-# INLINE lengthSlow #-} {- | can be used to check against native length implementation -} lengthSlow :: C s => s a -> Int lengthSlow = foldL' (const succ) 0 recurse :: (acc -> Maybe acc) -> acc -> acc recurse f = let aux x = maybe x aux (f x) in aux {- Typical examples for crochetL: controlled oscillator enveloping uncontrolled recursive filter small delay take -} crochetL :: C s => (x -> acc -> Maybe (y, acc)) -> acc -> s x -> s y crochetL f a = snd . mapAccumL f a {-# INLINE scanL #-} scanL :: C s => (x -> acc -> acc) -> acc -> s x -> s acc scanL f start xs = singleton start ++ crochetL (\x acc -> let y = f x acc in Just (y, y)) start xs {-# INLINE map #-} map :: C s => (a -> b) -> (s a -> s b) map f = crochetL (\x _ -> Just (f x, ())) () unzip :: C s => s (a,b) -> (s a, s b) unzip x = (map fst x, map snd x) {-# INLINE delay1 #-} {- | This is a fusion friendly implementation of delay. However, in order to be a 'crochetL' the output has the same length as the input, that is, the last element is removed - at least for finite input. -} delay1 :: C s => a -> s a -> s a delay1 = crochetL (flip (curry Just)) {-# INLINE take #-} take :: C s => Int -> s a -> s a take = crochetL (\x n -> toMaybe (n>0) (x, pred n)) {-# INLINE takeWhile #-} takeWhile :: C s => (a -> Bool) -> s a -> s a takeWhile p = crochetL (\x _ -> toMaybe (p x) (x, ())) () {-# INLINE replicate #-} replicate :: C s => Int -> a -> s a replicate n = take n . repeat {-# INLINE zipWith3 #-} zipWith3 :: C s => (a -> b -> c -> d) -> (s a -> s b -> s c -> s d) zipWith3 f s0 s1 = zipWith (uncurry f) (zipWith (,) s0 s1) {-# INLINE zipWith4 #-} zipWith4 :: C s => (a -> b -> c -> d -> e) -> (s a -> s b -> s c -> s d -> s e) zipWith4 f s0 s1 = zipWith3 (uncurry f) (zipWith (,) s0 s1) {- The rules "zipWith/*,generate" and "zipWith/*,crochetL" may generate infinite loops because GHC is free to choose "zipWith/generate,*" or "zipWith/*,generate". If it always chooses the latter one, it will loop forever. -} {-# RULES "crochetL/generate" forall f g a b. crochetL g b (generate f a) = generate (\(a0,b0) -> do (y0,a1) <- f a0 (z0,b1) <- g y0 b0 return (z0, (a1,b1))) (a,b) ; "crochetL/crochetL" forall f g a b x. crochetL g b (crochetL f a x) = crochetL (\x0 (a0,b0) -> do (y0,a1) <- f x0 a0 (z0,b1) <- g y0 b0 return (z0, (a1,b1))) (a,b) x ; "zipWith/generate,*" forall f h a y. zipWith h (generate f a) y = crochetL (\y0 a0 -> do (x0,a1) <- f a0 return (h x0 y0, a1)) a y ; "zipWith/crochetL,*" forall f h a x y. zipWith h (crochetL f a x) y = crochetL (\(x0,y0) a0 -> do (z0,a1) <- f x0 a0 return (h z0 y0, a1)) a (zipWith (,) x y) ; "zipWith/*,generate" forall f h a y. zipWith h y (generate f a) = zipWith (flip h) (generate f a) y ; "zipWith/*,crochetL" forall f h a x y. zipWith h y (crochetL f a x) = zipWith (flip h) (crochetL f a x) y ; "zipWith/double" forall (h :: a->a->b) (x :: s a). zipWith h x x = map (\xi -> h xi xi) x ; "reduceL/generate" forall f g a b. reduceL g b (generate f a) = snd (recurse (\(a0,b0) -> do (y,a1) <- f a0 b1 <- g y b0 return (a1, b1)) (a,b)) ; "reduceL/crochetL" forall f g a b x. reduceL g b (crochetL f a x) = snd (reduceL (\x0 (a0,b0) -> do (y,a1) <- f x0 a0 b1 <- g y b0 return (a1, b1)) (a,b) x) ; #-}