Block.hs

module Sound.Signal.Block where

import Data.Array (Array, (!), listArray)

import qualified Sound.Signal as Signal
import qualified Synthesizer.Plain.Signal as ListSignal

import qualified Data.List as List

import NumericPrelude.Condition (toMaybe)
import Prelude hiding ((++), iterate, foldl, zipWith, tail, head)


instance Signal.C T where
   singleton = singleton
   unfoldR   = unfoldR defaultChunkSize
   reduceL   = reduceL
   mapAccumL = mapAccumL defaultChunkSize
   (++)      = append
   zipWith   = zipWith defaultChunkSize


type ChunkSize = Int

defaultChunkSize :: ChunkSize
defaultChunkSize = 256

newtype T a = Cons {
   chunks :: [Chunk a]
  }
   deriving (Show)

{- |
The array starts with index 0.
We always consider a subarray of 'body'
starting at 'offset' with size 'size'.
This way we safe copy operations
and we can efficiently 'drop', 'take' and 'append' chunk lists.
Unfortunately, 'Data.Array' does not provide subarrays with sharing.
Every chunk must have at least size 1.
-}
data Chunk a = Chunk {
   offset :: Int,
   size   :: ChunkSize,
   body   :: Array Int a
  }
   deriving (Show)


singleton :: a -> T a
singleton x = Cons [Chunk 0 1 (listArray (0,0) [x])]

isEmpty :: T a -> Bool
isEmpty (Cons x) = null x

head :: T a -> a
head (Cons xt) =
   case xt of
      [] -> error "Signal.Block.head: empty list"
      (Chunk start _ arr : _) -> arr ! start

tail :: T a -> T a
tail (Cons xt) =
   case xt of
      [] -> error "Signal.Block.tail: empty list"
      (Chunk start sz arr : xs) -> Cons
          (if sz>1
             then Chunk (succ start) (pred sz) arr : xs
             else xs)

tails :: T a -> [T a]
tails =
   List.unfoldr
      (\x -> toMaybe (not (isEmpty x))
         (let tailX = tail x in (tailX,tailX)))

toList :: T a -> [a]
toList =
   List.concatMap
      (\(Chunk start sz arr) ->
           take sz (map (arr!) [start..])) . chunks

toListAlt :: T a -> [a]
toListAlt = List.init . map head . tails

fromList :: ChunkSize -> [a] -> T a
fromList chunkSize =
   let recurse [] = []
       recurse xs =
          let actSize = minLength chunkSize xs
          in  Chunk 0 actSize (listArray (0,actSize-1) xs) :
                if actSize < chunkSize
                  then []
                  else recurse (drop chunkSize xs)
   in  Cons . recurse

{-
@minLength n x = min n (length x)@,
but 'minLength' is more lazy than 'length'.
-}
minLength :: Int -> [a] -> Int
minLength =
   let recurse seenSoFar expected xt =
          case xt of
             [] -> seenSoFar
             (_:xs) ->
                 if expected == 0
                   then seenSoFar
                   else recurse (succ seenSoFar) (pred expected) xs
   in  recurse 0

{-
poor man's implementation via lists
I do not know which array function could be of help here.
-}
unfoldR :: ChunkSize -> (acc -> Maybe (y, acc)) -> acc -> (acc, T y)
unfoldR chunkSize f acc =
   let (accEnd, xs) = ListSignal.unfoldR f acc
   in  (accEnd, fromList chunkSize xs)

reduceL :: (a -> acc -> Maybe acc) -> acc -> T a -> acc
reduceL f start =
   ListSignal.reduceL f start . toList
{- when running on array separately it would be complicated
to distinguish between termination because the signal is finished
and because the abort condition is fulfilled. -}
--   List.foldl' (\acc -> List.reduceL f acc . elems) start . toChunkList


mapAccumL :: ChunkSize ->
   (x -> acc -> Maybe (y, acc)) -> acc -> T x -> (acc, T y)
mapAccumL chunkSize f accStart xs =
   let (accEnd, ys) = ListSignal.mapAccumL f accStart (toList xs)
   in  (accEnd, fromList chunkSize ys)


append :: T a -> T a -> T a
append (Cons x) (Cons y) = Cons (x List.++ y)

zipWith :: ChunkSize -> (a -> b -> c) -> (T a -> T b -> T c)
zipWith chunkSize f x y =
   fromList chunkSize $
   List.zipWith f (toList x) (toList y)