{-# 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
defaultChunkSize = Int -> ChunkSize
ChunkSize Int
1024


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

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


{-# INLINE scanL #-}
scanL :: (Storable a, Storable b) =>
   (a -> b -> a) -> a -> T b -> T a
scanL :: forall a b.
(Storable a, Storable b) =>
(a -> b -> a) -> a -> T b -> T a
scanL = forall a b.
(Storable a, Storable b) =>
(a -> b -> a) -> a -> T b -> T a
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 :: forall x. (C x, Storable x) => T x -> T x -> T x
mix = forall x. Storable x => (x -> x -> x) -> T x -> T x -> T x
zipWithAppend forall a. C a => a -> a -> a
(+)
{-
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 :: forall x. (C x, Storable x) => T x -> T x -> T x
mixSndPattern T x
xs0 T x
ys0 =
   let recourse :: Vector a -> [Vector a] -> [Vector a]
recourse Vector a
xs (Vector a
y:[Vector a]
ys) =
              forall a b. (a, b) -> b
snd (forall a b acc.
(Storable a, Storable b) =>
(acc -> a -> (acc, b)) -> acc -> Vector a -> (acc, Vector b)
V.mapAccumL
                 (\Pointer a
p0 a
yi ->
                    forall a b.
Storable a =>
b -> (a -> Pointer a -> b) -> Pointer a -> b
Pointer.switchL (Pointer a
p0,a
yi)
                       (\a
xi Pointer a
p1 -> (Pointer a
p1,a
xiforall a. C a => a -> a -> a
+a
yi)) Pointer a
p0)
                 (forall a. Storable a => Vector a -> Pointer a
Pointer.cons Vector a
xs) Vector a
y)
              forall a. a -> [a] -> [a]
:
              Vector a -> [Vector a] -> [Vector a]
recourse (forall a. Storable a => Int -> Vector a -> Vector a
Vector.drop (forall a. Vector a -> Int
V.length Vector a
y) Vector a
xs) [Vector a]
ys
       recourse Vector a
xs [] = forall a. Vector a -> [Vector a]
Vector.chunks Vector a
xs
   in  forall a. Storable a => [Vector a] -> Vector a
Vector.fromChunks forall a b. (a -> b) -> a -> b
$
       forall {a}.
(Storable a, C a) =>
Vector a -> [Vector a] -> [Vector a]
recourse T x
xs0 (forall a. Vector a -> [Vector a]
Vector.chunks T x
ys0)


{-# INLINE zipWithAppend #-}
zipWithAppend ::
   (Storable x) =>
   (x -> x -> x) ->
   T x -> T x -> T x
zipWithAppend :: forall x. Storable x => (x -> x -> x) -> T x -> T x -> T x
zipWithAppend x -> x -> x
f T x
xs0 T x
ys0 =
   let recourse :: [Vector x] -> [Vector x] -> [Vector x]
recourse xt :: [Vector x]
xt@(Vector x
x:[Vector x]
_) yt :: [Vector x]
yt@(Vector x
y:[Vector x]
_) =
          let z :: Vector x
z = forall a b c.
(Storable a, Storable b, Storable c) =>
(a -> b -> c) -> Vector a -> Vector b -> Vector c
V.zipWith x -> x -> x
f Vector x
x Vector x
y
              n :: Int
n = forall a. Vector a -> Int
V.length Vector x
z
          in  Vector x
z forall a. a -> [a] -> [a]
: [Vector x] -> [Vector x] -> [Vector x]
recourse
                     (forall a. Vector a -> [Vector a]
Vector.chunks forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Int -> Vector a -> Vector a
Vector.drop Int
n forall a b. (a -> b) -> a -> b
$ forall a. Storable a => [Vector a] -> Vector a
Vector.fromChunks [Vector x]
xt)
                     (forall a. Vector a -> [Vector a]
Vector.chunks forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Int -> Vector a -> Vector a
Vector.drop Int
n forall a b. (a -> b) -> a -> b
$ forall a. Storable a => [Vector a] -> Vector a
Vector.fromChunks [Vector x]
yt)
       recourse [Vector x]
xs [] = [Vector x]
xs
       recourse [] [Vector x]
ys = [Vector x]
ys
   in  forall a. Storable a => [Vector a] -> Vector a
Vector.fromChunks forall a b. (a -> b) -> a -> b
$
       [Vector x] -> [Vector x] -> [Vector x]
recourse (forall a. Vector a -> [Vector a]
Vector.chunks T x
xs0) (forall a. Vector a -> [Vector a]
Vector.chunks T x
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 :: forall x. Storable x => (x -> x -> x) -> T x -> T x -> T x
_zipWithAppendRest x -> x -> x
f T x
xs T x
ys =
   forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Storable a => Vector a -> Vector a -> Vector a
Vector.append forall a b. (a -> b) -> a -> b
$ forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall c x.
(Storable c, Storable x) =>
(x -> x -> c) -> T x -> T x -> (Vector c, (Bool, T x))
zipWithRest x -> x -> x
f T x
xs T x
ys

{-# INLINE zipWithRest #-}
zipWithRest ::
   (Storable c, Storable x) =>
   (x -> x -> c) ->
   T x ->
   T x ->
   (Vector.Vector c, (Bool, T x))
zipWithRest :: forall c x.
(Storable c, Storable x) =>
(x -> x -> c) -> T x -> T x -> (Vector c, (Bool, T x))
zipWithRest x -> x -> c
f T x
xs T x
ys =
   let len :: T Int
len = forall a. Ord a => a -> a -> a
min (forall i x. C i => T x -> i
lazyLength T x
xs) (forall i x. C i => T x -> i
lazyLength T x
ys) :: Chunky.T NonNeg.Int
       (T x
prefixX,T x
suffixX) = forall i x. (C i, Ord i, C i, Storable x) => i -> T x -> (T x, T x)
genericSplitAt T Int
len T x
xs
       (T x
prefixY,T x
suffixY) = forall i x. (C i, Ord i, C i, Storable x) => i -> T x -> (T x, T x)
genericSplitAt T Int
len T x
ys
       second :: Bool
second = forall a. Storable a => Vector a -> Bool
Vector.null T x
suffixX
   in  (forall a b c.
(Storable a, Storable b, Storable c) =>
(a -> b -> c) -> Vector a -> Vector b -> Vector c
Vector.zipWithLastPattern x -> x -> c
f T x
prefixX T x
prefixY,
        (Bool
second, if Bool
second then T x
suffixY else T x
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 :: forall i x. (C i, Ord i, C i, Storable x) => i -> T x -> (T x, T x)
genericSplitAt i
n0 =
   let recourse :: a -> [Vector a] -> ([Vector a], [Vector a])
recourse a
n [Vector a]
xs0 =
          forall a b. (a, b) -> (a, b)
forcePair forall a b. (a -> b) -> a -> b
$
          forall b a. b -> (a -> [a] -> b) -> [a] -> b
ListHT.switchL
             ([], [])
             (\Vector a
x [Vector a]
xs ->
                if forall a. C a => a -> Bool
isZero a
n
                  then ([], [Vector a]
xs0)
                  else
                    let m :: a
m = forall a b. (C a, C b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> Int
V.length Vector a
x
                    in  if a
mforall a. Ord a => a -> a -> Bool
<=a
n
                          then forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst (Vector a
xforall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ a -> [Vector a] -> ([Vector a], [Vector a])
recourse (a
nforall a. C a => a -> a -> a
-a
m) [Vector a]
xs
                          else forall a c b d. (a -> c, b -> d) -> (a, b) -> (c, d)
mapPair ((forall a. a -> [a] -> [a]
:[]), (forall a. a -> [a] -> [a]
:[Vector a]
xs)) forall a b. (a -> b) -> a -> b
$
                               forall a. Storable a => Int -> Vector a -> (Vector a, Vector a)
V.splitAt (forall a. C a => Integer -> a
fromInteger forall a b. (a -> b) -> a -> b
$ forall a. C a => a -> Integer
toInteger a
n) Vector a
x)
             [Vector a]
xs0
   in  forall a c b d. (a -> c, b -> d) -> (a, b) -> (c, d)
mapPair (forall a. Storable a => [Vector a] -> Vector a
Vector.fromChunks, forall a. Storable a => [Vector a] -> Vector a
Vector.fromChunks) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
       forall {a} {a}.
(Storable a, C a) =>
a -> [Vector a] -> ([Vector a], [Vector a])
recourse i
n0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Vector a -> [Vector a]
Vector.chunks


-- cf. Data.StorableVector.Lazy.Pattern.length
lazyLength :: (Ring.C i) =>
   T x -> i
lazyLength :: forall i x. C i => T x -> i
lazyLength =
   forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
List.foldr forall a. C a => a -> a -> a
(+) forall a. C a => a
zero forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
List.map (forall a b. (C a, C b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Vector a -> Int
V.length) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Vector a -> [Vector a]
Vector.chunks

genericLength :: (Ring.C i) =>
   T x -> i
genericLength :: forall i x. C i => T x -> i
genericLength =
   forall a. C a => [a] -> a
sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
List.map (forall a b. (C a, C b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Vector a -> Int
V.length) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Vector a -> [Vector a]
Vector.chunks


splitAtPad ::
   (Additive.C x, Storable x) =>
   ChunkSize -> Int -> T x -> (T x, T x)
splitAtPad :: forall x.
(C x, Storable x) =>
ChunkSize -> Int -> T x -> (T x, T x)
splitAtPad ChunkSize
size Int
n =
   forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst (forall a.
Storable a =>
ChunkSize -> a -> Int -> Vector a -> Vector a
Vector.pad ChunkSize
size forall a. C a => a
Additive.zero Int
n) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => Int -> Vector a -> (Vector a, Vector a)
Vector.splitAt Int
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 :: forall x. (C x, Storable x) => ChunkSize -> T x -> T x -> T x
mixSize ChunkSize
size T x
xs T x
ys =
   forall b a.
Storable b =>
ChunkSize -> (a -> Maybe (b, a)) -> a -> Vector b
Vector.unfoldr ChunkSize
size forall x.
(C x, Storable x) =>
(Pointer x, Pointer x) -> Maybe (x, (Pointer x, Pointer x))
mixStep
      (forall a. Storable a => Vector a -> Pointer a
Pointer.cons T x
xs, forall a. Storable a => Vector a -> Pointer a
Pointer.cons T x
ys)


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



{-# INLINE delay #-}
delay :: (Storable y) =>
   ChunkSize -> y -> Int -> T y -> T y
delay :: forall a.
Storable a =>
ChunkSize -> a -> Int -> Vector a -> Vector a
delay ChunkSize
size y
z Int
n = forall a. Storable a => Vector a -> Vector a -> Vector a
Vector.append (forall a. Storable a => ChunkSize -> Int -> a -> Vector a
Vector.replicate ChunkSize
size Int
n y
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 :: forall y. Storable y => (T y -> T y) -> T y -> T y
delayLoop T y -> T y
proc T y
prefix =
   let ys :: T y
ys = forall a. Storable a => Vector a -> Vector a -> Vector a
Vector.append T y
prefix (T y -> T y
proc T y
ys)
   in  T y
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 :: forall y. (C y, Storable y) => Int -> (T y -> T y) -> T y -> T y
delayLoopOverlap Int
time T y -> T y
proc T y
xs =
   let ys :: T y
ys = forall a b c.
(Storable a, Storable b, Storable c) =>
(a -> b -> c) -> Vector a -> Vector b -> Vector c
Vector.zipWith forall a. C a => a -> a -> a
(Additive.+) T y
xs
               (forall a.
Storable a =>
ChunkSize -> a -> Int -> Vector a -> Vector a
delay (Int -> ChunkSize
Vector.chunkSize Int
time) forall a. C a => a
Additive.zero Int
time (T y -> T y
proc T y
ys))
   in  T y
ys



{-# INLINE takeCrochet #-}
takeCrochet :: Storable a => Int -> T a -> T a
takeCrochet :: forall a. Storable a => Int -> Vector a -> Vector a
takeCrochet = forall x y acc.
(Storable x, Storable y) =>
(x -> acc -> Maybe (y, acc)) -> acc -> Vector x -> Vector y
Vector.crochetL (\a
x Int
n -> forall a. Bool -> a -> Maybe a
toMaybe (Int
nforall a. Ord a => a -> a -> Bool
>Int
0) (a
x, forall a. Enum a => a -> a
pred Int
n))