reactive-balsa 0.2.0.1 → 0.3
raw patch · 4 files changed
+117/−120 lines, 4 filesdep ~reactive-bananadep ~reactive-midyim
Dependency ranges changed: reactive-banana, reactive-midyim
Files
- reactive-balsa.cabal +4/−4
- src/Reactive/Banana/ALSA/Example.hs +78/−87
- src/Reactive/Banana/ALSA/Private.hs +7/−9
- src/Reactive/Banana/ALSA/Sequencer.hs +28/−20
reactive-balsa.cabal view
@@ -1,5 +1,5 @@ Name: reactive-balsa-Version: 0.2.0.1+Version: 0.3 License: BSD3 License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de>@@ -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,
src/Reactive/Banana/ALSA/Example.hs view
@@ -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
src/Reactive/Banana/ALSA/Private.hs view
@@ -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 =
src/Reactive/Banana/ALSA/Sequencer.hs view
@@ -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)