{-# LANGUAGE NoImplicitPrelude #-}
{- |
Copyright   :  (c) Henning Thielemann 2006
License     :  GPL

Maintainer  :  synthesizer@henning-thielemann.de
Stability   :  provisional
Portability :  requires multi-parameter type classes
-}
module Synthesizer.State.Cut (
   {- * dissection -}
   takeUntilPause,
   takeUntilInterval,
   chopStorable,
   chopChunkySize,

   {- * glueing -}
   selectBool,
   select,
   arrange,
   arrangeList,
   ) where

import qualified Synthesizer.State.Signal as Sig

import qualified Synthesizer.Storable.Signal as SigSt
import qualified Synthesizer.Generic.CutChunky as CutChunky
import qualified Synthesizer.Generic.Cut as Cut
import Foreign.Storable (Storable)

import qualified Data.EventList.Relative.TimeBody as EventList

import qualified MathObj.LaurentPolynomial as Laurent
import qualified Algebra.RealRing     as RealRing
import qualified Algebra.Additive as Additive

import Control.Applicative (Applicative, )

import qualified Data.List.HT as ListHT
import qualified Data.Array as Array
import Data.Traversable (sequenceA, )
import Data.Tuple.HT (mapFst, mapSnd, )
import Data.Array (Array, Ix, (!), )
import Data.Maybe (fromMaybe, )

import qualified Synthesizer.ChunkySize as ChunkySize
import qualified Number.NonNegative as NonNegW

import NumericPrelude.Numeric
import NumericPrelude.Base



{- |
Take signal until it falls short of a certain amplitude for a given time.
-}
{-# INLINE takeUntilPause #-}
takeUntilPause :: (RealRing.C a) => a -> Int -> Sig.T a -> Sig.T a
takeUntilPause :: forall a. C a => a -> Int -> T a -> T a
takeUntilPause a
y =
   forall a. (a -> Bool) -> Int -> T a -> T a
takeUntilInterval ((forall a. Ord a => a -> a -> Bool
<=a
y) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. C a => a -> a
abs)

{- |
Take values until the predicate p holds for n successive values.
The list is truncated at the beginning of the interval of matching values.
-}
{-# INLINE takeUntilInterval #-}
takeUntilInterval :: (a -> Bool) -> Int -> Sig.T a -> Sig.T a
takeUntilInterval :: forall a. (a -> Bool) -> Int -> T a -> T a
takeUntilInterval a -> Bool
p Int
n T a
xs =
   forall a b. (a -> b) -> T a -> T b
Sig.map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$
   forall a. (a -> Bool) -> T a -> T a
Sig.takeWhile ((forall a. Ord a => a -> a -> Bool
<Int
n) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$
   forall a b. T a -> T b -> T (a, b)
Sig.zip T a
xs forall a b. (a -> b) -> a -> b
$
   forall a. Int -> T a -> T a
Sig.drop Int
n forall a b. (a -> b) -> a -> b
$
   forall a. T a -> T a -> T a
Sig.append (forall acc x. (acc -> x -> acc) -> acc -> T x -> T acc
Sig.scanL (\Int
acc a
x -> if a -> Bool
p a
x then forall a. Enum a => a -> a
succ Int
acc else Int
0) Int
0 T a
xs) forall a b. (a -> b) -> a -> b
$
   forall a. a -> T a
Sig.repeat Int
0



{-# INLINE selectBool #-}
selectBool :: (Sig.T a, Sig.T a) -> Sig.T Bool -> Sig.T a
selectBool :: forall a. (T a, T a) -> T Bool -> T a
selectBool =
   forall a b c. (a -> b -> c) -> T a -> T b -> T c
Sig.zipWith (\(a
xf,a
xt) Bool
c -> if Bool
c then a
xt else a
xf) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. T a -> T b -> T (a, b)
Sig.zip


{-# INLINE select #-}
select :: Ix i => Array i (Sig.T a) -> Sig.T i -> Sig.T a
select :: forall i a. Ix i => Array i (T a) -> T i -> T a
select =
   forall x acc y. (x -> acc -> Maybe (y, acc)) -> acc -> T x -> T y
Sig.crochetL
      (\i
xi Array i (T a)
arr ->
           do Array i (a, T a)
arr0 <- forall (f :: * -> *) i a.
(Applicative f, Ix i) =>
Array i (f a) -> f (Array i a)
sequenceArray (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. T a -> Maybe (a, T a)
Sig.viewL Array i (T a)
arr)
              forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a, b) -> a
fst (Array i (a, T a)
arr0forall i e. Ix i => Array i e -> i -> e
!i
xi), forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd Array i (a, T a)
arr0))

{-# INLINE sequenceArray #-}
sequenceArray ::
   (Applicative f, Ix i) =>
   Array i (f a) -> f (Array i a)
sequenceArray :: forall (f :: * -> *) i a.
(Applicative f, Ix i) =>
Array i (f a) -> f (Array i a)
sequenceArray Array i (f a)
arr =
   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall i e. Ix i => (i, i) -> [e] -> Array i e
Array.listArray (forall i e. Array i e -> (i, i)
Array.bounds Array i (f a)
arr)) forall a b. (a -> b) -> a -> b
$
   forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (forall i e. Array i e -> [e]
Array.elems Array i (f a)
arr)


{- |
Given a list of signals with time stamps,
mix them into one signal as they occur in time.
Ideally for composing music.

Cf. 'MathObj.LaurentPolynomial.series'
-}
{-# INLINE arrangeList #-}
arrangeList :: (Additive.C v) =>
       EventList.T NonNegW.Int (Sig.T v)
            {-^ A list of pairs: (relative start time, signal part),
                The start time is relative to the start time
                of the previous event. -}
    -> Sig.T v
            {-^ The mixed signal. -}
arrangeList :: forall v. C v => T Int (T v) -> T v
arrangeList T Int (T v)
evs =
   let xs :: [[v]]
xs = forall a b. (a -> b) -> [a] -> [b]
map forall y. T y -> [y]
Sig.toList (forall time body. T time body -> [body]
EventList.getBodies T Int (T v)
evs)
   in  case forall a b. (a -> b) -> [a] -> [b]
map forall a. T a -> a
NonNegW.toNumber (forall time body. T time body -> [time]
EventList.getTimes T Int (T v)
evs) of
          Int
t:[Int]
ts -> forall a. Int -> a -> T a
Sig.replicate Int
t forall a. C a => a
zero forall a. T a -> T a -> T a
`Sig.append`
                  forall y. [y] -> T y
Sig.fromList (forall a. C a => [Int] -> [[a]] -> [a]
Laurent.addShiftedMany [Int]
ts [[v]]
xs)
          []   -> forall a. T a
Sig.empty




{-# INLINE arrange #-}
arrange :: (Additive.C v) =>
       EventList.T NonNegW.Int (Sig.T v)
            {-^ A list of pairs: (relative start time, signal part),
                The start time is relative to the start time
                of the previous event. -}
    -> Sig.T v
            {-^ The mixed signal. -}
arrange :: forall v. C v => T Int (T v) -> T v
arrange T Int (T v)
evs =
   let xs :: [T v]
xs = forall time body. T time body -> [body]
EventList.getBodies T Int (T v)
evs
   in  case forall a b. (a -> b) -> [a] -> [b]
map forall a. T a -> a
NonNegW.toNumber (forall time body. T time body -> [time]
EventList.getTimes T Int (T v)
evs) of
          Int
t:[Int]
ts -> forall a. Int -> a -> T a
Sig.replicate Int
t forall a. C a => a
zero forall a. T a -> T a -> T a
`Sig.append`
                  forall a. C a => [Int] -> [T a] -> T a
addShiftedMany [Int]
ts [T v]
xs
          []   -> forall a. T a
Sig.empty


{-# INLINE addShiftedMany #-}
addShiftedMany :: (Additive.C a) => [Int] -> [Sig.T a] -> Sig.T a
addShiftedMany :: forall a. C a => [Int] -> [T a] -> T a
addShiftedMany [Int]
ds [T a]
xss =
   forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. C a => Int -> T a -> T a -> T a
addShifted) forall a. T a
Sig.empty (forall a b. [a] -> [b] -> [(a, b)]
zip ([Int]
dsforall a. [a] -> [a] -> [a]
++[forall a. C a => a
zero]) [T a]
xss)



{-# INLINE addShifted #-}
addShifted :: Additive.C a => Int -> Sig.T a -> Sig.T a -> Sig.T a
addShifted :: forall a. C a => Int -> T a -> T a -> T a
addShifted Int
del T a
xs T a
ys =
   if Int
del forall a. Ord a => a -> a -> Bool
< Int
0
     then forall a. HasCallStack => [Char] -> a
error [Char]
"State.Signal.addShifted: negative shift"
     else
       forall y x. T y -> (forall s. (s -> Maybe (y, s)) -> s -> x) -> x
Sig.runViewL T a
xs (\s -> Maybe (a, s)
nextX s
xs2 ->
       forall y x. T y -> (forall s. (s -> Maybe (y, s)) -> s -> x) -> x
Sig.runViewL T a
ys (\s -> Maybe (a, s)
nextY s
ys2 ->
          forall acc y. (acc -> Maybe (y, acc)) -> acc -> T y
Sig.unfoldR
             (\((Int
d,s
ys0),s
xs0) ->
                 -- d<0 cannot happen
                 if Int
dforall a. Eq a => a -> a -> Bool
==forall a. C a => a
zero
                   then
                     forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                        (forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd (\(s
xs1,s
ys1) -> ((forall a. C a => a
zero,s
ys1),s
xs1)))
                        (forall s a t.
(s -> Maybe (a, s))
-> (t -> Maybe (a, t))
-> (a -> a -> a)
-> (s, t)
-> Maybe (a, (s, t))
Sig.zipStep s -> Maybe (a, s)
nextX s -> Maybe (a, s)
nextY forall a. C a => a -> a -> a
(+) (s
xs0, s
ys0))
                   else
                     forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd ((,) (forall a. Enum a => a -> a
pred Int
d, s
ys0)) forall a b. (a -> b) -> a -> b
$
                     forall a. a -> Maybe a -> a
fromMaybe (forall a. C a => a
zero, s
xs0) forall a b. (a -> b) -> a -> b
$ s -> Maybe (a, s)
nextX s
xs0)
             ((Int
del,s
ys2),s
xs2)
       ))


{- |
Split a storable signal into a sequence of signals.
A new piece is started whenever the Boolean signal contains a 'True'.
The first piece in the result is the part from the beginning until the first 'True'.
That is, if the signal 'Bool' starts with a 'True',
then the first result piece is empty.

When the control signal is at least as long as the storable signal
and if we neglect the chunking structure, then it holds

> concat (chopStorable bs xs) == xs
-}
chopStorable :: Storable a => Sig.T Bool -> SigSt.T a -> [SigSt.T a]
chopStorable :: forall a. Storable a => T Bool -> T a -> [T a]
chopStorable = forall chunky. C chunky => T Bool -> chunky -> [chunky]
chop

chopChunkySize :: Sig.T Bool -> ChunkySize.T -> [ChunkySize.T]
chopChunkySize :: T Bool -> T -> [T]
chopChunkySize = forall chunky. C chunky => T Bool -> chunky -> [chunky]
chop


chop :: CutChunky.C chunky => Sig.T Bool -> chunky -> [chunky]
chop :: forall chunky. C chunky => T Bool -> chunky -> [chunky]
chop T Bool
bs =
   forall y x. T y -> (forall s. (s -> Maybe (y, s)) -> s -> x) -> x
Sig.runViewL T Bool
bs forall a b. (a -> b) -> a -> b
$ \s -> Maybe (Bool, s)
f s
s ->
      let go :: s -> [Chunk a] -> (a, [a])
go s
_ [] = (forall sig. Monoid sig => sig
Cut.empty, [])
          go s
s0 (Chunk a
chunk:[Chunk a]
chunks) =
             case forall chunk s.
Transform chunk =>
(s -> Maybe (Bool, s)) -> chunk -> s -> ([chunk], Maybe s)
chopChunk s -> Maybe (Bool, s)
f Chunk a
chunk s
s0 of
                ([Chunk a]
split, Maybe s
ms) ->
                   forall chunky.
C chunky =>
[Chunk chunky] -> (chunky, [chunky]) -> (chunky, [chunky])
prependChunks [Chunk a]
split forall a b. (a -> b) -> a -> b
$
                   case Maybe s
ms of
                      Maybe s
Nothing -> (forall chunky. C chunky => [Chunk chunky] -> chunky
CutChunky.fromChunks [Chunk a]
chunks, [])
                      Just s
s1 -> s -> [Chunk a] -> (a, [a])
go s
s1 [Chunk a]
chunks
      in  forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. C a => s -> [Chunk a] -> (a, [a])
go s
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall chunky. C chunky => chunky -> [Chunk chunky]
CutChunky.toChunks

prependChunks ::
   CutChunky.C chunky =>
   [CutChunky.Chunk chunky] ->
   (chunky, [chunky]) ->
   (chunky, [chunky])
prependChunks :: forall chunky.
C chunky =>
[Chunk chunky] -> (chunky, [chunky]) -> (chunky, [chunky])
prependChunks [] (chunky, [chunky])
xs = (chunky, [chunky])
xs
prependChunks (Chunk chunky
chunk:[Chunk chunky]
chunks) (chunky, [chunky])
xs =
   let go :: Chunk chunky -> [Chunk chunky] -> (chunky, [chunky])
go Chunk chunky
c0 [Chunk chunky]
css =
          forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst
             (\chunky
y ->
                if forall sig. Read sig => sig -> Bool
Cut.null Chunk chunky
c0
                  then chunky
y
                  else forall chunky. C chunky => [Chunk chunky] -> chunky
CutChunky.fromChunks forall a b. (a -> b) -> a -> b
$ Chunk chunky
c0 forall a. a -> [a] -> [a]
: forall chunky. C chunky => chunky -> [Chunk chunky]
CutChunky.toChunks chunky
y)
             (case [Chunk chunky]
css of
                [] -> (chunky, [chunky])
xs
                (Chunk chunky
c1:[Chunk chunky]
cs) -> (forall sig. Monoid sig => sig
Cut.empty, forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:) (Chunk chunky -> [Chunk chunky] -> (chunky, [chunky])
go Chunk chunky
c1 [Chunk chunky]
cs)))
   in  Chunk chunky -> [Chunk chunky] -> (chunky, [chunky])
go Chunk chunky
chunk [Chunk chunky]
chunks

chopChunk ::
   Cut.Transform chunk =>
   (s -> Maybe (Bool, s)) ->
   chunk -> s -> ([chunk], Maybe s)
chopChunk :: forall chunk s.
Transform chunk =>
(s -> Maybe (Bool, s)) -> chunk -> s -> ([chunk], Maybe s)
chopChunk s -> Maybe (Bool, s)
f chunk
vs =
   let go :: Int -> s -> ([Int], Maybe s)
go Int
j s
s0 =
          if Int
j forall a. Ord a => a -> a -> Bool
>= forall sig. Read sig => sig -> Int
Cut.length chunk
vs
            then ([Int
j], forall a. a -> Maybe a
Just s
s0)
            else
              case s -> Maybe (Bool, s)
f s
s0 of
                 Maybe (Bool, s)
Nothing -> ([Int
j, forall sig. Read sig => sig -> Int
Cut.length chunk
vs], forall a. Maybe a
Nothing)
                 Just (Bool
b,s
s1) ->
                    (if Bool
b
                       then forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst (Int
jforall a. a -> [a] -> [a]
:)
                       else forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
                    Int -> s -> ([Int], Maybe s)
go (forall a. Enum a => a -> a
succ Int
j) s
s1
   in  forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst
          (forall a b. (a -> a -> b) -> [a] -> [b]
ListHT.mapAdjacent (\Int
from Int
to -> forall sig. Transform sig => Int -> sig -> sig
Cut.drop Int
from forall a b. (a -> b) -> a -> b
$ forall sig. Transform sig => Int -> sig -> sig
Cut.take Int
to chunk
vs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
0forall a. a -> [a] -> [a]
:)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
       Int -> s -> ([Int], Maybe s)
go Int
0