packages feed

reactive-midyim 0.2.1 → 0.3

raw patch · 7 files changed

+260/−264 lines, 7 filesdep ~reactive-banana

Dependency ranges changed: reactive-banana

Files

reactive-midyim.cabal view
@@ -1,5 +1,5 @@ Name:             reactive-midyim-Version:          0.2.1+Version:          0.3 License:          BSD3 License-File:     LICENSE Author:           Henning Thielemann <haskell@henning-thielemann.de>@@ -45,11 +45,11 @@ Source-Repository this   type:     darcs   location: http://hub.darcs.net/thielema/reactive-midyim/-  tag:      0.2.1+  tag:      0.3  Library   Build-Depends:-    reactive-banana >=0.8 && <0.9,+    reactive-banana >=1.1 && <1.2,     midi >=0.2 && <0.3,     event-list >=0.1 && < 0.2,     non-negative >=0.1 && <0.2,@@ -74,7 +74,6 @@     Reactive.Banana.MIDI.Pitch     Reactive.Banana.MIDI.Note     Reactive.Banana.MIDI.Time-    Reactive.Banana.MIDI.IndexedMonad     Reactive.Banana.MIDI.Program     Reactive.Banana.MIDI.Controller   Other-Modules:
− src/Reactive/Banana/MIDI/IndexedMonad.hs 
@@ -1,26 +0,0 @@-{--This module could as well live in a separate package.--}-module Reactive.Banana.MIDI.IndexedMonad where--import Control.Applicative (Applicative, pure, (<*>), )-import Control.Monad (liftM, ap, )---class C m where-   point :: a -> m s a-   bind :: m s a -> (a -> m s b) -> m s b---newtype Wrap m s a = Wrap {unwrap :: m s a}--instance C m => Functor (Wrap m s) where-   fmap = liftM--instance C m => Applicative (Wrap m s) where-   pure = return-   (<*>) = ap--instance C m => Monad (Wrap m s) where-   return = Wrap . point-   Wrap x >>= k  =  Wrap $ bind x (unwrap . k)
src/Reactive/Banana/MIDI/Pattern.hs view
@@ -30,7 +30,7 @@ import qualified Data.Traversable as Trav import qualified Data.Foldable as Fold -import Control.Monad (guard, )+import Control.Monad (guard, liftM, ) import Control.Applicative (pure, (<*>), ) import Data.Maybe (mapMaybe, maybeToList, ) import Data.Bool.HT (if', )@@ -42,19 +42,19 @@  -- * reactive patterns -type T t time set key value =-   RB.Behavior t (set key value) ->-   RB.Event t time ->-   RB.Event t [Note.Boundary key value]+type T m time set key value =+   RB.Behavior (set key value) ->+   RB.Event time ->+   m (RB.Event [Note.Boundary key value])  mono ::-   (KeySet.C set) =>+   (RB.MonadMoment m) =>    Selector set key Velocity i ->-   RB.Behavior t (set key Velocity) ->-   RB.Event t i ->-   RB.Event t [Note.Boundary key Velocity]+   RB.Behavior (set key Velocity) ->+   RB.Event i ->+   m (RB.Event [Note.Boundary key Velocity]) mono select pressed pattern =-   fst $ RBU.sequence [] $+   liftM fst $ RBU.sequence [] $    pure       (\set i -> do          off <- MS.get@@ -72,13 +72,13 @@   poly ::-   (KeySet.C set) =>+   (RB.MonadMoment m) =>    Selector set key Velocity i ->-   RB.Behavior t (set key Velocity) ->-   RB.Event t [IndexNote i] ->-   RB.Event t [Note.Boundary key Velocity]+   RB.Behavior (set key Velocity) ->+   RB.Event [IndexNote i] ->+   m (RB.Event [Note.Boundary key Velocity]) poly select pressed pattern =-   fst $ RBU.sequence EventList.empty $+   liftM fst $ RBU.sequence EventList.empty $    pure       (\set is -> do          off <- MS.get@@ -197,11 +197,12 @@   cycleUpIndex, cycleDownIndex, pingPongIndex ::-   RB.Behavior t Int ->-   RB.Event t time ->-   RB.Event t Int+   (RB.MonadMoment m) =>+   RB.Behavior Int ->+   RB.Event time ->+   m (RB.Event Int) cycleUpIndex numbers times =-   fst $ RB.mapAccum 0 $+   liftM fst $ RB.mapAccum 0 $    pure       (\number _time i -> (i, mod (succ i) (max 1 number)))       <*> numbers@@ -215,7 +216,7 @@       <@> times  pingPongIndex numbers times =-   fst $ RB.mapAccum (0,1) $+   liftM fst $ RB.mapAccum (0,1) $    pure       (\number _time (i,d0) ->          (i, let j = i+d0@@ -227,10 +228,12 @@       <@> times  crossSumIndex ::-   RB.Behavior t Int ->-   RB.Event t time ->-   RB.Event t Int+   (RB.MonadMoment m) =>+   RB.Behavior Int ->+   RB.Event time ->+   m (RB.Event Int) crossSumIndex numbers times =+   flip liftM (fromList [0..] times) $ \ts ->    pure       (\number i ->          let m = fromIntegral number@@ -238,19 +241,22 @@                then 0                else fromInteger $ flip mod m $ sum $ decomposePositional m i)       <*> numbers-      <@> fromList [0..] times+      <@> ts   crossSumStaticIndex ::+   (RB.MonadMoment m) =>    Int ->-   RB.Event t time ->-   RB.Event t Int+   RB.Event time ->+   m (RB.Event Int) crossSumStaticIndex number =    fromList (flipSeq number) -fromList :: [a] -> RB.Event t time -> RB.Event t a+fromList ::+   (RB.MonadMoment m) =>+   [a] -> RB.Event time -> m (RB.Event a) fromList xs times =-   RB.filterJust $ fst $ RB.mapAccum xs $+   liftM (RB.filterJust . fst) $ RB.mapAccum xs $    fmap       (\_time xs0 ->          case xs0 of@@ -260,27 +266,27 @@   cycleUp, cycleDown, pingPong, crossSum ::-   (KeySet.C set, Ord key) =>-   RB.Behavior t Int -> T t time set key Velocity+   (RB.MonadMoment m, KeySet.C set, Ord key) =>+   RB.Behavior Int -> T m time set key Velocity cycleUp   numbers sets times =-   mono selectFromChord sets (cycleUpIndex numbers times)+   mono selectFromChord sets =<< cycleUpIndex numbers times cycleDown numbers sets times =-   mono selectFromChord sets (cycleDownIndex numbers times)+   mono selectFromChord sets =<< cycleDownIndex numbers times pingPong  numbers sets times =-   mono selectFromChord sets (pingPongIndex numbers times)+   mono selectFromChord sets =<< pingPongIndex numbers times crossSum  numbers sets times =-   mono selectFromChord sets (crossSumIndex numbers times)+   mono selectFromChord sets =<< crossSumIndex numbers times  bruijn ::-   (KeySet.C set, Ord key) =>-   Int -> Int -> T t time set key Velocity+   (RB.MonadMoment m, KeySet.C set, Ord key) =>+   Int -> Int -> T m time set key Velocity bruijn n k sets times =-   mono selectFromChord sets $+   mono selectFromChord sets =<<    fromList (cycle $ DeBruijn.lexLeast n k) times   binaryStaccato, binaryLegato, binaryAccident ::-   (KeySet.C set, Ord key) => T t time set key Velocity+   (RB.MonadMoment m, KeySet.C set, Ord key) => T m time set key Velocity {- binary number Pattern.T:    0@@ -293,9 +299,7 @@    3 -} binaryStaccato sets times =-   poly-      selectFromChord-      sets+   poly selectFromChord sets =<<       (flip fromList times $        map           (map (IndexNote 1 . fst) .@@ -305,9 +309,7 @@           [0..])  binaryLegato sets times =-   poly-      selectFromChord-      sets+   poly selectFromChord sets =<<       (flip fromList times $        map           (\m ->@@ -322,9 +324,7 @@ It was not what I wanted, but it sounded nice. -} binaryAccident sets times =-   poly-      selectFromChord-      sets+   poly selectFromChord sets =<<       (flip fromList times $        map           (zipWith IndexNote (iterate (2*) 1) .@@ -345,23 +345,23 @@    in  recourse  cycleUpOctave ::-   (KeySet.C set, Ord pitch, Pitch.C pitch) =>-   RB.Behavior t Int -> T t time set pitch Velocity+   (RB.MonadMoment m, KeySet.C set, Ord pitch, Pitch.C pitch) =>+   RB.Behavior Int -> T m time set pitch Velocity cycleUpOctave numbers sets times =-   mono selectFromOctaveChord sets (cycleUpIndex numbers times)+   mono selectFromOctaveChord sets =<< cycleUpIndex numbers times   random ::-   (KeySet.C set, Ord key) =>-   T t time set key Velocity+   (RB.MonadMoment m, KeySet.C set, Ord key) =>+   T m time set key Velocity random sets times =-   mono selectFromChordRatio sets $-   fst $ RB.mapAccum (Rnd.mkStdGen 42) $+   (mono selectFromChordRatio sets =<<) $+   liftM fst $ RB.mapAccum (Rnd.mkStdGen 42) $    fmap (const $ Rnd.randomR (0,1)) times  randomInversions ::-   (KeySet.C set, Pitch.C pitch) =>-   T t time set pitch Velocity+   (RB.MonadMoment m, KeySet.C set, Pitch.C pitch) =>+   T m time set pitch Velocity randomInversions =    inversions $    map sum $@@ -370,17 +370,17 @@    Rnd.mkStdGen 42  cycleUpInversions ::-   (KeySet.C set, Pitch.C pitch) =>-   Int -> T t time set pitch Velocity+   (RB.MonadMoment m, KeySet.C set, Pitch.C pitch) =>+   Int -> T m time set pitch Velocity cycleUpInversions n =    inversions $ cycle $ take n $    map (\i -> fromInteger i / fromIntegral n) [0..]  inversions ::-   (KeySet.C set, Pitch.C pitch) =>-   [Double] -> T t time set pitch Velocity+   (RB.MonadMoment m, KeySet.C set, Pitch.C pitch) =>+   [Double] -> T m time set pitch Velocity inversions rs sets times =-   mono selectInversion sets (fromList rs times)+   mono selectInversion sets =<< fromList rs times
src/Reactive/Banana/MIDI/Process.hs view
@@ -2,10 +2,11 @@    RelativeTicks,    AbsoluteTicks,    RelativeSeconds,-   Moment(liftMoment),+   MomentIO(liftMomentIO),    Reactor(reserveSchedule),    scheduleQueue,    initialEvent,+   unionM,    beat,    beatQuant,    beatVar,@@ -37,7 +38,6 @@ import qualified Reactive.Banana.MIDI.KeySet as KeySet import qualified Reactive.Banana.MIDI.Pitch as Pitch import qualified Reactive.Banana.MIDI.Utility as RBU-import qualified Reactive.Banana.MIDI.IndexedMonad as IxMonad import qualified Reactive.Banana.MIDI.Common as Common import Reactive.Banana.MIDI.Common           (PitchChannel(PitchChannel),@@ -46,7 +46,6 @@  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.MIDI.Message.Class.Construct as Construct@@ -65,10 +64,10 @@ import qualified Control.Monad.Trans.State as MS  import qualified Data.Traversable as Trav-import Control.Monad (join, mplus, when, )+import Control.Monad (join, mplus, when, liftM, ) import Control.Applicative (pure, liftA2, (<*>), (<$>), ) import Data.Monoid (mempty, mappend, )-import Data.Tuple.HT (mapPair, mapFst, mapSnd, )+import Data.Tuple.HT (mapPair, mapSnd, ) import Data.Ord.HT (comparing, limit, ) import Data.Maybe.HT (toMaybe, ) import Data.Maybe (catMaybes, )@@ -85,48 +84,44 @@ type AbsoluteTicks   m = Time.T m Time.Absolute Time.Ticks type RelativeSeconds m = Time.T m Time.Relative Time.Seconds -class Moment moment where-   liftMoment :: RBS.Moment t a -> moment t a+class MomentIO moment where+   liftMomentIO :: RBF.MomentIO a -> moment a -instance Moment RBS.Moment where-   liftMoment = id+instance MomentIO RBF.MomentIO where+   liftMomentIO = id  -class (Moment reactor, Time.Timed reactor) => Reactor reactor where+class (MomentIO reactor, Time.Timed reactor) => Reactor reactor where    {- |    Provide a function for registering future beats-   and the return the reactive event list-   that results from the sent beats.+   and return the reactive event list that results from the sent beats.    -}    reserveSchedule ::-      (RBF.Frameworks t) =>-      reactor t+      reactor          ([AbsoluteTicks reactor] -> IO (), IO (),-          RB.Event t (AbsoluteTicks reactor))+          RB.Event (AbsoluteTicks reactor))  reactimate ::-   (Moment reactor, RBF.Frameworks t) =>-   RB.Event t (IO ()) -> IxMonad.Wrap reactor t ()-reactimate = IxMonad.Wrap . liftMoment . RBF.reactimate+   (MomentIO reactor) =>+   RB.Event (IO ()) -> reactor ()+reactimate = liftMomentIO . RBF.reactimate  reactimate' ::-   (Moment reactor, RBF.Frameworks t) =>-   RB.Event t (RBF.Future (IO ())) -> IxMonad.Wrap reactor t ()-reactimate' = IxMonad.Wrap . liftMoment . RBF.reactimate'+   (MomentIO reactor) =>+   RB.Event (RBF.Future (IO ())) -> reactor ()+reactimate' = liftMomentIO . RBF.reactimate' -liftIO ::-   (Moment m, RBF.Frameworks t) =>-   IO a -> IxMonad.Wrap m t a-liftIO = IxMonad.Wrap . liftMoment . RBF.liftIO+liftIO :: (MomentIO m) => IO a -> m a+liftIO = liftMomentIO . RBF.liftIO    scheduleQueue ::-   (Reactor reactor, RBF.Frameworks t) =>-   RB.Behavior t (AbsoluteTicks reactor) ->-   RB.Event t (Common.Bundle reactor a) -> reactor t (RB.Event t a)-scheduleQueue times e = IxMonad.unwrap $ do-   (send, _cancel, eEcho) <- IxMonad.Wrap reserveSchedule+   (Reactor reactor) =>+   RB.Behavior (AbsoluteTicks reactor) ->+   RB.Event (Common.Bundle reactor a) -> reactor (RB.Event a)+scheduleQueue times e = do+   (send, _cancel, eEcho) <- reserveSchedule    let -- maintain queue and generate Echo events        remove echoTime =           MS.state $ uncurry $ \_lastTime ->@@ -148,11 +143,12 @@                  (Time.subSat 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) =+   -- (Queue that keeps track of events to schedule+   -- , duration of the new alarm if applicable)+   (eEchoEvent, _bQueue) <-           RBU.sequence (mempty, EventList.empty) $-          RB.union (fmap remove eEcho) (pure add <*> times <@> e)+          RBU.union "scheduleQueue"+             (fmap remove eEcho) (pure add <*> times <@> e)     reactimate $ fmap snd eEchoEvent    return $ RBU.mapMaybe fst eEchoEvent@@ -163,26 +159,32 @@ Generate an event at the first time point. -} initialEvent ::-   (Reactor reactor, RBF.Frameworks t) =>-   a -> reactor t (RB.Event t a)-initialEvent x = IxMonad.unwrap $ do-   (send, _cancel, eEcho) <- IxMonad.Wrap reserveSchedule+   (Reactor reactor) =>+   a -> reactor (RB.Event a)+initialEvent x = do+   (send, _cancel, eEcho) <- reserveSchedule    liftIO $ send [mempty]    return $ fmap (const x) eEcho  +{- |+The second event stream is delayed by an infinitesimal amount.+-}+unionM :: (MomentIO m) => RB.Event a -> RB.Event a -> m (RB.Event a)+unionM xs = liftMomentIO . RBU.unionM xs + {- | 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 ::-   (Reactor reactor, RBF.Frameworks t) =>-   RB.Behavior t (RelativeTicks reactor) ->-   reactor t (RB.Event t (AbsoluteTicks reactor))-beat tempo = IxMonad.unwrap $ do-   (send, _cancel, eEcho) <- IxMonad.Wrap reserveSchedule+   (Reactor reactor) =>+   RB.Behavior (RelativeTicks reactor) ->+   reactor (RB.Event (AbsoluteTicks reactor))+beat tempo = do+   (send, _cancel, eEcho) <- reserveSchedule     liftIO $ send [mempty] @@ -206,12 +208,12 @@ and thus may miss some tempo changes. -} beatQuant ::-   (Reactor reactor, RBF.Frameworks t) =>+   (Reactor reactor) =>    RelativeTicks reactor ->-   RB.Behavior t (RelativeTicks reactor) ->-   reactor t (RB.Event t (AbsoluteTicks reactor))-beatQuant maxDur tempo = IxMonad.unwrap $ do-   (send, _cancel, eEcho) <- IxMonad.Wrap reserveSchedule+   RB.Behavior (RelativeTicks reactor) ->+   reactor (RB.Event (AbsoluteTicks reactor))+beatQuant maxDur tempo = do+   (send, _cancel, eEcho) <- reserveSchedule     liftIO $ send [mempty] @@ -226,8 +228,7 @@               send [Time.inc dur time]               {- print (dur, time, dt, portion) -} ) -       eEchoEvent =-          fst $ RBU.sequence 0 $ fmap next tempo <@> eEcho+   eEchoEvent <- liftM fst $ RBU.sequence 0 $ fmap next tempo <@> eEcho     reactimate $ fmap snd eEchoEvent    return $ RBU.mapMaybe fst eEchoEvent@@ -276,19 +277,19 @@ and alter the tempo of the queue timer. -} beatVar ::-   (Reactor reactor, RBF.Frameworks t) =>-   RB.Behavior t (AbsoluteTicks reactor) ->-   RB.Behavior t (RelativeTicks reactor) ->-   reactor t (RB.Event t (AbsoluteTicks reactor))-beatVar time tempo = IxMonad.unwrap $ do-   (send, cancel, eEcho) <- IxMonad.Wrap reserveSchedule+   (Reactor reactor) =>+   RB.Behavior (AbsoluteTicks reactor) ->+   RB.Behavior (RelativeTicks reactor) ->+   reactor (RB.Event (AbsoluteTicks reactor))+beatVar time tempo = do+   (send, cancel, eEcho) <- reserveSchedule    let sendSingle = send . (:[])     liftIO $ sendSingle mempty     (tempoInit, tempoChanges) <--      IxMonad.Wrap $ liftMoment $-      liftA2 (,) (RBF.initial tempo) (plainChanges tempo)+      liftMomentIO $+      liftA2 (,) (RB.valueBLater tempo) (plainChanges tempo)     let next t = mapSnd (return . sendSingle) <$> beatVarNext t @@ -296,11 +297,11 @@           ta <- beatVarChange p1 t1           return (Nothing, return $ cancel >> sendSingle ta) -       eEchoEvent =-          fst $ RBU.sequence (mempty, 0, tempoInit) $-          RB.union-             (fmap next eEcho)-             (fmap (flip change) time <@> tempoChanges)+   eEchoEvent <-+      liftM fst $ RBU.sequence (mempty, 0, tempoInit) $+      RBU.union "beatVar"+         (fmap next eEcho)+         (fmap (flip change) time <@> tempoChanges)     reactimate' $ fmap snd eEchoEvent    return $ RBU.mapMaybe fst eEchoEvent@@ -312,65 +313,64 @@ since this uses precisely timed delivery by ALSA. -} delaySchedule ::-   (Reactor reactor, RBF.Frameworks t) =>+   (Reactor reactor) =>    RelativeTicks reactor ->-   RB.Behavior t (AbsoluteTicks reactor) ->-   RB.Event t a -> reactor t (RB.Event t a)+   RB.Behavior (AbsoluteTicks reactor) ->+   RB.Event a -> reactor (RB.Event a) delaySchedule dt times =-   scheduleQueue times .-   fmap ((:[]) . Common.Future dt)+   scheduleQueue times . fmap ((:[]) . Common.Future dt)   delay ::    RelativeTicks m ->-   RB.Event t ev -> RB.Event t (Common.Future m ev)+   RB.Event ev -> RB.Event (Common.Future m ev) delay dt =    fmap (Common.Future dt)  delayAdd ::+   (MomentIO m) =>    RelativeTicks m ->-   RB.Event t ev -> RB.Event t (Common.Future m ev)+   RB.Event ev -> m (RB.Event (Common.Future m ev)) delayAdd dt evs =-   RB.union (fmap Common.now evs) $ delay dt evs+   unionM (fmap Common.now evs) $ delay dt evs   {- | register pressed keys -} pressed ::-   (KeySet.C set, Ord key) =>+   (RB.MonadMoment m, KeySet.C set, Ord key) =>    set key value ->-   RB.Event f (Note.BoundaryExt key value) ->-   (RB.Event f [Note.Boundary key value], RB.Behavior f (set key value))+   RB.Event (Note.BoundaryExt key value) ->+   m (RB.Event [Note.Boundary key value], RB.Behavior (set key value)) pressed empty =    RBU.traverse empty KeySet.changeExt  latch ::-   (Ord key) =>-   RB.Event f (Note.Boundary key value) ->-   (RB.Event f (Note.Boundary key value),-    RB.Behavior f (Map.Map key value))+   (RB.MonadMoment m, Ord key) =>+   RB.Event (Note.Boundary key value) ->+   m (RB.Event (Note.Boundary key value),+      RB.Behavior (Map.Map key value)) latch =-   mapPair (RB.filterJust, fmap KeySet.deconsLatch) .+   liftM (mapPair (RB.filterJust, fmap KeySet.deconsLatch)) .    RBU.traverse KeySet.latch KeySet.latchChange   controllerRaw ::-   (Check.C ev) =>+   (RB.MonadMoment m, Check.C ev) =>    Channel ->    Controller ->    Int ->-   RB.Event t ev -> RB.Behavior t Int+   RB.Event ev -> m (RB.Behavior Int) controllerRaw chan ctrl deflt =-   RB.stepper deflt .-   RBU.mapMaybe (Check.controller chan ctrl)+   RB.stepper deflt . RBU.mapMaybe (Check.controller chan ctrl)  controllerExponential ::-   (Floating a, Check.C ev) =>+   (RB.MonadMoment m, Floating a, Check.C ev) =>    Channel ->    Controller ->    a -> (a,a) ->-   RB.Event t ev -> RB.Behavior t a+   RB.Event ev -> m (RB.Behavior a) controllerExponential chan ctrl deflt (lower,upper) =    let k = log (upper/lower) / 127    in  RB.stepper deflt .@@ -379,11 +379,11 @@               . Check.controller chan ctrl)  controllerLinear ::-   (Fractional a, Check.C ev) =>+   (RB.MonadMoment m, Fractional a, Check.C ev) =>    Channel ->    Controller ->    a -> (a,a) ->-   RB.Event t ev -> RB.Behavior t a+   RB.Event ev -> m (RB.Behavior a) controllerLinear chan ctrl deflt (lower,upper) =    let k = (upper-lower) / 127    in  RB.stepper deflt .@@ -392,16 +392,20 @@               . Check.controller chan ctrl)  +-- | FuncHT.mapFst+mapFstM :: Monad m => (a -> m c) -> (a, b) -> m (c, b)+mapFstM f ~(a,b) = liftM (flip (,) b) $ f a+ tempoCtrl ::-   (Check.C ev) =>+   (RB.MonadMoment m, Check.C ev) =>    Channel ->    Controller ->    RelativeTicks m ->    (RelativeTicks m, RelativeTicks m) ->-   RB.Event t ev ->-   (RB.Behavior t (RelativeTicks m), RB.Event t ev)+   RB.Event ev ->+   m (RB.Behavior (RelativeTicks m), RB.Event ev) tempoCtrl chan ctrl deflt (lower,upper) =-   mapFst (RB.stepper deflt) .+   mapFstM (RB.stepper deflt) .    RBU.partitionMaybe       (fmap (Ctrl.duration (lower, upper))           . Check.controller chan ctrl)@@ -419,19 +423,17 @@ The disadvantage is that there are distinct distances between the pitches. -} snapSelect ::-   (Moment moment, RBF.Frameworks t, KeySet.C set,-    Pitch.C pitch, Eq pitch, Eq value) =>-   RB.Behavior t (set pitch value) ->-   RB.Behavior t Int ->-   moment t (RB.Event t [Note.Boundary pitch value])+   (MomentIO moment, KeySet.C set, Pitch.C pitch, Eq pitch, Eq value) =>+   RB.Behavior (set pitch value) ->+   RB.Behavior Int ->+   moment (RB.Event [Note.Boundary pitch value]) snapSelect set ctrl =-   liftMoment $-   fmap-      (flip RBU.mapAdjacent Nothing+   liftMomentIO $+   (flip RBU.mapAdjacent Nothing          (\oldNote newNote ->             let note on (pc, v) = Note.Boundary pc v on             in  catMaybes [fmap (note False) oldNote,-                           fmap (note True) newNote])) $+                           fmap (note True) newNote]) =<<) $    uniqueChanges $    liftA2       (\s x ->@@ -442,12 +444,11 @@   uniqueChanges ::-   (Moment moment, RBF.Frameworks t, Eq a) =>-   RB.Behavior t a -> moment t (RB.Event t a)-uniqueChanges x = liftMoment $ do-   x0 <- RBF.initial x+   (MomentIO moment, Eq a) => RB.Behavior a -> moment (RB.Event a)+uniqueChanges x = liftMomentIO $ do+   x0 <- RB.valueBLater x    xs <- plainChanges x-   return $ RB.filterJust $+   fmap RB.filterJust $       flip RBU.mapAdjacent x0 (\old new -> toMaybe (new/=old) new) xs  @@ -456,13 +457,11 @@ Can we also use it for JACK? If not, we can create something of type -  RB.Behavior t a -> RBS.Moment t (RB.Event t ())+  RB.Behavior a -> RB.Moment (RB.Event ())  and attach the Behavior values using (<@). -}-plainChanges ::-   (RBF.Frameworks t) =>-   RB.Behavior t a -> RBS.Moment t (RB.Event t a)+plainChanges :: RB.Behavior a -> RBF.MomentIO (RB.Event a) plainChanges x = do    (evs, handle) <- RBF.newEvent    xs <- RBF.changes x@@ -471,30 +470,28 @@   sweep ::-   (RBF.Frameworks t, Reactor reactor) =>+   (Reactor reactor) =>    RelativeSeconds reactor ->    (Double -> Double) ->-   RB.Behavior t Double ->-   reactor t-      (RB.Event t (AbsoluteTicks reactor),-       RB.Behavior t Double)-sweep durSecs wave speed = IxMonad.unwrap $ do-   bt <--      IxMonad.Wrap . beat . pure =<<-         IxMonad.Wrap (Time.ticksFromSeconds durSecs)+   RB.Behavior Double ->+   reactor+      (RB.Event (AbsoluteTicks reactor),+       RB.Behavior Double)+sweep durSecs wave speed = do+   bt <- beat . pure =<< Time.ticksFromSeconds durSecs    let dur = realToFrac $ Time.unSeconds $ Time.decons durSecs-   return-      (bt,-       fmap wave $ RB.accumB 0 $-       fmap (\d _ phase -> fraction (phase + dur * d)) speed <@> bt)+   phases <-+      RB.accumB 0 $+      fmap (\d _ phase -> fraction (phase + dur * d)) speed <@> bt+   return (bt, fmap wave phases)  makeControllerLinear ::    (Construct.C msg) =>    Channel -> Controller ->-   RB.Behavior t Int ->-   RB.Behavior t Int ->-   RB.Event t time -> RB.Behavior t Double ->-   RB.Event t msg+   RB.Behavior Int ->+   RB.Behavior Int ->+   RB.Event time -> RB.Behavior Double ->+   RB.Event msg makeControllerLinear chan cc depthCtrl centerCtrl bt ctrl =    pure       (\y depth center _time ->@@ -509,13 +506,11 @@   cyclePrograms ::-   (Construct.C msg, Query.C msg) =>+   (RB.MonadMoment m, Construct.C msg, Query.C msg) =>    [Program] ->-   RB.Event t msg -> RB.Event t (Maybe msg)+   RB.Event msg -> m (RB.Event (Maybe msg)) cyclePrograms pgms =-   fst .-   RBU.traverse (cycle pgms)-      (Program.traverseSeek (length pgms))+   liftM fst . RBU.traverse (cycle pgms) (Program.traverseSeek (length pgms))   {- |@@ -532,12 +527,12 @@ the program would be reset to the initial program. -} cycleProgramsDefer ::-   (Construct.C msg, Query.C msg) =>+   (RB.MonadMoment m, Construct.C msg, Query.C msg) =>    RelativeTicks m -> [Program] ->-   RB.Behavior t (AbsoluteTicks m) ->-   RB.Event t msg -> RB.Event t (Maybe msg)+   RB.Behavior (AbsoluteTicks m) ->+   RB.Event msg -> m (RB.Event (Maybe msg)) cycleProgramsDefer defer pgms times =-   fst .+   liftM fst .    RBU.traverse (cycle pgms, mempty)       (\(eventTime,e) ->          fmap join $ Trav.sequence $@@ -558,13 +553,11 @@   noteSequence ::-   (Construct.C msg) =>    RelativeTicks m ->    Bool -> [Bool -> msg] ->    Common.Bundle m msg noteSequence stepTime on =-   zipWith Common.Future (iterate (mappend stepTime) mempty) .-   map ($on)+   zipWith Common.Future (iterate (mappend stepTime) mempty) . map ($on)  {- | This process simulates playing chords on a guitar.@@ -587,13 +580,13 @@ or two keys, one for each direction. -} guitar ::-   (Construct.C msg, KeySet.C set) =>+   (RB.MonadMoment m, Construct.C msg, KeySet.C set) =>    RelativeTicks m ->-   RB.Behavior t (set PitchChannel Velocity) ->-   RB.Event t Bool ->-   RB.Event t (Common.Bundle m msg)+   RB.Behavior (set PitchChannel Velocity) ->+   RB.Event Bool ->+   m (RB.Event (Common.Bundle m msg)) guitar stepTime pressd trigger =-   fst $+   liftM fst $    RBU.traverse []       (\(set, on) -> do          played <- MS.get@@ -667,18 +660,18 @@ The Reactor monad is only needed for sending the initial notes. -} trainer ::-   (Reactor reactor, RBF.Frameworks t,+   (Reactor reactor,     Query.C msg, Construct.C msg, Time.Quantity time) =>    Channel ->    Time.T reactor Time.Relative time ->    Time.T reactor Time.Relative time ->    [([Pitch], [Pitch])] ->-   RB.Behavior t (AbsoluteTicks reactor) ->-   RB.Event t msg ->-   reactor t (RB.Event t (Common.Bundle reactor msg))-trainer chan pauseSecs durationSecs sets0 times evs0 = IxMonad.unwrap $ do-   pause    <- IxMonad.Wrap $ Time.ticksFromAny pauseSecs-   duration <- IxMonad.Wrap $ Time.ticksFromAny durationSecs+   RB.Behavior (AbsoluteTicks reactor) ->+   RB.Event msg ->+   reactor (RB.Event (Common.Bundle reactor msg))+trainer chan pauseSecs durationSecs sets0 times evs0 = do+   pause    <- Time.ticksFromAny pauseSecs+   duration <- Time.ticksFromAny durationSecs    let makeSeq sets =           case sets of              (target, _) : _ ->@@ -692,9 +685,9 @@              [] -> ([], mempty)     let (initial, initIgnoreUntil) = makeSeq sets0-   initEv <- IxMonad.Wrap $ initialEvent initial+   initEv <- initialEvent initial -   return $ RB.union initEv $ fst $+   liftM (RBU.union "trainer" initEv . fst) $       flip (RBU.traverse (sets0, [], Time.inc initIgnoreUntil mempty))          (fmap (,) times <@> evs0) $ \(time,ev) ->       case Query.noteExplicitOff ev of
src/Reactive/Banana/MIDI/Program.hs view
@@ -1,5 +1,6 @@ module Reactive.Banana.MIDI.Program (-   traverse, traverseSeek, next, seek, maybeNoteOn,+   Reactive.Banana.MIDI.Program.traverse, traverseSeek,+   next, seek, maybeNoteOn,    asBanks,    ) where
src/Reactive/Banana/MIDI/Time.hs view
@@ -1,7 +1,6 @@ module Reactive.Banana.MIDI.Time where -import qualified Reactive.Banana.MIDI.IndexedMonad as IxMonad-import qualified Reactive.Banana.Frameworks as RBF+import qualified Reactive.Banana.Combinators as RB  import qualified Numeric.NonNegative.Class as NonNeg @@ -20,7 +19,7 @@ This way we can prevent unlimited growth of denominators. -} -- the Const type helps us to avoid explicit kind signature extension-newtype T m t a = Cons (Const a (m () t))+newtype T m t a = Cons (Const a (m t))  instance Show a => Show (T m t a) where    showsPrec n x =@@ -93,17 +92,17 @@       mapPair (cons, mapSnd cons) $ split (decons x) (decons y)  -class IxMonad.C m => Timed m where-   ticksFromSeconds :: (RBF.Frameworks s) => T m t Seconds -> m s (T m t Ticks)+class RB.MonadMoment m => Timed m where+   ticksFromSeconds :: T m t Seconds -> m (T m t Ticks)  class Quantity a where-   ticksFromAny :: (Timed m, RBF.Frameworks s) => T m t a -> m s (T m t Ticks)+   ticksFromAny :: (Timed m) => T m t a -> m (T m t Ticks)  instance Quantity Seconds where    ticksFromAny = ticksFromSeconds  instance Quantity Ticks where-   ticksFromAny = IxMonad.point+   ticksFromAny = return   consRel :: String -> Rational -> T m Relative Seconds
src/Reactive/Banana/MIDI/Utility.hs view
@@ -2,14 +2,16 @@ module Reactive.Banana.MIDI.Utility where  import qualified Reactive.Banana.Combinators as RB+import qualified Reactive.Banana.Frameworks as RBF  import qualified Control.Monad.Trans.State as MS+import Control.Monad (liftM, liftM2, )  import Prelude hiding (sequence, )   partition ::-   (a -> Bool) -> RB.Event f a -> (RB.Event f a, RB.Event f a)+   (a -> Bool) -> RB.Event a -> (RB.Event a, RB.Event a) partition p =    (\x ->       (fmap snd $ RB.filterE fst x,@@ -17,38 +19,66 @@    fmap (\a -> (p a, a))  mapMaybe ::-   (a -> Maybe b) -> RB.Event f a -> RB.Event f b+   (a -> Maybe b) -> RB.Event a -> RB.Event b mapMaybe f = RB.filterJust . fmap f  partitionMaybe ::-   (a -> Maybe b) -> RB.Event f a -> (RB.Event f b, RB.Event f a)+   (a -> Maybe b) -> RB.Event a -> (RB.Event b, RB.Event a) partitionMaybe f =    (\x ->       (mapMaybe fst x,        mapMaybe (\(mb,a) -> maybe (Just a) (const Nothing) mb) x)) .    fmap (\a -> (f a, a)) +union :: String -> RB.Event a -> RB.Event a -> RB.Event a+union name = RB.unionWith (error $ name ++ ": clashing events")++{- |+The second event stream is delayed by an infinitesimal amount.+-}+unionM :: RB.Event a -> RB.Event a -> RBF.MomentIO (RB.Event a)+unionM xs = fmap (union "Utility.unionM" xs) . delayEps++delayEps :: RB.Event a -> RBF.MomentIO (RB.Event a)+delayEps xs = do+   (evs, handle) <- RBF.newEvent+   RBF.reactimate $ fmap handle xs+   return evs+ bypass ::    (a -> Maybe b) ->-   (RB.Event f a -> RB.Event f c) ->-   (RB.Event f b -> RB.Event f c) ->-   RB.Event f a -> RB.Event f c+   (RB.Event a -> RB.Event c) ->+   (RB.Event b -> RB.Event c) ->+   RB.Event a -> RB.Event c bypass p fa fb evs =    let (eb,ea) = partitionMaybe p evs-   in  RB.union (fb eb) (fa ea)+   in  union "bypass" (fb eb) (fa ea) +bypassM ::+   (Monad m) =>+   (a -> Maybe b) ->+   (RB.Event a -> m (RB.Event c)) ->+   (RB.Event b -> m (RB.Event c)) ->+   RB.Event a -> m (RB.Event c)+bypassM p fa fb evs =+   let (eb,ea) = partitionMaybe p evs+   in  liftM2 (union "bypass") (fb eb) (fa ea)+ traverse ::-   s -> (a -> MS.State s b) -> RB.Event f a ->-   (RB.Event f b, RB.Behavior f s)+   (RB.MonadMoment m) =>+   s -> (a -> MS.State s b) -> RB.Event a ->+   m (RB.Event b, RB.Behavior s) traverse s f = sequence s . fmap f  sequence ::-   s -> RB.Event f (MS.State s a) ->-   (RB.Event f a, RB.Behavior f s)+   (RB.MonadMoment m) =>+   s -> RB.Event (MS.State s a) ->+   m (RB.Event a, RB.Behavior s) sequence s =    RB.mapAccum s . fmap MS.runState  -mapAdjacent :: (a -> a -> b) -> a -> RB.Event f a -> RB.Event f b+mapAdjacent ::+   (RB.MonadMoment m) => (a -> a -> b) -> a -> RB.Event a -> m (RB.Event b) mapAdjacent f a0 =-   fst . RB.mapAccum a0 . fmap (\new old -> (f old new, new))+   liftM fst . RB.mapAccum a0 . fmap (\new old -> (f old new, new))