diff --git a/reactive-balsa.cabal b/reactive-balsa.cabal --- a/reactive-balsa.cabal +++ b/reactive-balsa.cabal @@ -1,5 +1,5 @@ Name: reactive-balsa -Version: 0.2.0.1 +Version: 0.3 License: BSD3 License-File: LICENSE Author: Henning Thielemann @@ -45,15 +45,15 @@ Source-Repository this type: darcs location: http://hub.darcs.net/thielema/reactive-balsa/ - tag: 0.2.0.1 + tag: 0.3 Flag splitBase description: Choose the new smaller, split-up base package. Library Build-Depends: - reactive-midyim >=0.2 && <0.3, - reactive-banana >=0.7 && <0.9, + reactive-midyim >=0.3 && <0.4, + reactive-banana >=1.1 && <1.2, midi-alsa >=0.2 && <0.3, midi >=0.2 && <0.3, alsa-seq >=0.6 && <0.7, diff --git a/src/Reactive/Banana/ALSA/Example.hs b/src/Reactive/Banana/ALSA/Example.hs --- a/src/Reactive/Banana/ALSA/Example.hs +++ b/src/Reactive/Banana/ALSA/Example.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE Rank2Types #-} module Reactive.Banana.ALSA.Example where import qualified Reactive.Banana.ALSA.Sequencer as Seq @@ -20,7 +19,6 @@ import qualified Reactive.Banana.MIDI.Utility as RBU -import qualified Reactive.Banana.Frameworks as RBF import qualified Reactive.Banana.Combinators as RB import Reactive.Banana.Combinators ((<@>), ) @@ -33,8 +31,8 @@ import qualified System.Random as Random import Control.Monad.Trans.Reader (ReaderT, ) -import Control.Monad (guard, liftM2, liftM3, ) -import Control.Applicative (pure, (<*>), ) +import Control.Monad (guard, liftM2, liftM3, join, foldM, (<=<), ) +import Control.Applicative (pure, (<*>), (<$>), ) import Data.Tuple.HT (mapFst, ) import Data.Maybe (mapMaybe, ) @@ -77,9 +75,7 @@ time :: Rational -> AlsaTime.RelativeSeconds time = Time.relative "example" . Time.Seconds -ticks :: - (RBF.Frameworks t) => - Rational -> Seq.Reactor t AlsaTime.RelativeTicks +ticks :: Rational -> Seq.Reactor AlsaTime.RelativeTicks ticks = Time.ticksFromSeconds . time {- @@ -94,27 +90,28 @@ reverse = Seq.run $ RBU.mapMaybe $ Note.liftMaybe Note.reverse -- works, but does not interact nicely with Note.AllOff -- latch = Seq.run (Seq.bypass Common.maybeNote (fst . Seq.latch)) -latch = Seq.run (Seq.bypass Note.maybeBndExt (fst . Process.pressed KeySet.latch)) -groupLatch = Seq.run (Seq.bypass Note.maybeBndExt (fst . Process.pressed KeySet.groupLatch)) -delay = Seq.runM $ \_times evs -> do dt <- ticks 0.2; return $ Process.delay dt evs -delayAdd = Seq.runM $ \_times evs -> do dt <- ticks 0.2; return $ Process.delayAdd dt evs -delayTranspose = Seq.runM $ \ _times evs -> do +latch = Seq.runM (Seq.bypassM Note.maybeBndExt (fmap fst . Process.pressed KeySet.latch)) +groupLatch = Seq.runM (Seq.bypassM Note.maybeBndExt (fmap fst . Process.pressed KeySet.groupLatch)) +delay = Seq.runM $ \evs -> do dt <- ticks 0.2; return $ Process.delay dt evs +delayAdd = Seq.runM $ \evs -> do dt <- ticks 0.2; Process.delayAdd dt evs +delayTranspose = Seq.runM $ \evs -> do let proc p dt = do tk <- ticks dt return $ Process.delay tk $ RBU.mapMaybe (stranspose p) evs - fmap (foldl RB.union (fmap now evs)) $ sequence $ + foldM Process.unionM (fmap now evs) <=< sequence $ proc 4 0.2 : proc 7 0.4 : proc 12 0.6 : [] getTempo :: - (Check.C ev, RBF.Frameworks t) => - RB.Event t ev -> - Seq.Reactor t (RB.Behavior t AlsaTime.RelativeTicks, RB.Event t ev) + (Check.C ev) => + RB.Event ev -> + Seq.Reactor (RB.Behavior AlsaTime.RelativeTicks, RB.Event ev) getTempo ctrl = + join $ liftM3 (uncurry Process.tempoCtrl Ctrl.tempoDefault) (ticks 0.15) (liftM2 (,) (ticks 0.5) (ticks 0.05)) (return ctrl) {- @@ -124,19 +121,17 @@ pattern :: (KeySet.C set) => set PitchChannel Velocity -> - (forall t. - (RBF.Frameworks t) => - RB.Behavior t (set PitchChannel Velocity) -> - RB.Event t AlsaTime.AbsoluteTicks -> - RB.Event t [Note.Boundary PitchChannel Velocity]) -> + (RB.Behavior (set PitchChannel Velocity) -> + RB.Event AlsaTime.AbsoluteTicks -> + Seq.Reactor (RB.Event [Note.Boundary PitchChannel Velocity])) -> ReaderT Seq.Handle IO () -pattern set pat = Seq.runM $ \ times evs0 -> do +pattern set pat = Seq.runTimesM $ \ times evs0 -> do (tempo, evs1) <- getTempo evs0 beat <- Process.beatVar times tempo - return $ - Seq.bypass Note.maybeBndExt - (\notes -> - pat (snd $ Process.pressed set notes) beat) evs1 + Seq.bypassM Note.maybeBndExt + (\notes -> do + pressed <- Process.pressed set notes + pat (snd pressed) beat) evs1 serialCycleUp @@ -157,39 +152,37 @@ cycleUpOffset :: ReaderT Seq.Handle IO () -cycleUpOffset = Seq.runM $ \ times evs0 -> do +cycleUpOffset = Seq.runTimesM $ \ times evs0 -> do (tempo, evs1) <- getTempo evs0 let n = 4 range = 3 * fromIntegral n - offset = - fmap round $ - Process.controllerLinear (channel 0) (controller 17) - (0::Float) (-range,range) evs1 + offset <- + fmap round <$> + Process.controllerLinear (channel 0) (controller 17) + (0::Float) (-range,range) evs1 beat <- Process.beatVar times tempo - return $ - Seq.bypass Note.maybeBndExt - (\notes -> - Pattern.mono Pattern.selectFromOctaveChord - (snd $ Process.pressed KeySet.groupLatch notes) - (pure (\o i -> mod (i-o) n + o) - <*> offset - <@> Pattern.cycleUpIndex (pure n) beat)) evs1 + Seq.bypassM Note.maybeBndExt + (\notes -> do + pressed <- Process.pressed KeySet.groupLatch notes + ixs <- Pattern.cycleUpIndex (pure n) beat + Pattern.mono Pattern.selectFromOctaveChord + (snd pressed) + (pure (\o i -> mod (i-o) n + o) <*> offset <@> ixs)) + evs1 -continuousSelect = Seq.runM $ \ _times evs -> - fmap - (Pattern.mono - Pattern.selectFromOctaveChord - (snd $ Process.pressed KeySet.groupLatch $ - RBU.mapMaybe Note.maybeBndExt evs)) $ - Process.uniqueChanges $ - fmap round $ - Process.controllerLinear (channel 0) (controller 17) (0::Float) (-8,16) evs +continuousSelect = Seq.runM $ \evs -> do + pressed <- + Process.pressed KeySet.groupLatch $ RBU.mapMaybe Note.maybeBndExt evs + Pattern.mono Pattern.selectFromOctaveChord (snd pressed) =<< + Process.uniqueChanges . fmap round =<< + Process.controllerLinear (channel 0) (controller 17) (0::Float) (-8,16) evs -snapSelect = Seq.runM $ \ _times evs -> do - Process.snapSelect - (snd $ Process.pressed KeySet.groupLatch $ RBU.mapMaybe Note.maybeBndExt evs) - (Process.controllerRaw (channel 0) (controller 17) 64 evs) +snapSelect = Seq.runM $ \evs -> do + pressed <- + Process.pressed KeySet.groupLatch $ RBU.mapMaybe Note.maybeBndExt evs + ctrl <- Process.controllerRaw (channel 0) (controller 17) 64 evs + Process.snapSelect (snd pressed) ctrl {- let ctrl = Process.controllerRaw (channel 0) (controller 17) 64 evs Seq.bypass Note.maybeBndExt @@ -198,7 +191,7 @@ -} split = Seq.run $ - uncurry RB.union + uncurry (RBU.union "split") . mapFst (RBU.mapMaybe (stranspose 12) @@ -213,7 +206,7 @@ Common.checkController (controller 95 ==) e) -splitPattern = Seq.runM $ \ times evs0 -> do +splitPattern = Seq.runTimesM $ \ times evs0 -> do (tempo, evs1) <- getTempo evs0 beat <- Process.beatVar times tempo @@ -225,48 +218,45 @@ return bnd _ -> return bnd - return $ - Seq.bypass checkLeft - (\left -> - fmap (mapMaybe (stranspose 12 . Note.fromBnd)) $ - Pattern.cycleUp (pure 4) - (snd $ Process.pressed KeySet.groupLatch left) beat) - evs1 + Seq.bypassM checkLeft + (\left -> do + pressed <- Process.pressed KeySet.groupLatch left + fmap (mapMaybe (stranspose 12 . Note.fromBnd)) <$> + Pattern.cycleUp (pure 4) (snd pressed) beat) + evs1 {- RBU.mapMaybe (stranspose 12) left)) beat -} -cyclePrograms = Seq.runM $ \times evs -> do +cyclePrograms = Seq.runTimesM $ \times evs -> do -- Seq.cyclePrograms (map program [13..17]) times evs defer <- Time.ticksFromSeconds $ time 0.1 - return $ RB.union - (RB.filterJust $ - Process.cycleProgramsDefer defer (map program [13..17]) times evs) - evs + pgms <- Process.cycleProgramsDefer defer (map program [13..17]) times evs + Process.unionM (RB.filterJust pgms) evs sweep = - Seq.runM $ \ _times evs -> + Seq.runM $ \evs -> let c = channel 0 centerCC = controller 70 depthCC = controller 17 speedCC = controller 16 - in fmap (RB.union - (RB.filterE (not. Common.checkController - (flip elem [centerCC, depthCC, speedCC])) evs) . - uncurry - (Process.makeControllerLinear c centerCC - (Process.controllerRaw c depthCC 64 evs) - (Process.controllerRaw c centerCC 64 evs))) - $ - Process.sweep - (time 0.01) (sin . (2*pi*)) - (Process.controllerExponential c speedCC 0.3 (0.1, 1) evs) + in do + depth <- Process.controllerRaw c depthCC 64 evs + center <- Process.controllerRaw c centerCC 64 evs + speed <- Process.controllerExponential c speedCC 0.3 (0.1, 1) evs + RBU.union "sweep" + (RB.filterE + (not . Common.checkController + (flip elem [centerCC, depthCC, speedCC])) evs) . + uncurry (Process.makeControllerLinear c centerCC depth center) + <$> + Process.sweep (time 0.01) (sin . (2*pi*)) speed guitar = - Seq.runM $ \ _times evs -> - (\f -> fmap (flip f evs) (ticks 0.03)) $ \del -> - Seq.bypass Note.maybeBndExt $ \notes -> + Seq.runM $ \evs -> + (\f -> flip f evs =<< ticks 0.03) $ \del -> + Seq.bypassM Note.maybeBndExt $ \notes -> let (trigger, keys) = RBU.partitionMaybe (\note -> @@ -276,15 +266,16 @@ return on _ -> Nothing) notes - in (Process.guitar del - :: RB.Behavior t (KeySet.GroupLatch PitchChannel Velocity) -> - RB.Event t Bool -> RB.Event t Common.EventDataBundle) - (snd $ Process.pressed KeySet.groupLatch keys) trigger + in do + pressed <- snd <$> Process.pressed KeySet.groupLatch keys + Process.guitar del pressed trigger + :: Seq.Reactor (RB.Event Common.EventDataBundle) + trainer :: (Random.RandomGen g) => g -> ReaderT Seq.Handle IO () trainer g = - Seq.runM $ \ times evs -> - fmap (RB.union (fmap singletonBundle evs)) $ + Seq.runTimesM $ \ times evs -> + Process.unionM (fmap singletonBundle evs) =<< Process.trainer (channel 0) (time 0.5) (time 0.3) (Training.all g) times evs diff --git a/src/Reactive/Banana/ALSA/Private.hs b/src/Reactive/Banana/ALSA/Private.hs --- a/src/Reactive/Banana/ALSA/Private.hs +++ b/src/Reactive/Banana/ALSA/Private.hs @@ -3,10 +3,9 @@ import qualified Reactive.Banana.MIDI.Process as Process import qualified Reactive.Banana.MIDI.Time as Time -import qualified Reactive.Banana.MIDI.IndexedMonad as IxMonad +import qualified Reactive.Banana.Combinators as RB import qualified Reactive.Banana.Frameworks as RBF -import qualified Reactive.Banana.Switch as RBS import qualified Sound.ALSA.Sequencer as SndSeq import qualified Sound.ALSA.Sequencer.Client as Client @@ -32,22 +31,21 @@ } -newtype Reactor t a = +newtype Reactor a = Reactor { runReactor :: MR.ReaderT (RBF.AddHandler Event.T, Handle) - (MS.StateT Schedule (RBS.Moment t)) + (MS.StateT Schedule RBF.MomentIO) a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix) -instance Process.Moment Reactor where - liftMoment = Reactor . MT.lift . MT.lift +instance RB.MonadMoment Reactor where + liftMoment = Process.liftMomentIO . RB.liftMoment -instance IxMonad.C Reactor where - point = return - bind = (>>=) +instance Process.MomentIO Reactor where + liftMomentIO = Reactor . MT.lift . MT.lift instance Time.Timed Reactor where ticksFromSeconds = diff --git a/src/Reactive/Banana/ALSA/Sequencer.hs b/src/Reactive/Banana/ALSA/Sequencer.hs --- a/src/Reactive/Banana/ALSA/Sequencer.hs +++ b/src/Reactive/Banana/ALSA/Sequencer.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE Rank2Types #-} module Reactive.Banana.ALSA.Sequencer ( Handle, Reactor, @@ -28,8 +27,8 @@ 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 (forever, ) -import Control.Applicative (Applicative, pure, (<*>), ) +import Control.Monad (liftM, forever, ) +import Control.Applicative (pure, (<*>), ) import Control.Functor.HT (void, ) import Data.Monoid (mempty, ) @@ -47,26 +46,27 @@ else Event.Tag $ succ s -getHandle :: Reactor t Handle +getHandle :: Reactor Handle getHandle = Reactor $ MR.asks snd run :: (Common.Events ev) => - (forall t. - (RBF.Frameworks t) => - RB.Event t Event.Data -> RB.Event t ev) -> + (RB.Event Event.Data -> RB.Event ev) -> ReaderT Handle IO () -run f = - runM (\ _ts xs -> return $ f xs) +run f = runM (return . f) runM :: (Common.Events ev) => - (forall t. - (RBF.Frameworks t) => - RB.Behavior t AlsaTime.AbsoluteTicks -> - RB.Event t Event.Data -> Reactor t (RB.Event t ev)) -> + (RB.Event Event.Data -> Reactor (RB.Event ev)) -> ReaderT Handle IO () -runM f = do +runM f = runTimesM (const f) + +runTimesM :: + (Common.Events ev) => + (RB.Behavior AlsaTime.AbsoluteTicks -> + RB.Event Event.Data -> Reactor (RB.Event ev)) -> + ReaderT Handle IO () +runTimesM f = do Common.startQueue MR.ReaderT $ \h -> do (addEventHandler, runEventHandler) <- RBF.newAddHandler @@ -107,11 +107,9 @@ Event.CustomEv Event.Echo _ <- Just $ Event.body echo return $ Event.tag echo -reactimate :: - (RBF.Frameworks t) => - RB.Event t (IO ()) -> Reactor t () +reactimate :: RB.Event (IO ()) -> Reactor () reactimate evs = - Process.liftMoment $ RBF.reactimate evs + Process.liftMomentIO $ RBF.reactimate evs sendEchos :: Handle -> Schedule -> [AlsaTime.AbsoluteTicks] -> IO () sendEchos h sched echos = do @@ -150,7 +148,17 @@ 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] + (RB.Event b -> RB.Event c) -> + RB.Event a -> RB.Event [Common.Future Event.Data] bypass p f = RBU.bypass p (fmap Common.flattenEvents) (fmap Common.flattenEvents . f) + +bypassM :: + (Monad m, Common.Events a, Common.Events c) => + (a -> Maybe b) -> + (RB.Event b -> m (RB.Event c)) -> + RB.Event a -> m (RB.Event [Common.Future Event.Data]) +bypassM p f = + RBU.bypassM p + (return . fmap Common.flattenEvents) + (liftM (fmap Common.flattenEvents) . f)