{-# 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 Data.Maybe (Maybe(Just,Nothing), maybe, fromMaybe)

-- import Data.StorableVector(Vector)
import Foreign.Storable (Storable, )
import Foreign.Storable.Tuple ()

import qualified Synthesizer.Frame.Stereo as Stereo
-- 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.Numeric
import NumericPrelude.Base
import Prelude ()


{-
import NumericPrelude.Numeric
   (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


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]


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

{- disabled RULES
  "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) ;

  -}

{- disabled 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 ;
-}
-}


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


{-
The "fromList/drop" rule is not quite accurate
because the chunk borders are moved.
Maybe 'ChunkSize' better is a list of chunks sizes.
-}

{- disabled RULES
  "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
          (untilNothing (\(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) ;
  #-}


-- maybe candidate for Utility, cf. FusionList.Signal.recourse

{-# INLINE untilNothing #-}
untilNothing :: (acc -> Maybe acc) -> acc -> acc
untilNothing f =
   let aux x = maybe x aux (f x)
   in  aux


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


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

-}