{- 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,
      Vector.foldr,
      -- 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,
      -- for Test.Filter
      toList,
      -- for Storable.Filter.NonRecursive
      Vector.chunks,

      -- 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

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


{-
-- 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

-}