Signal.hs

{-# OPTIONS_GHC -fenable-rewrite-rules #-}
{- |
Chunky signal stream build on StorableVector.

Hints for fusion:
 - Higher order functions should always be inlined in the end
   in order to turn them into machine loops
   instead of calling a function in an inner loop.
-}
module Synthesizer.Storable.Signal (
   T,
   Vector.hPut,
   ChunkSize, Vector.chunkSize, defaultChunkSize,
   -- for Storable.Oscillator
   scanL,
   Vector.map,
   Vector.iterate,
   Vector.zipWith,
   -- for State.Signal
   Vector.append,
   Vector.concat,
   Vector.span,
   Vector.splitAt,
   Vector.viewL,
   Vector.viewR,
   Vector.switchL,
   Vector.unfoldr,
   Vector.reverse,
   Vector.crochetL,
   -- for Dimensional.File
   Vector.writeFile,
   -- for Storable.Cut
   mix, mixSndPattern, mixSize,
   splitAtPad,
   Vector.null,
   Vector.fromChunks,
   Vector.foldr,
   -- for Storable.Filter.Comb
   delay,
   delayLoop,
   delayLoopOverlap,
   -- for FusionList.Storable
   Vector.empty,
   Vector.cons,
   Vector.replicate,
   Vector.repeat,
   Vector.drop,
   Vector.take,
   takeCrochet,
   fromList,
   -- for Generic.Signal
   zipWithRest,
   zipWithAppend,
   -- for Storable.ALSA.MIDI
   Vector.switchR,
   -- for Test.Filter
   toList,
   -- for Storable.Filter.NonRecursive
   Vector.chunks,

   -- just for fun
   genericLength,
   ) where

import qualified Data.List as List
import qualified Data.StorableVector.Lazy.Pointer as Pointer
import qualified Data.StorableVector.Lazy as Vector
import qualified Data.StorableVector as V
import Data.StorableVector.Lazy (ChunkSize(..))

import Foreign.Storable (Storable, )
import Foreign.Storable.Tuple ()

import qualified Synthesizer.Frame.Stereo as Stereo

import qualified Data.List.HT as ListHT
import Data.Maybe.HT (toMaybe, )
import Data.Tuple.HT (mapFst, mapSnd, mapPair, forcePair, )

import qualified Algebra.Ring      as Ring
import qualified Algebra.Additive  as Additive
import qualified Algebra.ToInteger as ToInteger

import qualified Number.NonNegativeChunky as Chunky
import qualified Number.NonNegative       as NonNeg

import NumericPrelude.Numeric
import NumericPrelude.Base
import Prelude ()


-- this form is needed for Storable signal embed in amplitude signal
type T = Vector.Vector


defaultChunkSize :: ChunkSize
defaultChunkSize = ChunkSize 1024


{-# INLINE fromList #-}
fromList :: (Storable a) => ChunkSize -> [a] -> T a
fromList = Vector.pack

{-# INLINE toList #-}
toList :: (Storable a) => T a -> [a]
toList = Vector.unpack


{-# INLINE scanL #-}
scanL :: (Storable a, Storable b) =>
   (a -> b -> a) -> a -> T b -> T a
scanL = Vector.scanl


{- |
This implementation generates laziness breaks
whereever one of the original sequences has laziness breaks.
It should be commutative in this respect.

It is more efficient than 'mixSize'
since it appends the rest of the longer signal without copying.
-}
{-# SPECIALISE mix :: T Double -> T Double -> T Double #-}
{-# SPECIALISE mix :: T Float -> T Float -> T Float #-}
{-# SPECIALISE mix :: T (Double,Double) -> T (Double,Double) -> T (Double,Double) #-}
{-# SPECIALISE mix :: T (Float,Float) -> T (Float,Float) -> T (Float,Float) #-}
{-# SPECIALISE mix :: T (Stereo.T Double) -> T (Stereo.T Double) -> T (Stereo.T Double) #-}
{-# SPECIALISE mix :: T (Stereo.T Float) -> T (Stereo.T Float) -> T (Stereo.T Float) #-}
{-# INLINE mix #-}
mix :: (Additive.C x, Storable x) =>
   T x ->
   T x ->
   T x
mix = zipWithAppend (+)
{-
List.map V.unpack $ Vector.chunks $ mix (fromList defaultChunkSize [1,2,3,4,5::P.Double]) (fromList defaultChunkSize [1,2,3,4])
-}

{- |
Mix while maintaining the pattern of the second operand.
This is closer to the behavior of Vector.zipWithLastPattern.
-}
{-# INLINE mixSndPattern #-}
mixSndPattern :: (Additive.C x, Storable x) =>
   T x ->
   T x ->
   T x
mixSndPattern xs0 ys0 =
   let recourse xs (y:ys) =
              snd (V.mapAccumL
                 (\p0 yi ->
                    Pointer.switchL (p0,yi)
                       (\xi p1 -> (p1,xi+yi)) p0)
                 (Pointer.cons xs) y)
              :
              recourse (Vector.drop (V.length y) xs) ys
       recourse xs [] = Vector.chunks xs
   in  Vector.fromChunks $
       recourse xs0 (Vector.chunks ys0)


{-# INLINE zipWithAppend #-}
zipWithAppend ::
   (Storable x) =>
   (x -> x -> x) ->
   T x -> T x -> T x
zipWithAppend f xs0 ys0 =
   let recourse xt@(x:_) yt@(y:_) =
          let z = V.zipWith f x y
              n = V.length z
          in  z : recourse
                     (Vector.chunks $ Vector.drop n $ Vector.fromChunks xt)
                     (Vector.chunks $ Vector.drop n $ Vector.fromChunks yt)
       recourse xs [] = xs
       recourse [] ys = ys
   in  Vector.fromChunks $
       recourse (Vector.chunks xs0) (Vector.chunks ys0)

{- |
It also preserves the chunk structure of the second signal,
which is essential if you want to limit look-ahead.

This implementation seems to have a memory leak!
-}
{-# INLINE _zipWithAppendRest #-}
_zipWithAppendRest ::
   (Storable x) =>
   (x -> x -> x) ->
   T x -> T x -> T x
_zipWithAppendRest f xs ys =
   uncurry Vector.append $ mapSnd snd $ zipWithRest f xs ys

{-# INLINE zipWithRest #-}
zipWithRest ::
   (Storable c, Storable x) =>
   (x -> x -> c) ->
   T x ->
   T x ->
   (Vector.Vector c, (Bool, T x))
zipWithRest f xs ys =
   let len = min (lazyLength xs) (lazyLength ys) :: Chunky.T NonNeg.Int
       (prefixX,suffixX) = genericSplitAt len xs
       (prefixY,suffixY) = genericSplitAt len ys
       second = Vector.null suffixX
   in  (Vector.zipWithLastPattern f prefixX prefixY,
        (second, if second then suffixY else suffixX))

{-
We should move that to StorableVector package,
but we cannot, since that's Haskell 98.
-}
genericSplitAt ::
   (Additive.C i, Ord i, ToInteger.C i, Storable x) =>
   i -> T x -> (T x, T x)
genericSplitAt n0 =
   let recourse n xs0 =
          forcePair $
          ListHT.switchL
             ([], [])
             (\x xs ->
                if isZero n
                  then ([], xs0)
                  else
                    let m = fromIntegral $ V.length x
                    in  if m<=n
                          then mapFst (x:) $ recourse (n-m) xs
                          else mapPair ((:[]), (:xs)) $
                               V.splitAt (fromInteger $ toInteger n) x)
             xs0
   in  mapPair (Vector.fromChunks, Vector.fromChunks) .
       recourse n0 . Vector.chunks


-- cf. Data.StorableVector.Lazy.Pattern.length
lazyLength :: (Ring.C i) =>
   T x -> i
lazyLength =
   List.foldr (+) zero . List.map (fromIntegral . V.length) . Vector.chunks

genericLength :: (Ring.C i) =>
   T x -> i
genericLength =
   sum . List.map (fromIntegral . V.length) . Vector.chunks


splitAtPad ::
   (Additive.C x, Storable x) =>
   ChunkSize -> Int -> T x -> (T x, T x)
splitAtPad size n =
   mapFst (Vector.pad size Additive.zero n) . Vector.splitAt n


{- disabled SPECIALISE mixSize :: ChunkSize -> T Double -> T Double -> T Double -}
{- disabled SPECIALISE mixSize :: ChunkSize -> T Float -> T Float -> T Float -}
{- disabled SPECIALISE mixSize :: ChunkSize -> T (Double,Double) -> T (Double,Double) -> T (Double,Double) -}
{- disabled SPECIALISE mixSize :: ChunkSize -> T (Float,Float) -> T (Float,Float) -> T (Float,Float) -}
{-# INLINE mixSize #-}
mixSize :: (Additive.C x, Storable x) =>
      ChunkSize
   -> T x
   -> T x
   -> T x
mixSize size xs ys =
   Vector.unfoldr size mixStep
      (Pointer.cons xs, Pointer.cons ys)


{-# INLINE mixStep #-}
mixStep :: (Additive.C x, Storable x) =>
   (Pointer.Pointer x, Pointer.Pointer x) ->
   Maybe (x, (Pointer.Pointer x, Pointer.Pointer x))
mixStep (xt,yt) =
   case (Pointer.viewL xt, Pointer.viewL yt) of
      (Just (x,xs), Just (y,ys)) -> Just (x+y, (xs,ys))
      (Nothing,     Just (y,ys)) -> Just (y,   (xt,ys))
      (Just (x,xs), Nothing)     -> Just (x,   (xs,yt))
      (Nothing,     Nothing)     -> Nothing



{-# INLINE delay #-}
delay :: (Storable y) =>
   ChunkSize -> y -> Int -> T y -> T y
delay size z n = Vector.append (Vector.replicate size n z)

{-# INLINE delayLoop #-}
delayLoop ::
   (Storable y) =>
      (T y -> T y)
            -- ^ processor that shall be run in a feedback loop
   -> T y   -- ^ prefix of the output, its length determines the delay
   -> T y
delayLoop proc prefix =
   let ys = Vector.append prefix (proc ys)
   in  ys


{-# INLINE delayLoopOverlap #-}
delayLoopOverlap ::
   (Additive.C y, Storable y) =>
      Int
   -> (T y -> T y)
            {- ^ Processor that shall be run in a feedback loop.
                 It's absolutely necessary that this function preserves the chunk structure
                 and that it does not look a chunk ahead.
                 That's guaranteed for processes that do not look ahead at all,
                 like 'Vector.map', 'Vector.crochetL' and
                 all of type @Causal.Process@. -}
   -> T y   -- ^ input
   -> T y   -- ^ output has the same length as the input
delayLoopOverlap time proc xs =
   let ys = Vector.zipWith (Additive.+) xs
               (delay (Vector.chunkSize time) Additive.zero time (proc ys))
   in  ys



{-# INLINE takeCrochet #-}
takeCrochet :: Storable a => Int -> T a -> T a
takeCrochet = Vector.crochetL (\x n -> toMaybe (n>0) (x, pred n))