Signal.hs

{-# 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) ;
  #-}