synthesizer-0.2: src/Synthesizer/Storable/Signal.hs
{- OPTIONS_GHC -fglasgow-exts -}
{- glasgow-exts are for the 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
splitAtPad,
Vector.null,
Vector.fromChunks,
-- for Storable.Filter.Comb
delay,
delayLoop,
delayLoopOverlap,
-- for FusionTest
mix, mixSize,
Vector.empty,
Vector.replicate,
Vector.repeat,
Vector.drop,
Vector.take,
takeCrochet,
fromList,
appendFromFusionList,
appendFusionList,
-- for Generic.Signal
zipWithRest,
zipWithAppend,
-- for Storable.ALSA.MIDI
Vector.switchR,
-- just for fun
fromFusionList,
genericLength,
) where
-- import qualified Sound.Signal as Signal
import qualified Synthesizer.FusionList.Signal as FList
import qualified Data.List as List
import qualified Data.StorableVector.Lazy as Vector
import qualified Data.StorableVector as V
import Data.StorableVector.Lazy (ChunkSize(..))
-- import Data.Maybe (Maybe(Just,Nothing), maybe, fromMaybe)
-- import Data.StorableVector(Vector)
import Foreign.Storable (Storable)
-- import qualified Synthesizer.Format as Format
-- import Control.Arrow ((***))
-- import Control.Monad (liftM, liftM2, {- guard, -} )
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 qualified Data.List.HT as ListHT
import Data.Maybe.HT (toMaybe, )
import Data.Tuple.HT (mapFst, mapSnd, mapPair, forcePair, )
-- import qualified Algebra.Additive as Additive
-- import System.IO (openBinaryFile, hClose, hPutBuf, IOMode(WriteMode), Handle)
import NumericPrelude
import PreludeBase
import Prelude ()
{-
import NumericPrelude
(sum, (+), (-), divMod, fromIntegral, fromInteger, toInteger, isZero, zero, )
import Prelude hiding
(length, (++), iterate, foldl, map, repeat, replicate, null,
zip, zipWith, zipWith3, drop, take, splitAt, takeWhile, reverse)
-}
{-
import qualified Prelude as P
import Prelude
(IO, ($), (.), fst, snd, id,
Int, Double, Float,
Char, Num, Show, showsPrec, FilePath,
Bool(True,False), not,
flip, curry, uncurry,
Ord, (<), (>), (<=), {- (>=), (==), -} min, max,
mapM_, fmap, (=<<), return,
Enum, succ, pred, )
-}
-- this form is needed for Storable signal embed in amplitude signal
type T = Vector.Vector
-- type T a = Vector.Vector a
instance (Show a, Storable a) => Show (Vector.Vector a) where
showsPrec p = showsPrec p . Vector.unpack
{-
instance (Storable a) => Format.C T where
format = showsPrec
-}
defaultChunkSize :: ChunkSize
defaultChunkSize = ChunkSize 1024
{-
{- * Helper functions for StorableVector -}
cancelNullVector :: (Vector a, b) -> Maybe (Vector a, b)
cancelNullVector y =
toMaybe (not (Vector.null (fst y))) y
viewLVector :: Storable a =>
Vector a -> Maybe (a, Vector a)
viewLVector = Vector.viewL
{-
toMaybe
(not (Vector.null x))
(Vector.head x, Vector.tail x)
-}
crochetLVector :: (Storable x, Storable y) =>
(x -> acc -> Maybe (y, acc))
-> acc
-> Vector x
-> (Vector y, Maybe acc)
crochetLVector f acc0 x0 =
mapSnd (fmap fst) $
Vector.unfoldrN
(Vector.length x0)
(\(acc,xt) ->
do (x,xs) <- viewLVector xt
(y,acc') <- f x acc
return (y, (acc',xs)))
(acc0, x0)
reduceLVector :: Storable x =>
(x -> acc -> Maybe acc) -> acc -> Vector x -> (acc, Bool)
reduceLVector f acc0 x =
let recourse i acc =
if i < Vector.length x
then (acc, True)
else
maybe
(acc, False)
(recourse (succ i))
(f (Vector.index x i) acc)
in recourse 0 acc0
{- * Fundamental functions -}
{- |
Sophisticated implementation where chunks always have size bigger than 0.
-}
{-# INLINE [0] unfoldr #-}
unfoldr :: (Storable b) =>
ChunkSize
-> (a -> Maybe (b,a))
-> a
-> T b
unfoldr (ChunkSize size) f =
Cons .
List.unfoldr
(cancelNullVector . Vector.unfoldrN size f =<<) .
Just
{- |
Simple implementation where chunks can have size 0 in the first run.
Then they are filtered out.
This separation might reduce laziness.
-}
unfoldr0 :: (Storable b) =>
ChunkSize
-> (a -> Maybe (b,a))
-> a
-> T b
unfoldr0 (ChunkSize size) f =
Cons .
List.filter (not . Vector.null) .
List.unfoldr (fmap (Vector.unfoldrN size f)) .
Just
unfoldr1 :: (Storable b) =>
ChunkSize
-> (a -> (b, Maybe a))
-> Maybe a
-> T b
unfoldr1 size f = unfoldr size (liftM f)
{-# INLINE [0] crochetL #-}
crochetL :: (Storable x, Storable y) =>
(x -> acc -> Maybe (y, acc))
-> acc
-> T x
-> T y
crochetL f acc0 =
Cons . List.unfoldr (\(xt,acc) ->
do (x,xs) <- ListHT.viewL xt
acc' <- acc
return $ mapSnd ((,) xs) $ crochetLVector f acc' x) .
flip (,) (Just acc0) .
decons
{-
Usage of 'unfoldr' seems to be clumsy but that covers all cases,
like different block sizes in source and destination list.
-}
crochetLSize :: (Storable x, Storable y) =>
ChunkSize
-> (x -> acc -> Maybe (y, acc))
-> acc
-> T x
-> T y
crochetLSize size f =
curry (unfoldr size (\(acc,xt) ->
do (x,xs) <- viewL xt
(y,acc') <- f x acc
return (y, (acc',xs))))
viewL :: Storable a => T a -> Maybe (a, T a)
viewL (Cons xs0) =
-- dropWhile would be unnecessary if we require that all chunks are non-empty
do (x,xs) <- ListHT.viewL (List.dropWhile Vector.null xs0)
(y,ys) <- viewLVector x
return (y, append (fromChunk ys) (Cons xs))
viewR :: Storable a => T a -> Maybe (T a, a)
viewR (Cons xs0) =
-- dropWhile would be unnecessary if we require that all chunks are non-empty
do (xs,x) <- ListHT.viewR (dropWhileRev Vector.null xs0)
(ys,y) <- Vector.viewR x
return (append (Cons xs) (fromChunk ys), y)
crochetListL :: (Storable y) =>
ChunkSize
-> (x -> acc -> Maybe (y, acc))
-> acc
-> [x]
-> T y
crochetListL size f =
curry (unfoldr size (\(acc,xt) ->
do (x,xs) <- ListHT.viewL xt
(y,acc') <- f x acc
return (y, (acc',xs))))
-}
{-# INLINE fromList #-}
fromList :: (Storable a) => ChunkSize -> [a] -> T a
fromList = Vector.pack
{-
-- should start fusion
fromListCrochetL :: (Storable a) => ChunkSize -> [a] -> T a
fromListCrochetL size =
crochetListL size (\x _ -> Just (x, ())) ()
fromListUnfoldr :: (Storable a) => ChunkSize -> [a] -> T a
fromListUnfoldr size = unfoldr size ListHT.viewL
fromListPack :: (Storable a) => ChunkSize -> [a] -> T a
fromListPack (ChunkSize size) =
Cons .
List.map Vector.pack .
sliceVert size
toList :: (Storable a) => T a -> [a]
toList = List.concatMap Vector.unpack . decons
-- if the chunk has length zero, an empty sequence is generated
fromChunk :: (Storable a) => Vector a -> T a
fromChunk x =
if Vector.null x
then empty
else Cons [x]
{-# NOINLINE [0] crochetFusionListL #-}
crochetFusionListL :: (Storable y) =>
ChunkSize
-> (x -> acc -> Maybe (y, acc))
-> acc
-> FList.T x
-> T y
crochetFusionListL size f =
curry (unfoldr size (\(acc,xt) ->
do (x,xs) <- FList.viewL xt
(y,acc') <- f x acc
return (y, (acc',xs))))
-}
{-# NOINLINE [0] fromFusionList #-}
fromFusionList :: (Storable a) => ChunkSize -> FList.T a -> T a
fromFusionList size = fromList size . FList.toList
-- fromFusionListCrochetL
{-
{-# INLINE fromFusionListCrochetL #-}
fromFusionListCrochetL :: (Storable a) => ChunkSize -> FList.T a -> T a
fromFusionListCrochetL size =
crochetFusionListL size (\x _ -> Just (x, ())) ()
fromFusionListUnfoldr :: (Storable a) => ChunkSize -> FList.T a -> T a
fromFusionListUnfoldr size =
unfoldr size FList.viewL
{-# NOINLINE [0] toFusionList #-}
toFusionList :: (Storable a) => T a -> FList.T a
toFusionList = FList.Cons . List.concatMap Vector.unpack . decons
{- |
Converts from and to 'FList.T'
in order to speedup computation,
especially because it tells the optimizer about the 'Storable' constraint
and thus allows for more fusion,
where fusion would break otherwise.
-}
{-# INLINE chop #-}
chop :: (Storable a) => ChunkSize -> FList.T a -> FList.T a
chop size = toFusionList . fromFusionList size
{-# INLINE [0] reduceL #-}
reduceL :: Storable x =>
(x -> acc -> Maybe acc) -> acc -> T x -> acc
reduceL f acc0 =
let recourse acc xt =
case xt of
[] -> acc
(x:xs) ->
let (acc',continue) = reduceLVector f acc x
in if continue
then recourse acc' xs
else acc'
in recourse acc0 . decons
{- * Basic functions -}
empty :: Storable a => T a
empty = Cons []
null :: Storable a => T a -> Bool
null = List.null . decons
{-# NOINLINE [0] cons #-}
cons :: Storable a => a -> T a -> T a
cons x = Cons . (Vector.singleton x :) . decons
length :: T a -> Int
length = sum . List.map Vector.length . decons
reverse :: Storable a => T a -> T a
reverse =
Cons . List.reverse . List.map Vector.reverse . decons
{-# INLINE [0] foldl #-}
foldl :: Storable b => (a -> b -> a) -> a -> T b -> a
foldl f x0 = List.foldl (Vector.foldl f) x0 . decons
{-# INLINE [0] map #-}
map :: (Storable x, Storable y) =>
(x -> y)
-> T x
-> T y
map f = mapInline f -- Cons . List.map (Vector.map f) . decons
{-# INLINE mapInline #-}
mapInline :: (Storable x, Storable y) =>
(x -> y)
-> T x
-> T y
mapInline f =
let mapVec = Vector.map f
in Cons . List.map mapVec . decons
{-# NOINLINE [0] drop #-}
drop :: (Storable a) => Int -> T a -> T a
drop _ (Cons []) = empty
drop n (Cons (x:xs)) =
let m = Vector.length x
in if m<=n
then drop (n-m) (Cons xs)
else Cons (Vector.drop n x : xs)
{-# NOINLINE [0] take #-}
take :: (Storable a) => Int -> T a -> T a
take _ (Cons []) = empty
take 0 _ = empty
take n (Cons (x:xs)) =
let m = Vector.length x
in if m<=n
then Cons $ (x:) $ decons $ take (n-m) $ Cons xs
else fromChunk (Vector.take n x)
{-# NOINLINE [0] splitAt #-}
splitAt :: (Storable a) => Int -> T a -> (T a, T a)
splitAt n0 =
let recourse _ [] = ([], [])
recourse 0 xs = ([], xs)
recourse n (x:xs) =
let m = Vector.length x
in if m<=n
then mapFst (x:) $ recourse (n-m) xs
else mapPair ((:[]), (:xs)) $ Vector.splitAt n x
in mapPair (Cons, Cons) . recourse n0 . decons
dropMarginRem :: (Storable a) => Int -> Int -> T a -> (Int, T a)
dropMarginRem n m xs =
List.foldl'
(\(mi,xsi) k -> (mi-k, drop k xsi))
(m,xs)
(List.map Vector.length $ decons $ take m $ drop n xs)
{-
This implementation does only walk once through the dropped prefix.
It is maximally lazy and minimally space consuming.
-}
dropMargin :: (Storable a) => Int -> Int -> T a -> T a
dropMargin n m xs =
List.foldl' (flip drop) xs
(List.map Vector.length $ decons $ take m $ drop n xs)
{-# NOINLINE [0] dropWhile #-}
dropWhile :: (Storable a) => (a -> Bool) -> T a -> T a
dropWhile _ (Cons []) = empty
dropWhile p (Cons (x:xs)) =
let y = Vector.dropWhile p x
in if Vector.null y
then dropWhile p (Cons xs)
else Cons (y:xs)
{-# NOINLINE [0] takeWhile #-}
takeWhile :: (Storable a) => (a -> Bool) -> T a -> T a
takeWhile _ (Cons []) = empty
takeWhile p (Cons (x:xs)) =
let y = Vector.takeWhile p x
in if Vector.length y < Vector.length x
then fromChunk y
else Cons (x : decons (takeWhile p (Cons xs)))
{-# NOINLINE [0] span #-}
span :: (Storable a) => (a -> Bool) -> T a -> (T a, T a)
span p =
let recourse [] = ([],[])
recourse (x:xs) =
let (y,z) = Vector.span p x
in if Vector.null z
then mapFst (x:) (recourse xs)
else (decons $ fromChunk y, (z:xs))
in mapPair (Cons, Cons) . recourse . decons
{-
span _ (Cons []) = (empty, empty)
span p (Cons (x:xs)) =
let (y,z) = Vector.span p x
in if Vector.length y == 0
then mapFst (Cons . (x:) . decons) (span p (Cons xs))
else (Cons [y], Cons (z:xs))
-}
concat :: (Storable a) => [T a] -> T a
concat = Cons . List.concat . List.map decons
{- |
Ensure a minimal length of the list by appending pad values.
-}
{-# NOINLINE [0] pad #-}
pad :: (Storable a) => ChunkSize -> a -> Int -> T a -> T a
pad size y n0 =
let recourse n xt =
if n<=0
then xt
else
case xt of
[] -> decons $ replicate size n y
x:xs -> x : recourse (n - Vector.length x) xs
in Cons . recourse n0 . decons
padAlt :: (Storable a) => ChunkSize -> a -> Int -> T a -> T a
padAlt size x n xs =
append xs
(let m = length xs
in if n>m
then replicate size (n-m) x
else empty)
infixr 5 `append`
{-# NOINLINE [0] append #-}
append :: T a -> T a -> T a
append (Cons xs) (Cons ys) = Cons (xs List.++ ys)
-}
{-# INLINE appendFromFusionList #-}
appendFromFusionList :: Storable a =>
ChunkSize -> FList.T a -> FList.T a -> T a
appendFromFusionList size xs ys =
Vector.append (FList.toStorableSignal size xs) (FList.toStorableSignal size ys)
{- |
Like 'appendFromFusionList' but returns a 'FList.T'
for more flexible following processing.
-}
{-# INLINE appendFusionList #-}
appendFusionList :: Storable a =>
ChunkSize -> FList.T a -> FList.T a -> FList.T a
appendFusionList size xs ys =
FList.fromStorableSignal (appendFromFusionList size xs ys)
{-
{-# INLINE iterate #-}
iterate :: Storable a => ChunkSize -> (a -> a) -> a -> T a
iterate size f = unfoldr size (\x -> Just (x, f x))
repeat :: Storable a => ChunkSize -> a -> T a
repeat (ChunkSize size) =
Cons . List.repeat . Vector.replicate size
cycle :: Storable a => T a -> T a
cycle =
Cons . List.cycle . decons
replicate :: Storable a => ChunkSize -> Int -> a -> T a
replicate (ChunkSize size) n x =
let (numChunks, rest) = divMod n size
in append
(Cons (List.replicate numChunks (Vector.replicate size x)))
(fromChunk (Vector.replicate rest x))
-}
{-# INLINE scanL #-}
scanL :: (Storable a, Storable b) =>
(a -> b -> a) -> a -> T b -> T a
scanL = Vector.scanl
{-
{-# INLINE [0] mapAccumL #-}
mapAccumL :: (Storable a, Storable b) =>
(acc -> a -> (acc, b)) -> acc -> T a -> (acc, T b)
mapAccumL f start =
mapSnd Cons .
List.mapAccumL (Vector.mapAccumL f) start .
decons
{-# INLINE [0] mapAccumR #-}
mapAccumR :: (Storable a, Storable b) =>
(acc -> a -> (acc, b)) -> acc -> T a -> (acc, T b)
mapAccumR f start =
mapSnd Cons .
List.mapAccumR (Vector.mapAccumR f) start .
decons
{-# RULEZ
"Storable.append/repeat/repeat" forall size x.
append (repeat size x) (repeat size x) = repeat size x ;
"Storable.append/repeat/replicate" forall size n x.
append (repeat size x) (replicate size n x) = repeat size x ;
"Storable.append/replicate/repeat" forall size n x.
append (replicate size n x) (repeat size x) = repeat size x ;
"Storable.append/replicate/replicate" forall size n m x.
append (replicate size n x) (replicate size m x) =
replicate size (n+m) x ;
"Storable.mix/repeat/repeat" forall size x y.
mix (repeat size x) (repeat size y) = repeat size (x+y) ;
#-}
{-# RULES
"Storable.length/cons" forall x xs.
length (cons x xs) = 1 + length xs ;
"Storable.length/map" forall f xs.
length (map f xs) = length xs ;
"Storable.map/cons" forall f x xs.
map f (cons x xs) = cons (f x) (map f xs) ;
"Storable.map/repeat" forall size f x.
map f (repeat size x) = repeat size (f x) ;
"Storable.map/replicate" forall size f x n.
map f (replicate size n x) = replicate size n (f x) ;
"Storable.map/repeat" forall size f x.
map f (repeat size x) = repeat size (f x) ;
{-
This can make things worse, if 'map' is applied to replicate,
since this can use of sharing.
It can also destroy the more important map/unfoldr fusion in
take n . map f . unfoldr g
"Storable.take/map" forall n f x.
take n (map f x) = map f (take n x) ;
-}
"Storable.take/repeat" forall size n x.
take n (repeat size x) = replicate size n x ;
"Storable.take/take" forall n m xs.
take n (take m xs) = take (min n m) xs ;
"Storable.drop/drop" forall n m xs.
drop n (drop m xs) = drop (n+m) xs ;
"Storable.drop/take" forall n m xs.
drop n (take m xs) = take (max 0 (m-n)) (drop n xs) ;
"Storable.map/mapAccumL/snd" forall g f acc0 xs.
map g (snd (mapAccumL f acc0 xs)) =
snd (mapAccumL (\acc a -> mapSnd g (f acc a)) acc0 xs) ;
#-}
{- GHC says this is an orphaned rule
"Storable.map/mapAccumL/mapSnd" forall g f acc0 xs.
mapSnd (map g) (mapAccumL f acc0 xs) =
mapAccumL (\acc a -> mapSnd g (f acc a)) acc0 xs ;
-}
-}
{-# SPECULATE mix :: T Double -> T Double -> T Double #-}
{-# SPECULATE mix :: T Float -> T Float -> T Float #-}
{-# SPECULATE mix :: T (Double,Double) -> T (Double,Double) -> T (Double,Double) #-}
{-# SPECULATE mix :: T (Float,Float) -> T (Float,Float) -> T (Float,Float) #-}
{-
'mix' is more efficient
since it appends the rest of the longer signal without copying.
It also preserves the chunk structure of the second signal,
which is essential if you want to limit look-ahead.
-}
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])
-}
zipWithAppend ::
(Storable x) =>
(x -> x -> x) ->
T x -> T x -> T x
zipWithAppend f xs ys =
uncurry Vector.append $ mapSnd snd $ zipWithRest f xs ys
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.zipWith 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 $
maybe
([], [])
(\(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)
$ ListHT.viewL 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
{-# SPECULATE mixSize :: ChunkSize -> T Double -> T Double -> T Double #-}
{-# SPECULATE mixSize :: ChunkSize -> T Float -> T Float -> T Float #-}
{-# SPECULATE mixSize :: ChunkSize -> T (Double,Double) -> T (Double,Double) -> T (Double,Double) #-}
{-# SPECULATE 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 =
curry (Vector.unfoldr size mixStep)
{-# INLINE mixStep #-}
mixStep :: (Additive.C x, Storable x) =>
(T x, T x) ->
Maybe (x, (T x, T x))
mixStep (xt,yt) =
case (Vector.viewL xt, Vector.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 zip #-}
zip :: (Storable a, Storable b) =>
ChunkSize -> (T a -> T b -> T (a,b))
zip size = zipWith size (,)
{-# INLINE zipWith3 #-}
zipWith3 :: (Storable a, Storable b, Storable c, Storable d) =>
ChunkSize -> (a -> b -> c -> d) -> (T a -> T b -> T c -> T d)
zipWith3 size f s0 s1 =
zipWith size (uncurry f) (zip size s0 s1)
{-# INLINE zipWith4 #-}
zipWith4 :: (Storable a, Storable b, Storable c, Storable d, Storable e) =>
ChunkSize -> (a -> b -> c -> d -> e) -> (T a -> T b -> T c -> T d -> T e)
zipWith4 size f s0 s1 =
zipWith3 size (uncurry f) (zip size s0 s1)
{- * Fusable functions -}
{-# INLINE [0] zipWith #-}
zipWith :: (Storable x, Storable y, Storable z) =>
ChunkSize
-> (x -> y -> z)
-> T x
-> T y
-> T z
zipWith size f =
curry (unfoldr size (\(xt,yt) ->
liftM2
(\(x,xs) (y,ys) -> (f x y, (xs,ys)))
(viewL xt)
(viewL yt)))
scanLCrochet :: (Storable a, Storable b) =>
(a -> b -> a) -> a -> T b -> T a
scanLCrochet f start =
cons start .
crochetL (\x acc -> let y = f acc x in Just (y, y)) start
{-# INLINE mapCrochet #-}
mapCrochet :: (Storable a, Storable b) => (a -> b) -> (T a -> T b)
mapCrochet f = crochetL (\x _ -> Just (f x, ())) ()
-}
{-# INLINE takeCrochet #-}
takeCrochet :: Storable a => Int -> T a -> T a
takeCrochet = Vector.crochetL (\x n -> toMaybe (n>0) (x, pred n))
{-
{-# INLINE repeatUnfoldr #-}
repeatUnfoldr :: Storable a => ChunkSize -> a -> T a
repeatUnfoldr size = iterate size id
{-# INLINE replicateCrochet #-}
replicateCrochet :: Storable a => ChunkSize -> Int -> a -> T a
replicateCrochet size n = takeCrochet n . repeat size
{-
crochetFusionListLGenerate size g b f a =
unfoldr size (\(a0,b0) ->
do (y0,a1) <- f a0
(z0,b1) <- g y0 b0
Just (z0, (a1,b1))) (a,b) ;
-}
{-# RULES
"Storable.crochetFusionListL/crochetL" forall size f g a b x.
crochetFusionListL size g b (FList.crochetL f a x) =
crochetFusionListL size (\x0 (a0,b0) ->
do (y0,a1) <- f x0 a0
(z0,b1) <- g y0 b0
Just (z0, (a1,b1))) (a,b) x ;
"Storable.crochetFusionListL/generate" forall size f g a b.
crochetFusionListL size g b (FList.generate f a) =
unfoldr size (\(a0,b0) ->
do (y0,a1) <- f a0
(z0,b1) <- g y0 b0
Just (z0, (a1,b1))) (a,b) ;
{-
"Storable.fromFusionList/crochetL"
forall size f a (x :: Storable a => FList.T a) .
fromFusionList size (FList.crochetL f a x) =
crochetL f a (fromFusionList size x) ;
-}
"Storable.fromFusionList/generate" forall size f a.
fromFusionList size (FList.generate f a) =
unfoldr size f a ;
"Storable.fromFusionList/cons" forall size x xs.
fromFusionList size (FList.cons x xs) =
cons x (fromFusionList size xs) ;
"Storable.fromFusionList/empty" forall size.
fromFusionList size (FList.empty) =
empty ;
"Storable.fromFusionList/append" forall size xs ys.
fromFusionList size (FList.append xs ys) =
append (fromFusionList size xs) (fromFusionList size ys) ;
"Storable.fromFusionList/maybe" forall size f x y.
fromFusionList size (maybe x f y) =
maybe (fromFusionList size x)
(fromFusionList size . f) y ;
"Storable.fromFusionList/fromMaybe" forall size x y.
fromFusionList size (fromMaybe x y) =
maybe (fromFusionList size x) (fromFusionList size) y ;
#-}
{-
The "fromList/drop" rule is not quite accurate
because the chunk borders are moved.
Maybe 'ChunkSize' better is a list of chunks sizes.
-}
{-# RULEZ
"fromList/zipWith"
forall size f (as :: Storable a => [a]) (bs :: Storable a => [a]).
fromList size (List.zipWith f as bs) =
zipWith size f (fromList size as) (fromList size bs) ;
"fromList/drop" forall as n size.
fromList size (List.drop n as) =
drop n (fromList size as) ;
#-}
{- * Fused functions -}
type Unfoldr s a = (s -> Maybe (a,s), s)
{-# INLINE zipWithUnfoldr2 #-}
zipWithUnfoldr2 :: Storable z =>
ChunkSize
-> (x -> y -> z)
-> Unfoldr a x
-> Unfoldr b y
-> T z
zipWithUnfoldr2 size h (f,a) (g,b) =
unfoldr size
(\(a0,b0) -> liftM2 (\(x,a1) (y,b1) -> (h x y, (a1,b1))) (f a0) (g b0))
-- (uncurry (liftM2 (\(x,a1) (y,b1) -> (h x y, (a1,b1)))) . (f *** g))
(a,b)
{- done by takeCrochet
{-# INLINE mapUnfoldr #-}
mapUnfoldr :: (Storable x, Storable y) =>
ChunkSize
-> (x -> y)
-> Unfoldr a x
-> T y
mapUnfoldr size g (f,a) =
unfoldr size (fmap (mapFst g) . f) a
-}
{-# INLINE dropUnfoldr #-}
dropUnfoldr :: Storable x =>
ChunkSize
-> Int
-> Unfoldr a x
-> T x
dropUnfoldr size n (f,a0) =
maybe
empty
(unfoldr size f)
(nest n (\a -> fmap snd . f =<< a) (Just a0))
{- done by takeCrochet
{-# INLINE takeUnfoldr #-}
takeUnfoldr :: Storable x =>
ChunkSize
-> Int
-> Unfoldr a x
-> T x
takeUnfoldr size n0 (f,a0) =
unfoldr size
(\(a,n) ->
do guard (n>0)
(x,a') <- f a
return (x, (a', pred n)))
(a0,n0)
-}
lengthUnfoldr :: Storable x =>
Unfoldr a x
-> Int
lengthUnfoldr (f,a0) =
let recourse n a =
maybe n (recourse (succ n) . snd) (f a)
in recourse 0 a0
{-# INLINE zipWithUnfoldr #-}
zipWithUnfoldr ::
(Storable b, Storable c) =>
(acc -> Maybe (a, acc))
-> (a -> b -> c)
-> acc
-> T b -> T c
zipWithUnfoldr f h a y =
crochetL (\y0 a0 ->
do (x0,a1) <- f a0
Just (h x0 y0, a1)) a y
{-# INLINE zipWithCrochetL #-}
zipWithCrochetL ::
(Storable x, Storable b, Storable c) =>
ChunkSize
-> (x -> acc -> Maybe (a, acc))
-> (a -> b -> c)
-> acc
-> T x -> T b -> T c
zipWithCrochetL size f h a x y =
crochetL (\(x0,y0) a0 ->
do (z0,a1) <- f x0 a0
Just (h z0 y0, a1))
a (zip size x y)
{-# INLINE crochetLCons #-}
crochetLCons ::
(Storable a, Storable b) =>
(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)
{-# INLINE reduceLCons #-}
reduceLCons ::
(Storable a) =>
(a -> acc -> Maybe acc)
-> acc
-> a -> T a -> acc
reduceLCons f a0 x xs =
maybe a0 (flip (reduceL f) xs) (f x a0)
{-# RULES
"Storable.zipWith/share" forall size (h :: a->a->b) (x :: T a).
zipWith size h x x = map (\xi -> h xi xi) x ;
-- "Storable.map/zipWith" forall size (f::c->d) (g::a->b->c) (x::T a) (y::T b).
"Storable.map/zipWith" forall size f g x y.
map f (zipWith size g x y) =
zipWith size (\xi yi -> f (g xi yi)) x y ;
-- this rule lets map run on a different block structure
"Storable.zipWith/map,*" forall size f g x y.
zipWith size g (map f x) y =
zipWith size (\xi yi -> g (f xi) yi) x y ;
"Storable.zipWith/*,map" forall size f g x y.
zipWith size g x (map f y) =
zipWith size (\xi yi -> g xi (f yi)) x y ;
"Storable.drop/unfoldr" forall size f a n.
drop n (unfoldr size f a) =
dropUnfoldr size n (f,a) ;
"Storable.take/unfoldr" forall size f a n.
take n (unfoldr size f a) =
-- takeUnfoldr size n (f,a) ;
takeCrochet n (unfoldr size f a) ;
"Storable.length/unfoldr" forall size f a.
length (unfoldr size f a) = lengthUnfoldr (f,a) ;
"Storable.map/unfoldr" forall size g f a.
map g (unfoldr size f a) =
-- mapUnfoldr size g (f,a) ;
mapCrochet g (unfoldr size f a) ;
"Storable.map/iterate" forall size g f a.
map g (iterate size f a) =
mapCrochet g (iterate size f a) ;
{-
"Storable.zipWith/unfoldr,unfoldr" forall sizeA sizeB f g h a b n.
zipWith n h (unfoldr sizeA f a) (unfoldr sizeB g b) =
zipWithUnfoldr2 n h (f,a) (g,b) ;
-}
-- block boundaries are changed here, so it changes lazy behaviour
"Storable.zipWith/unfoldr,*" forall sizeA sizeB f h a y.
zipWith sizeA h (unfoldr sizeB f a) y =
zipWithUnfoldr f h a y ;
-- block boundaries are changed here, so it changes lazy behaviour
"Storable.zipWith/*,unfoldr" forall sizeA sizeB f h a y.
zipWith sizeA h y (unfoldr sizeB f a) =
zipWithUnfoldr f (flip h) a y ;
"Storable.crochetL/unfoldr" forall size f g a b.
crochetL g b (unfoldr size f a) =
unfoldr size (\(a0,b0) ->
do (y0,a1) <- f a0
(z0,b1) <- g y0 b0
Just (z0, (a1,b1))) (a,b) ;
"Storable.reduceL/unfoldr" forall size f g a b.
reduceL g b (unfoldr size f a) =
snd
(FList.recourse (\(a0,b0) ->
do (y,a1) <- f a0
b1 <- g y b0
Just (a1, b1)) (a,b)) ;
"Storable.crochetL/cons" forall g b x xs.
crochetL g b (cons x xs) =
crochetLCons g b x xs ;
"Storable.reduceL/cons" forall g b x xs.
reduceL g b (cons x xs) =
reduceLCons g b x xs ;
"Storable.take/crochetL" forall f a x n.
take n (crochetL f a x) =
takeCrochet n (crochetL f a x) ;
"Storable.length/crochetL" forall f a x.
length (crochetL f a x) = length x ;
"Storable.map/crochetL" forall g f a x.
map g (crochetL f a x) =
mapCrochet g (crochetL f a x) ;
"Storable.zipWith/crochetL,*" forall size f h a x y.
zipWith size h (crochetL f a x) y =
zipWithCrochetL size f h a x y ;
"Storable.zipWith/*,crochetL" forall size f h a x y.
zipWith size h y (crochetL f a x) =
zipWithCrochetL size f (flip h) a x y ;
"Storable.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
Just (z0, (a1,b1))) (a,b) x ;
"Storable.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
Just (a1, b1)) (a,b) x) ;
#-}
{- * Fusion tests -}
fromMapList :: (Storable y) => ChunkSize -> (x -> y) -> [x] -> T y
fromMapList size f =
unfoldr size (fmap (mapFst f) . ListHT.viewL)
{-# RULES
"Storable.fromList/map" forall size f xs.
fromList size (List.map f xs) = fromMapList size f xs ;
#-}
fromMapFusionList :: (Storable y) =>
ChunkSize -> (x -> y) -> FList.T x -> T y
fromMapFusionList size f =
unfoldr size (fmap (mapFst f) . FList.viewL)
{-# RULES
"Storable.fromFusionList/map" forall size f xs.
fromFusionList size (FList.map f xs) = fromMapFusionList size f xs ;
"Storable.fromFusionList/replicate" forall size n x.
fromFusionList size (FList.replicate n x) = replicate size n x ;
#-}
testLength :: (Storable a, Enum a) => a -> Int
testLength x = length (map succ (fromList (ChunkSize 100) [x,x,x]))
testMapZip :: (Storable a, Enum a, Num a) =>
ChunkSize -> T a -> T a -> T a
-- testMapZip size x y = map snd (zipWith size (,) x y)
testMapZip size x y = map succ (zipWith size (P.+) x y)
testMapCons :: (Storable a, Enum a) =>
a -> T a -> T a
testMapCons x xs = map succ (cons x xs)
{-# INLINE testMapIterate #-}
{-# SPECIALISE testMapIterate ::
ChunkSize -> Char -> T Char #-}
testMapIterate :: (Storable a, Enum a) =>
ChunkSize -> a -> T a
testMapIterate size y = map pred $ iterate size succ y
testMapIterateInt ::
ChunkSize -> Int -> T Int
testMapIterateInt = testMapIterate
-}