MIDIControllerSelection.hs

module Synthesizer.CausalIO.ALSA.MIDIControllerSelection (
   fromChannel,
   filter,
   T(Cons),

   controllerLinear,
   controllerExponential,
   pitchBend,
   channelPressure,
   ) where

import qualified Synthesizer.CausalIO.Process as PIO
import qualified Synthesizer.CausalIO.ALSA.Process as PAlsa

import qualified Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet as PCS
import qualified Synthesizer.EventList.ALSA.MIDI as MIDIEv
import qualified Synthesizer.MIDIValue as MV

import qualified Sound.ALSA.Sequencer.Event as Event

-- import qualified Data.EventList.Relative.TimeBody  as EventList
import qualified Data.EventList.Relative.TimeTime  as EventListTT

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

import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import Data.Tuple.HT (mapSnd, )

import Control.Arrow (Arrow, )

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



fromChannel ::
   (Arrow arrow) =>
   MIDIEv.Channel ->
   arrow
      (EventListTT.T MIDIEv.StrictTime [Event.T])
      (EventListTT.T MIDIEv.StrictTime [(PCS.Controller, Int)])
fromChannel chan =
   PAlsa.mapMaybe $ PCS.maybeController chan


-- see PCS.mapInsertMany
mapInsertMany ::
   (Ord key) =>
   [(key,a)] -> Map.Map key a -> Map.Map key a
mapInsertMany assignments inits =
   foldl (flip (uncurry Map.insert)) inits assignments



data T a =
   Cons PCS.Controller (Int -> a) a

filter ::
   [T a] ->
   PIO.T
      (EventListTT.T MIDIEv.StrictTime [(PCS.Controller, Int)])
      (PCS.T Int a)
filter mapping =
   let dict =
          Map.fromList $
          zipWith (\n (Cons cc f _init) -> (cc, (n, f)))
             [0 ..] mapping
   in  PIO.mapAccum
          (\evs curMap ->
             let ctrlEvs =
                    fmap (Maybe.mapMaybe (\(cc, val) ->
                       fmap (mapSnd ($val)) $ Map.lookup cc dict)) evs
             in  (PCS.Cons curMap ctrlEvs,
                  mapInsertMany
                     (concat $ EventListTT.getBodies ctrlEvs)
                     curMap))
          (Map.fromList $ zip [0..] $
           map (\(Cons _cc _f initVal) -> initVal) mapping)


controllerLinear ::
   (Field.C y) =>
   MIDIEv.Controller ->
   (y,y) -> y ->
   T y
controllerLinear ctrl bnd initial =
   Cons (PCS.Controller ctrl) (MV.controllerLinear bnd) initial

controllerExponential ::
   (Trans.C y) =>
   MIDIEv.Controller ->
   (y,y) -> y ->
   T y
controllerExponential ctrl bnd initial =
   Cons (PCS.Controller ctrl) (MV.controllerExponential bnd) initial

pitchBend ::
   (Trans.C y) =>
   y -> y ->
   T y
pitchBend range center =
   Cons PCS.PitchBend (MV.pitchBend range center) center

channelPressure ::
   (Trans.C y) =>
   y -> y ->
   T y
channelPressure maxVal initial =
   Cons PCS.Pressure (MV.controllerLinear (zero,maxVal)) initial