module Synthesizer.MIDI.CausalIO.ControllerSet (
   T,
   fromChannel,
   slice, PCS.Controller(..),

   controllerLinear,
   controllerExponential,
   pitchBend,
   channelPressure,
   bendWheelPressure,
   ) where

import qualified Synthesizer.CausalIO.Process as PIO
import qualified Synthesizer.MIDI.CausalIO.Process as MIO

import qualified Synthesizer.MIDI.PiecewiseConstant.ControllerSet as PCS
import qualified Synthesizer.MIDI.EventList as MIDIEv
import qualified Synthesizer.MIDI.Value.BendModulation as BM
import qualified Synthesizer.MIDI.Value.BendWheelPressure as BWP
import qualified Synthesizer.MIDI.Value as MV
import qualified Synthesizer.PiecewiseConstant.Signal as PC

import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
import qualified Sound.MIDI.Message.Class.Check as Check

import qualified Data.EventList.Relative.TimeTime  as EventListTT
import qualified Data.EventList.Relative.BodyTime  as EventListBT
import qualified Data.EventList.Relative.MixedTime as EventListMT

import qualified Algebra.Transcendental as Trans
import qualified Algebra.Field          as Field
import qualified Algebra.RealRing       as RealRing

import qualified Control.Monad.Trans.State as MS

import qualified Data.Accessor.Basic as Acc

import qualified Data.Map as Map

import Data.Traversable (traverse, )
import Data.Foldable (traverse_, )

import Control.Arrow (Arrow, arr, )
import Control.Category ((.), )

import qualified Data.Maybe as Maybe
import Data.Maybe.HT (toMaybe, )

import NumericPrelude.Numeric
import NumericPrelude.Base hiding ((.), )
import Prelude ()



-- see PCS.mapInsertMany
mapInsertMany ::
   (Ord key) =>
   [(key,a)] -> Map.Map key a -> Map.Map key a
mapInsertMany :: forall key a. Ord key => [(key, a)] -> Map key a -> Map key a
mapInsertMany [(key, a)]
assignments Map key a
inits =
   forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert)) Map key a
inits [(key, a)]
assignments


fromChannel ::
   (Check.C event) =>
   MIDIEv.Channel ->
   PIO.T
      (EventListTT.T MIDIEv.StrictTime [event])
      (PCS.T PCS.Controller Int)
fromChannel :: forall event.
C event =>
Channel -> T (T StrictTime [event]) (T Controller Int)
fromChannel Channel
chan =
   (forall state a b. state -> (a -> State state b) -> T a b
PIO.traverse forall k a. Map k a
Map.empty forall a b. (a -> b) -> a -> b
$ \T StrictTime [(Controller, Int)]
evs0 -> do
      Map Controller Int
initial <- forall (m :: * -> *) s. Monad m => StateT s m s
MS.get
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall key a. Map key a -> T StrictTime [(key, a)] -> T key a
PCS.Cons Map Controller Int
initial) forall a b. (a -> b) -> a -> b
$
         forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\[(Controller, Int)]
ys -> forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
MS.modify (forall key a. Ord key => [(key, a)] -> Map key a -> Map key a
mapInsertMany [(Controller, Int)]
ys) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [(Controller, Int)]
ys) T StrictTime [(Controller, Int)]
evs0)
   forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.
   forall (arrow :: * -> * -> *) (f :: * -> *) a b.
(Arrow arrow, Functor f) =>
(a -> Maybe b) -> arrow (f [a]) (f [b])
MIO.mapMaybe (forall event.
C event =>
Channel -> event -> Maybe (Controller, Int)
PCS.maybeController Channel
chan)


type T arrow y =
   arrow
      (PCS.T PCS.Controller Int)
      (EventListBT.T PC.ShortStrictTime y)


slice ::
   (Arrow arrow) =>
   PCS.Controller ->
   (Int -> y) {- ^ This might be a function from "Synthesizer.MIDI.Value"
                   or "Synthesizer.Dimensional.MIDIValue" -} ->
   y ->
   T arrow y
slice :: forall (arrow :: * -> * -> *) y.
Arrow arrow =>
Controller -> (Int -> y) -> y -> T arrow y
slice Controller
c Int -> y
f y
deflt =
   forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a b. (a -> b) -> a -> b
$ \(PCS.Cons Map Controller Int
initial T StrictTime [(Controller, Int)]
stream) ->
      let yin :: y
yin = forall b a. b -> (a -> b) -> Maybe a -> b
maybe y
deflt Int -> y
f forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Controller
c Map Controller Int
initial
      in  forall y. T StrictTime y -> T ShortStrictTime y
PC.subdivideLongStrict forall a b. (a -> b) -> a -> b
$
          forall body time. body -> T time body -> T time body
EventListMT.consBody y
yin forall a b. (a -> b) -> a -> b
$
          forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
MS.evalState y
yin forall a b. (a -> b) -> a -> b
$
          forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
             (\[Int]
ys -> forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (m :: * -> *) s. Monad m => s -> StateT s m ()
MS.put forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int -> y
f) [Int]
ys forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) s. Monad m => StateT s m s
MS.get) forall a b. (a -> b) -> a -> b
$
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
             (forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe
                (\(Controller
ci,Int
a) -> forall a. Bool -> a -> Maybe a
toMaybe (Controller
cforall a. Eq a => a -> a -> Bool
==Controller
ci) Int
a))
             T StrictTime [(Controller, Int)]
stream


controllerLinear ::
   (Field.C y, Arrow arrow) =>
   MIDIEv.Controller ->
   (y,y) -> y ->
   T arrow y
controllerLinear :: forall y (arrow :: * -> * -> *).
(C y, Arrow arrow) =>
Controller -> (y, y) -> y -> T arrow y
controllerLinear Controller
ctrl (y, y)
bnd y
initial =
   forall (arrow :: * -> * -> *) y.
Arrow arrow =>
Controller -> (Int -> y) -> y -> T arrow y
slice (Controller -> Controller
PCS.Controller Controller
ctrl) (forall y. C y => (y, y) -> Int -> y
MV.controllerLinear (y, y)
bnd) y
initial

controllerExponential ::
   (Trans.C y, Arrow arrow) =>
   MIDIEv.Controller ->
   (y,y) -> y ->
   T arrow y
controllerExponential :: forall y (arrow :: * -> * -> *).
(C y, Arrow arrow) =>
Controller -> (y, y) -> y -> T arrow y
controllerExponential Controller
ctrl (y, y)
bnd y
initial =
   forall (arrow :: * -> * -> *) y.
Arrow arrow =>
Controller -> (Int -> y) -> y -> T arrow y
slice (Controller -> Controller
PCS.Controller Controller
ctrl) (forall y. C y => (y, y) -> Int -> y
MV.controllerExponential (y, y)
bnd) y
initial

pitchBend ::
   (Trans.C y, Arrow arrow) =>
   y -> y ->
   T arrow y
pitchBend :: forall y (arrow :: * -> * -> *).
(C y, Arrow arrow) =>
y -> y -> T arrow y
pitchBend y
range y
center =
   forall (arrow :: * -> * -> *) y.
Arrow arrow =>
Controller -> (Int -> y) -> y -> T arrow y
slice Controller
PCS.PitchBend (forall y. C y => y -> y -> Int -> y
MV.pitchBend y
range y
center) y
center

channelPressure ::
   (Trans.C y, Arrow arrow) =>
   y -> y ->
   T arrow y
channelPressure :: forall y (arrow :: * -> * -> *).
(C y, Arrow arrow) =>
y -> y -> T arrow y
channelPressure y
maxVal y
initial =
   forall (arrow :: * -> * -> *) y.
Arrow arrow =>
Controller -> (Int -> y) -> y -> T arrow y
slice Controller
PCS.Pressure (forall y. C y => (y, y) -> Int -> y
MV.controllerLinear (forall a. C a => a
zero,y
maxVal)) y
initial

bendWheelPressure ::
   (RealRing.C y, Trans.C y, Arrow arrow) =>
   Int -> y -> y ->
   T arrow (BM.T y)
bendWheelPressure :: forall y (arrow :: * -> * -> *).
(C y, C y, Arrow arrow) =>
Int -> y -> y -> T arrow (T y)
bendWheelPressure Int
pitchRange y
wheelDepth y
pressDepth =
   forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a b. (a -> b) -> a -> b
$ \(PCS.Cons Map Controller Int
initial T StrictTime [(Controller, Int)]
stream) ->
      let set :: Controller -> T a Int -> a -> a
set Controller
key T a Int
field =
             forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall r a. T r a -> a -> r -> r
Acc.set T a Int
field) forall a b. (a -> b) -> a -> b
$
             forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Controller
key Map Controller Int
initial
          yin :: T
yin =
             forall {a}. Controller -> T a Int -> a -> a
set Controller
PCS.PitchBend T T Int
BWP.bend forall a b. (a -> b) -> a -> b
$
             forall {a}. Controller -> T a Int -> a -> a
set (Controller -> Controller
PCS.Controller Controller
VoiceMsg.modulation) T T Int
BWP.wheel forall a b. (a -> b) -> a -> b
$
             forall {a}. Controller -> T a Int -> a -> a
set Controller
PCS.Pressure T T Int
BWP.pressure forall a b. (a -> b) -> a -> b
$
             T
BWP.deflt
      in  forall y. T StrictTime y -> T ShortStrictTime y
PC.subdivideLongStrict forall a b. (a -> b) -> a -> b
$
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. (C a, C a) => Int -> a -> a -> T -> T a
BM.fromBendWheelPressure Int
pitchRange y
wheelDepth y
pressDepth) forall a b. (a -> b) -> a -> b
$
          forall body time. body -> T time body -> T time body
EventListMT.consBody T
yin forall a b. (a -> b) -> a -> b
$
          forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
MS.evalState T
yin forall a b. (a -> b) -> a -> b
$
          forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\[T]
ys0 -> forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ forall (m :: * -> *) s. Monad m => s -> StateT s m ()
MS.put [T]
ys0 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) s. Monad m => StateT s m s
MS.get) forall a b. (a -> b) -> a -> b
$
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
Maybe.catMaybes forall a b. (a -> b) -> a -> b
$
          forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
MS.evalState T
BWP.deflt forall a b. (a -> b) -> a -> b
$
          forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Controller, Int) -> State T (Maybe T)
PCS.checkBendWheelPressure) T StrictTime [(Controller, Int)]
stream