{- OPTIONS_GHC -O2 -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.span,
      Vector.append,
      Vector.concat,
      Vector.span,
      Vector.splitAt,
      Vector.viewL,
      Vector.viewR,
      Vector.switchL,
      Vector.unfoldr,
      Vector.reverse,
      -- for Dimensional.File
      Vector.writeFile,
      -- for Storable.Cut
      splitAtPad,
      -- 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,
   ) where

-- import qualified Sound.Signal as Signal

import qualified Synthesizer.Generic.Signal as SigG
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 qualified Data.Char as Char
-- import Data.Int (Int8)

import Data.StorableVector(Vector)
import Foreign.Storable (Storable)
import Foreign.Ptr (minusPtr)
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.Marshal (advancePtr)
import StorableInstance ()

-- 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 NumericPrelude.Condition (toMaybe)
import NumericPrelude.List (sliceVert, dropWhileRev, )

import Synthesizer.Utility (viewListL, viewListR, nest, mapFst, mapSnd, mapPair)

-- import qualified Algebra.Additive as Additive


import System.IO (openBinaryFile, hClose, hPutBuf, IOMode(WriteMode), Handle)
import Control.Exception (bracket)


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

instance SigG.C Vector.Vector where
   {-# INLINE empty #-}
   empty = Vector.empty
   {-# INLINE null #-}
   null = Vector.null
   {-# INLINE cons #-}
   cons = Vector.cons
   {-# INLINE fromList #-}
   fromList = Vector.pack defaultChunkSize
   {-# INLINE toList #-}
   toList = Vector.unpack
   {-# INLINE repeat #-}
   repeat = Vector.repeat defaultChunkSize
   {-# INLINE cycle #-}
   cycle = Vector.cycle
   {-# INLINE replicate #-}
   replicate = Vector.replicate defaultChunkSize
   {-# INLINE iterate #-}
   iterate = Vector.iterate defaultChunkSize
   {-# INLINE iterateAssoc #-}
   iterateAssoc op x = Vector.iterate defaultChunkSize (op x) x -- should be optimized
   {-# INLINE unfoldR #-}
   unfoldR = Vector.unfoldr defaultChunkSize
   {-# INLINE map #-}
   map = Vector.map
   {-# INLINE mix #-}
   mix = mix
   {-# INLINE zipWith #-}
   zipWith = Vector.zipWith
   {-# INLINE scanL #-}
   scanL = Vector.scanl
   {-# INLINE viewL #-}
   viewL = Vector.viewL
   {-# INLINE viewR #-}
   viewR = Vector.viewR
   {-# INLINE foldL #-}
   foldL = Vector.foldl
   {-# INLINE length #-}
   length = Vector.length
   {-# INLINE take #-}
   take = Vector.take
   {-# INLINE drop #-}
   drop = Vector.drop
   {-# INLINE splitAt #-}
   splitAt = Vector.splitAt
   {-# INLINE dropMarginRem #-}
   dropMarginRem = Vector.dropMarginRem  -- can occur in an inner loop in Interpolation
   {-# INLINE takeWhile #-}
   takeWhile = Vector.takeWhile
   {-# INLINE dropWhile #-}
   dropWhile = Vector.dropWhile
   {-# INLINE span #-}
   span = Vector.span
   {-# INLINE append #-}
   append = Vector.append
   {-# INLINE concat #-}
   concat = Vector.concat
   {-# INLINE reverse #-}
   reverse = Vector.reverse
{-
   {-# INLINE mapAccumL #-}
   mapAccumL = Vector.mapAccumL
   {-# INLINE mapAccumR #-}
   mapAccumR = Vector.mapAccumR
-}
   {-# INLINE crochetL #-}
   crochetL = Vector.crochetL


{-
{- * 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 recurse i acc =
          if i < Vector.length x
            then (acc, True)
            else
               maybe
                  (acc, False)
                  (recurse (succ i))
                  (f (Vector.index x i) acc)
   in  recurse 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) <- viewListL 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) <- viewListL (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) <- viewListR (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) <- viewListL 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 viewListL

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 recurse acc xt =
          case xt of
             [] -> acc
             (x:xs) ->
                 let (acc',continue) = reduceLVector f acc x
                 in  if continue
                       then recurse acc' xs
                       else acc'
   in  recurse 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 recurse _ [] = ([], [])
       recurse 0 xs = ([], xs)
       recurse n (x:xs) =
          let m = Vector.length x
          in  if m<=n
                then mapFst (x:) $ recurse (n-m) xs
                else mapPair ((:[]), (:xs)) $ Vector.splitAt n x
   in  mapPair (Cons, Cons) . recurse 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 recurse [] = ([],[])
       recurse (x:xs) =
          let (y,z) = Vector.span p x
          in  if Vector.null z
                then mapFst (x:) (recurse xs)
                else (decons $ fromChunk y, (z:xs))
   in  mapPair (Cons, Cons) . recurse . 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 recurse n xt =
          if n<=0
            then xt
            else
              case xt of
                 [] -> decons $ replicate size n y
                 x:xs -> x : recurse (n - Vector.length x) xs
   in  Cons . recurse 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) #-}
{-# INLINE mix #-}
{-
'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 xs ys =
   let len = min (lazyLength xs) (lazyLength ys) :: Chunky.T NonNeg.Int
       (prefixX,suffixX) = genericSplitAt len xs
       (prefixY,suffixY) = genericSplitAt len ys
   in  Vector.append
          (Vector.crochetL
              (\y xs0 ->
                  fmap (mapFst (y+)) (Vector.viewL xs0))
              prefixX prefixY)
          (if Vector.null suffixX
             then suffixY
             else suffixX)
{-
List.map V.unpack $ Vector.chunks $ mix (fromList defaultChunkSize [1,2,3,4,5::P.Double]) (fromList defaultChunkSize [1,2,3,4])
-}


{-
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 recurse n xs0 =
          maybe
             ([], [])
             (\(x,xs) ->
                if isZero n
                  then ([], xs0)
                  else
                    let m = fromIntegral $ V.length x
                    in  if m<=n
                          then mapFst (x:) $ recurse (n-m) xs
                          else mapPair ((:[]), (:xs)) $
                               V.splitAt (fromInteger $ toInteger n) x)
           $ viewListL xs0
   in  mapPair (Vector.SV, Vector.SV) . recurse n0 . Vector.chunks


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 the like. -}
   -> 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 recurse n a =
          maybe n (recurse (succ n) . snd) (f a)
   in  recurse 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.recurse (\(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) . viewListL)

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

-}