{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE Rank2Types #-}
module Reactive.Banana.ALSA.Sequencer where

import qualified Reactive.Banana.ALSA.Common as Common
import qualified Reactive.Banana.ALSA.Guitar as Guitar
import qualified Reactive.Banana.ALSA.KeySet as KeySet
import qualified Reactive.Banana.ALSA.Time as Time
import qualified Reactive.Banana.ALSA.Utility as RBU

import qualified Reactive.Banana.Combinators as RB
import qualified Reactive.Banana.Frameworks as RBF
import qualified Reactive.Banana.Switch as RBS
import Reactive.Banana.Combinators ((<@>), )

import qualified Sound.ALSA.Sequencer.Event.RemoveMonad as Remove
import qualified Sound.ALSA.Sequencer.Event as Event
import qualified Sound.ALSA.Sequencer.Address as Addr

import qualified Sound.MIDI.ALSA.Check as Check
import qualified Sound.MIDI.ALSA as MALSA
import Sound.MIDI.ALSA (normalNoteFromEvent, )

import Sound.MIDI.Message.Channel (Channel, )
import Sound.MIDI.Message.Channel.Voice
          (Pitch, Controller, Velocity, Program, normalVelocity,
           fromPitch, toPitch, )

import qualified Data.EventList.Relative.TimeBody as EventList
import qualified Data.EventList.Absolute.TimeBody as EventListAbs

import qualified Data.Accessor.Monad.Trans.State as AccState
import qualified Data.Accessor.Tuple as AccTuple
import Data.Accessor.Basic ((^.), )

import qualified Control.Monad.Trans.Class as MT
import qualified Control.Monad.Trans.State as MS
import qualified Control.Monad.Trans.Reader as MR
import Control.Monad.Trans.Reader (ReaderT(ReaderT), )
import Control.Monad.IO.Class (MonadIO, liftIO, )
import Control.Monad.Fix (MonadFix, )
import Control.Monad (forever, when, liftM2, guard, )
import Control.Applicative (Applicative, pure, liftA2, (<*>), )
import Data.Monoid (mempty, mappend, )
import Data.Bool.HT (if', )
import Data.Tuple.HT (mapPair, mapFst, )
import Data.Ord.HT (comparing, limit, )
import Data.Maybe.HT (toMaybe, )
import Data.Maybe (catMaybes, )

import qualified Data.Map as Map
import qualified Data.List as List
import qualified Data.List.Key as Key
import qualified Data.List.Match as Match

import Prelude hiding (sequence, )

-- * make ALSA reactive

newtype Reactor t a =
   Reactor {
      runReactor ::
            (RBF.AddHandler Event.T, Common.Handle)
            (MS.StateT Schedule (RBS.Moment t))
   } deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

liftNetworkDescription :: RBS.Moment t a -> Reactor t a
liftNetworkDescription act =
   Reactor $ MT.lift $ MT.lift act

We need this to identify received Echo events.
We could also use the Custom fields of the Echo event
and would get a much larger range of Schedules,
but unfortunately we cannot use the Custom values
for selectively removing events from the output queue.
This is needed in our variable speed beat generator.

In order to prevent shortage of Tags
we could reserve one tag for events that will never be canceled
and then use the Custom fields in order to further distinguish Echo messages.
type Schedule = Event.Tag
newtype Schedule = Schedule Word32
   deriving (Eq, Ord, Enum, Show)

startSchedule :: Schedule
startSchedule = Event.Tag 1

nextSchedule :: Schedule -> Schedule
nextSchedule (Event.Tag s) =
   if s == maxBound
     then error $ "maximum number of schedules " ++ show s ++ " reached"
     else Event.Tag $ succ s

getHandle :: Reactor t Common.Handle
getHandle = Reactor $ MR.asks snd

run ::
   (Common.Events ev) =>
   (forall t.
      (RBF.Frameworks t) =>
      RB.Event t Event.Data -> RB.Event t ev) ->
   ReaderT Common.Handle IO ()
run f =
   runM (\ _ts xs -> return $ f xs)

runM ::
   (Common.Events ev) =>
   (forall t.
    (RBF.Frameworks t) =>
    RB.Behavior t Time.Abs ->
    RB.Event t Event.Data -> Reactor t (RB.Event t ev)) ->
   ReaderT Common.Handle IO ()
runM f = do
   MR.ReaderT $ \h -> do
      (addEventHandler, runEventHandler) <- RBF.newAddHandler
      (addEchoHandler,  runEchoHandler)  <- RBF.newAddHandler
      (addTimeHandler,  runTimeHandler)  <- RBF.newAddHandler
      RBF.actuate =<< RBF.compile (do
         time <-
            fmap (RB.stepper 0) $
            RBF.fromAddHandler addTimeHandler
         evs <-
            flip MS.evalStateT startSchedule
              . flip MR.runReaderT (addEchoHandler, h)
              . runReactor
              . f time
              . fmap Event.body
            =<< RBF.fromAddHandler addEventHandler
         RBF.reactimate $
            pure (outputEvents h) <*> time <@> evs)
      forever $ do
         ev <- Event.input (Common.sequ h)
         runTimeHandler $ Time.fromEvent ev
         if Event.dest ev == Addr.Cons (Common.client h) (Common.portPrivate h)
           then debug "input: echo"  >> runEchoHandler ev
           else debug "input: event" >> runEventHandler ev

outputEvents ::
   Common.Events evs =>
   Common.Handle -> Time.Abs -> evs -> IO ()
outputEvents h time evs = do
   mapM_ (Event.output (Common.sequ h)) $
      map (\(Common.Future dt body) ->
             Common.makeEvent h (Time.inc dt time) body) $
      Common.flattenEvents evs
   _ <- Event.drainOutput (Common.sequ h)
   return ()

checkSchedule :: Schedule -> Event.T -> Bool
checkSchedule sched echo =
   maybe False (sched ==) $ do
      Event.CustomEv Event.Echo _ <- Just $ Event.body echo
      return $ Event.tag echo

reactimate ::
   (RBF.Frameworks t) =>
   RB.Event t (IO ()) -> Reactor t ()
reactimate evs =
   Reactor $ MT.lift $ MT.lift $ RBF.reactimate evs

sendEchos :: Common.Handle -> Schedule -> [Time.Abs] -> IO ()
sendEchos h sched echos = do
   flip mapM_ echos $ \time ->
      Event.output (Common.sequ h) $
      (Common.makeEcho h time)
      { Event.tag = sched }
   _ <- Event.drainOutput (Common.sequ h)
   debug "echos sent"

cancelEchos :: Common.Handle -> Schedule -> IO ()
cancelEchos h sched =
   Remove.run (Common.sequ h) $ do
      Remove.setEventType Event.Echo
      Remove.setTag sched

reserveSchedule ::
   (RBF.Frameworks t) =>
   Reactor t (RB.Event t Time.Abs, [Time.Abs] -> IO (), IO ())
reserveSchedule = Reactor $ ReaderT $ \(addH,h) -> do
   sched <- MS.get
   MS.modify nextSchedule
   eEcho <-
      MT.lift $
      fmap (fmap Time.fromEvent .
            RB.filterE (checkSchedule sched)) $
      RBF.fromAddHandler addH
   return (eEcho, sendEchos h sched, cancelEchos h sched)

scheduleQueue ::
   (RBF.Frameworks t, Show a) =>
   RB.Behavior t Time.Abs ->
   RB.Event t (Common.Bundle a) -> Reactor t (RB.Event t a)
scheduleQueue times e = do
   (eEcho, send, _) <- reserveSchedule
   let -- maintain queue and generate Echo events
       remove echoTime =
          MS.state $ uncurry $ \_lastTime ->
             (error "scheduleQueue: received more events than sent")
             (\(_t,x) xs ->
                ((Just x, debug $ "got echo for event: " ++ show x),
                 ({- Time.inc t lastTime -}
                  echoTime, xs)))
       add time new = do
          MS.modify $ \(lastTime, old) ->
                 (EventList.mapTime (Time.cons "scheduleQueue") $
                  EventList.fromAbsoluteEventList $
                  EventListAbs.fromPairList $
                  map (\(Common.Future dt a) -> (Time.decons dt, a)) $
                  List.sortBy (comparing Common.futureTime) new) $
                 (Time.cons "Causal.process.decreaseStart"
                     (time-lastTime)) old)
          return (Nothing, send $ map (flip Time.inc time . Common.futureTime) new)

       -- (Queue that keeps track of events to schedule
       -- , duration of the new alarm if applicable) 
       (eEchoEvent, _bQueue) =
          RBU.sequence (0, EventList.empty) $
          RB.union (fmap remove eEcho) (pure add <*> times <@> e)

   reactimate $ fmap snd eEchoEvent
   return $ RBU.mapMaybe fst eEchoEvent

debug :: String -> IO ()
debug =
   const $ return ()
   -- putStrLn

bypass ::
   (Common.Events a, Common.Events c) =>
   (a -> Maybe b) ->
   (RB.Event f b -> RB.Event f c) ->
   RB.Event f a -> RB.Event f [Common.Future Event.Data]
bypass p f =
   RBU.bypass p (fmap Common.flattenEvents) (fmap Common.flattenEvents . f)

-- * examples

{- |
register pressed keys
pressed ::
   (KeySet.C set) =>
   set ->
   RB.Event f Common.NoteBoundaryExt ->
   (RB.Event f [Common.NoteBoundary], RB.Behavior f set)
pressed empty =
   RBU.traverse empty
      (\e ->
         case e of
            Common.NoteBoundaryExt bnd -> KeySet.change bnd
            Common.AllNotesOff -> KeySet.reset)

latch ::
   RB.Event f Common.NoteBoundary ->
   (RB.Event f Common.NoteBoundary,
    RB.Behavior f (Map.Map (Pitch, Channel) Velocity))
latch =
   mapPair (RB.filterJust, fmap KeySet.deconsLatch) .
   RBU.traverse KeySet.latch KeySet.latchChange

{- |
Demonstration of scheduleQueue,
but for real use prefer 'delay',
since this uses precisely timed delivery by ALSA.
delaySchedule ::
   (RBF.Frameworks t) =>
   Time.T ->
   RB.Behavior t Time.Abs ->
   RB.Event t Event.Data -> Reactor t (RB.Event t Event.Data)
delaySchedule dt times =
   scheduleQueue times .
   fmap ((:[]) . Common.Future dt)

delay ::
   Time.T ->
   RB.Event t ev -> RB.Event t (Common.Future ev)
delay dt =
   fmap (Common.Future dt)

delayAdd ::
   Time.T ->
   RB.Event t ev -> RB.Event t (Common.Future ev)
delayAdd dt evs =
   RB.union (fmap Common.now evs) $ delay dt evs

{- |
Generate a beat according to the tempo control.
The input signal specifies the period between two beats.
The output events hold the times, where they occur.
beat ::
   (RBF.Frameworks t) =>
   RB.Behavior t Time.T -> Reactor t (RB.Event t Time.Abs)
beat tempo = do
   (eEcho, send, _) <- reserveSchedule

   liftIO $ send [0]

   let next dt time =
          (time, send [Time.inc dt time])

       eEchoEvent = fmap next tempo <@> eEcho

   reactimate $ fmap snd eEchoEvent
   return $ fmap fst eEchoEvent

{- |
Similar to 'beat' but warrants a maximum reaction time to tempo changes.
This way you can alter slow tempos to faster one more quickly.
Instead of this we could use the reciprocal of Time, that is frequency,
and integrate that.
But integration of a piecewise RBU.constant function means a linear function.
This cannot be represented in FRP.
The approach we use here samples the tempo signal
and thus may miss some tempo changes.
beatQuant ::
   (RBF.Frameworks t) =>
   Time.T ->
   RB.Behavior t Time.T -> Reactor t (RB.Event t Time.Abs)
beatQuant maxDur tempo = do
   (eEcho, send, _) <- reserveSchedule

   liftIO $ send [0]

   let next dt time = do
          complete <- MS.gets (>=1)
          when complete $ MS.modify (subtract 1)
          portion <- MS.get
          let dur = limit (mempty,maxDur) (Time.scaleCeiling (1-portion) dt)
          MS.modify (Time.div dur dt +)
             (toMaybe complete time,
              send [Time.inc dur time]
              {- print (dur, time, dt, portion) -} )

       eEchoEvent =
          fst $ RBU.sequence 0 $ fmap next tempo <@> eEcho

   reactimate $ fmap snd eEchoEvent
   return $ RBU.mapMaybe fst eEchoEvent

{- |
Similar to 'beat' but it reacts immediately to tempo changes.
This requires the ability of ALSA to cancel sent Echo messages
and it requires to know the precise time points of tempo changes,
thus we need the Discrete input instead of Behaviour
and we need a behaviour for the current time.
beatVar ::
   (RBF.Frameworks t) =>
   RB.Behavior t Time.Abs ->
   RB.Behavior t Time.T ->
   Reactor t (RB.Event t Time.Abs)
beatVar time tempo = do
   (eEcho, send, cancel) <- reserveSchedule

   liftIO $ send [0]

   (tempoInit, tempoChanges) <-
      Reactor $ MT.lift $ MT.lift $
      liftM2 (,) (RBF.initial tempo) (RBF.changes tempo)

   let change ::
          Time.T -> Time.Abs ->
             (Time.Abs, Double, Time.T)
             (Maybe Time.Abs, IO ())

       next _t = do
          (t0,r,p) <- MS.get
          It should be t1==t,
          where t is the timestamp from an Echo message
          and t1 is the computed time.
          In principle we could use t,
          but this will be slightly later than the reference time t1.
          let t1 = Time.inc (Time.scale r p) t0
          MS.put (t1,1,p)
          return (Just t1, send [Time.inc p t1])

       change p1 t1 = do
          (t0,r0,p0) <- MS.get
          let r1 = max 0 $ r0 - Time.div (Time.subSat t1 t0) p0
          MS.put (t1,r1,p1)
              cancel >>
              send [Time.inc (Time.scale r1 p1) t1])

       eEchoEvent =
          fst $ RBU.sequence (0, 0, tempoInit) $
             (fmap next eEcho)
             (fmap (flip change) time <@> tempoChanges)

   reactimate $ fmap snd eEchoEvent
   return $ RBU.mapMaybe fst eEchoEvent

tempoCtrl ::
   (Check.C ev) =>
   Channel ->
   Controller ->
   Time.T -> (Time.T, Time.T) ->
   RB.Event t ev -> (RB.Behavior t Time.T, RB.Event t ev)
tempoCtrl chan ctrl deflt (lower,upper) =
   mapFst (RB.stepper deflt) .
      (fmap (Common.ctrlDur (lower, upper))
          . Check.controller chan ctrl)

controllerRaw ::
   (Check.C ev) =>
   Channel ->
   Controller ->
   Int ->
   RB.Event t ev -> RB.Behavior t Int
controllerRaw chan ctrl deflt =
   RB.stepper deflt .
   RBU.mapMaybe (Check.controller chan ctrl)

controllerExponential ::
   (Floating a, Check.C ev) =>
   Channel ->
   Controller ->
   a -> (a,a) ->
   RB.Event t ev -> RB.Behavior t a
controllerExponential chan ctrl deflt (lower,upper) =
   let k = log (upper/lower) / 127
   in  RB.stepper deflt .
          (fmap ((lower*) . exp . (k*) . fromIntegral)
              . Check.controller chan ctrl)

controllerLinear ::
   (Fractional a, Check.C ev) =>
   Channel ->
   Controller ->
   a -> (a,a) ->
   RB.Event t ev -> RB.Behavior t a
controllerLinear chan ctrl deflt (lower,upper) =
   let k = (upper-lower) / 127
   in  RB.stepper deflt .
          (fmap ((lower+) . (k*) . fromIntegral)
              . Check.controller chan ctrl)

cyclePrograms ::
   [Program] ->
   RB.Event t Event.Data -> RB.Event t (Maybe Event.Data)
cyclePrograms pgms =
   fst .
   RBU.traverse (cycle pgms)
      (Common.traverseProgramsSeek (length pgms))

{- |
> cycleProgramsDefer t

After a note that triggers a program change,
we won't change the program in the next 't' seconds.
This is in order to allow chords being played
and in order to skip accidentally played notes.
In the future we might also add a time-out:
After a certain time, where no key is pressed,
the program would be reset to the initial program.
cycleProgramsDefer ::
   Time.T -> [Program] ->
   RB.Behavior t Time.Abs ->
   RB.Event t Event.Data -> RB.Event t (Maybe Event.Data)
cycleProgramsDefer defer pgms times =
   fst .
   RBU.traverse (cycle pgms, 0)
      (\(eventTime,e) ->
         case e of
            Event.CtrlEv Event.PgmChange ctrl ->
               AccState.lift AccTuple.first $
                  Common.seekProgram (length pgms) (ctrl ^. MALSA.ctrlProgram)
            Event.NoteEv notePart note -> do
               blockTime <- MS.gets snd
               if eventTime < blockTime
                 then return Nothing
                    case fst $ normalNoteFromEvent notePart note of
                       Event.NoteOn -> do
                          AccState.set AccTuple.second $
                             Time.inc defer eventTime
                          AccState.lift AccTuple.first $
                             Common.nextProgram note
                       _ -> return Nothing
            _ -> return Nothing) .
   RB.apply (fmap (,) times)

newtype PitchChannel =
   PitchChannel ((Pitch, Channel), Velocity)
   deriving (Show)

instance Eq PitchChannel where
   (PitchChannel ((p0,_), _)) == (PitchChannel ((p1,_), _)) =
      p0 == p1

instance Ord PitchChannel where
   compare (PitchChannel ((p0,_), _)) (PitchChannel ((p1,_), _)) =
      compare p0 p1

instance Guitar.Transpose PitchChannel where
   getPitch (PitchChannel ((p,_), _)) = p
   transpose d (PitchChannel ((p,c),v)) = do
      p' <- Common.increasePitch d p
      return $ PitchChannel ((p',c), v)

noteSequence ::
   Time.T ->
   Event.NoteEv -> [Event.Note] ->
noteSequence stepTime onOff =
   zipWith Common.Future (iterate (mappend stepTime) mempty) .
   map (Event.NoteEv onOff)

{- |
This process simulates playing chords on a guitar.
If you press some keys like C, E, G on the keyboard,
then this process figures out what tones would be played on a guitar.

Call it like @guitar stepTime chords triggers@.

@stepTime@ is the delay between to successive notes.
A good value is 0.03 (seconds).
The chords to be played are passed in by @chords@.
This should be the output of 'pressed'.
Further on the function needs events
that trigger playing the chord in @trigger@ argument.
The trigger consists of the trigger time
and the direction to be played
('True' = down from high to low pitches,
'False' = up from low to high pitches).
The trigger may be derived from a specific key that is pressed and released,
or two keys, one for each direction.
guitar ::
   (KeySet.C set) =>
   Time.T ->
   RB.Behavior t set ->
   RB.Event t Bool ->
   RB.Event t Common.EventDataBundle
guitar stepTime pressd trigger =
   fst $
   RBU.traverse []
      (\(set, on) -> do
         played <- MS.get
         let toPlay =
                case KeySet.toList set of
                   [] -> []
                   list ->
                      fmap (\(PitchChannel ((p,c),v)) ->
                         MALSA.noteEvent c p v v 0) $
                      Guitar.mapChordToString Guitar.stringPitches $
                      fmap PitchChannel list
         MS.put toPlay
         return $
            if on
                 noteSequence stepTime Event.NoteOff
                    (List.reverse played)
                 noteSequence stepTime Event.NoteOn toPlay
                 noteSequence stepTime Event.NoteOff played
                 noteSequence stepTime Event.NoteOn
                    (List.reverse toPlay)) $
   pure (,) <*> pressd <@> trigger

{- |
Audio perception trainer

Play sets of notes and
let the human player answer to them according to a given scheme.
Repeat playing the notes sets until the trainee answers correctly.
Then continue with other sequences, maybe more complicated ones.

possible tasks:

 - replay a RBU.sequence of pitches on the keyboard:
      single notes for training abolute pitches,
      intervals all with the same base notes,
      intervals with different base notes

 - transpose a set of pitches:
      tranpose to a certain base note,
      transpose by a certain interval

 - play a set of pitches in a different order:
      reversed order,
      in increasing pitch

 - replay a set of simultaneously pressed keys

The difficulty can be increased by not connecting
the keyboard directly with the sound generator.
This way, the trainee cannot verify,
how the pressed keys differ from the target keys.

Sometimes it seems that you are catched in an infinite loop.
This happens if there were too many keys pressed.
The trainer collects all key press events,
not only the ones that occur after the target set is played.
This way you can correct yourself immediately,
before the target is repeatedly played.
The downside is, that there may be key press events hanging around.
You can get rid of them by pressing a key again and again,
but slowly, until the target is played, again.
Then the queue of registered keys should be empty
and you can proceed training.
The Reactor monad is only needed for sending the initial notes.
trainer ::
   (RBF.Frameworks t) =>
   Channel ->
   Time.T -> Time.T ->
   [([Pitch], [Pitch])] ->
   RB.Behavior t Time.Abs ->
   RB.Event t Event.Data ->
   Reactor t (RB.Event t Common.EventDataBundle)
trainer chan pause duration sets0 times evs0 = do
   let makeSeq sets =
          case sets of
             (target, _) : _ ->
                (concat $
                    (\t p ->
                       Common.eventsFromKey t duration
                          ((p,chan), normalVelocity))
                    (iterate (mappend duration) pause) target,
                 mappend pause $ Time.scaleInt (length target) duration)
             [] -> ([], mempty)

   let (initial, initIgnoreUntil) = makeSeq sets0
   getHandle >>= \h -> liftIO (outputEvents h 0 initial)

   return $ fst $
      flip (RBU.traverse (sets0, [], Time.inc initIgnoreUntil 0))
         (fmap (,) times <@> evs0) $ \(time,ev) ->
      case ev of
         Event.NoteEv notePart note ->
            case fst $ normalNoteFromEvent notePart note of
               Event.NoteOn -> do
                  ignoreUntil <- AccState.get AccTuple.third3
                  if time <= ignoreUntil
                    then return []
                    else do
                       pressd <- AccState.get AccTuple.second3
                       let newPressd = (note ^. MALSA.notePitch) : pressd
                       AccState.set AccTuple.second3 newPressd
                       sets <- AccState.get AccTuple.first3
                       case sets of
                          (_, target) : rest ->
                             if Match.lessOrEqualLength target newPressd
                               then do
                                  AccState.set AccTuple.second3 []
                                  when (newPressd == List.reverse target) $
                                     AccState.set AccTuple.first3 rest
                                  (notes, newIgnoreUntil) <-
                                     fmap makeSeq $
                                     AccState.get AccTuple.first3
                                  AccState.set AccTuple.third3 $
                                     Time.inc newIgnoreUntil time
                                  return notes
                               else return []
                          _ -> return []
               _ -> return []
         _ -> return []

sweep ::
   (RBF.Frameworks t) =>
   Time.T ->
   (Double -> Double) ->
   RB.Behavior t Double ->
   Reactor t (RB.Event t Time.Abs, RB.Behavior t Double)
sweep dur wave speed = do
   bt <- beat $ pure dur
   let durD = realToFrac $ Time.decons dur
       fmap wave $ RB.accumB 0 $
       fmap (\d _ phase -> Common.fraction (phase + durD * d)) speed <@> bt)

makeControllerLinear ::
   Channel -> Controller ->
   RB.Behavior t Int ->
   RB.Behavior t Int ->
   RB.Event t Time.Abs -> RB.Behavior t Double ->
   RB.Event t Event.Data
makeControllerLinear chan cc depthCtrl centerCtrl bt ctrl =
      (\y depth center _time ->
         Event.CtrlEv Event.Controller $
         MALSA.controllerEvent chan cc $
         round $ limit (0,127) $
         fromIntegral center + fromIntegral depth * y)
      <*> ctrl
      <*> depthCtrl
      <*> centerCtrl
      <@> bt

{- |
Use a MIDI controller for selecting a note from a key set.
Only the pitch class of the keys is respected.
The controller behavior must be in the range 0-127.
This way, it accesses the whole range of MIDI notes.
The output note is stopped and a new note is played
whenever turning the knob alters the note pitch.
The advantage of the effect is that the pitch range of the knob
does not depend on the number of pressed keys.
The disadvantage is that there a distinct distances between the pitches.
snapSelect ::
   (RBF.Frameworks t, KeySet.C set) =>
   RB.Behavior t set ->
   RB.Behavior t Int ->
   Reactor t (RB.Event t [Event.Data])
--   RBS.Moment t (RB.Event t [Event.Data])
snapSelect set ctrl =
   liftNetworkDescription $
   fmap (fst . RB.mapAccum Nothing .
         fmap (\newNote oldNote ->
                  (guard (newNote/=oldNote) >>
                   catMaybes [fmap (Event.NoteEv Event.NoteOff .
                                    uncurry (uncurry Common.simpleNote)) oldNote,
                              fmap (Event.NoteEv Event.NoteOn .
                                    uncurry (uncurry Common.simpleNote)) newNote],
                   newNote))) $
   RBF.changes $
      (\s x ->
         toMaybe (not $ null s) $
         Key.minimum (\((_c,p), _v) -> abs (fromPitch p - x)) $
         map (\((p,c), v) -> ((c, transposeToClosestOctave x p), v)) s)
      (fmap KeySet.toList set) ctrl

transposeToClosestOctave :: Int -> Pitch -> Pitch
transposeToClosestOctave target sourceClass =
   let t = target
       s = fromPitch sourceClass
       x = mod (s - t + 6) 12 + t - 6
   in  toPitch $
       if' (x<0) (x+12) $
       if' (x>127) (x-12) x

uniqueChanges ::
   (RBF.Frameworks t, Eq a) =>
   RB.Behavior t a -> Reactor t (RB.Event t a)
uniqueChanges x = liftNetworkDescription $ do
   x0 <- RBF.initial x
   xs <- RBF.changes x
   return $ RB.filterJust $ fst $
      RB.mapAccum x0 $ fmap (\new old -> (toMaybe (new/=old) new, new)) xs