module Reactive.Banana.ALSA.Example where import qualified Reactive.Banana.ALSA.Sequencer as Seq import qualified Reactive.Banana.ALSA.Common as Common import qualified Reactive.Banana.ALSA.Time as AlsaTime import qualified Reactive.Banana.MIDI.Training as Training import qualified Reactive.Banana.MIDI.Pattern as Pattern import qualified Reactive.Banana.MIDI.Controller as Ctrl import qualified Reactive.Banana.MIDI.Pitch as Pitch import qualified Reactive.Banana.MIDI.KeySet as KeySet import qualified Reactive.Banana.MIDI.Process as Process import qualified Reactive.Banana.MIDI.Note as Note import qualified Reactive.Banana.MIDI.Time as Time import Reactive.Banana.MIDI.Common (PitchChannel, program, channel, pitch, controller, singletonBundle, now, ) import qualified Reactive.Banana.MIDI.Utility as RBU import qualified Reactive.Banana.Bunch.Combinators as RB import Reactive.Banana.Bunch.Combinators ((<@>), ) import qualified Sound.MIDI.ALSA.Check as Check import qualified Sound.MIDI.ALSA.Query as Query () import qualified Sound.MIDI.ALSA.Construct as Construct () import qualified Sound.ALSA.Sequencer.Event as Event import Sound.MIDI.Message.Channel.Voice (Velocity, ) import qualified System.Random as Random import Control.Monad.Trans.Reader (ReaderT, ) import Control.Monad (guard, liftM2, liftM3, join, ) import Control.Applicative (pure, (<*>), (<$>), ) import Data.Tuple.HT (mapFst, ) import Data.Maybe (mapMaybe, ) import Prelude hiding (reverse, ) run, runLLVM, runTimidity :: ReaderT Seq.Handle IO a -> IO a run x = Common.with $ Common.connectAny >> x runLLVM x = Common.with $ Common.connectLLVM >> x runTimidity x = Common.with $ Common.connectTimidity >> x pass, transpose, reverse, latch, groupLatch, delay, delayAdd, delayTranspose, cycleUp, cycleUpAuto, pingPong, pingPongAuto, binary, crossSum, bruijn, random, randomInversions, serialCycleUp, split, splitPattern, cyclePrograms, sweep, guitar, snapSelect, continuousSelect :: ReaderT Seq.Handle IO () time :: Rational -> AlsaTime.RelativeSeconds time = Time.relative "example" . Time.Seconds ticks :: Rational -> Seq.Reactor AlsaTime.RelativeTicks ticks = Time.ticksFromSeconds . time {- stranspose :: (Query.C msg, Construct.C msg) => Int -> msg -> Maybe msg -} stranspose :: Int -> Event.Data -> Maybe Event.Data stranspose d = Note.liftMaybe $ Note.transpose d pass = Seq.run id transpose = Seq.run $ RBU.mapMaybe $ stranspose 2 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.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; return $ 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 $ proc 4 0.2 : proc 7 0.4 : proc 12 0.6 : [] getTempo :: (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) {- pure 0.2 -} pattern :: (KeySet.C set) => set 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.runTimesM $ \ times evs0 -> do (tempo, evs1) <- getTempo evs0 beat <- Process.beatVar times tempo Seq.bypassM Note.maybeBndExt (\notes -> do pressed <- Process.pressed set notes pat (snd pressed) beat) evs1 serialCycleUp = pattern (KeySet.serialLatch 4) (Pattern.cycleUp (pure 4)) cycleUp = pattern KeySet.groupLatch (Pattern.cycleUp (pure 4)) pingPong = pattern KeySet.groupLatch (Pattern.pingPong (pure 4)) binary = pattern KeySet.groupLatch Pattern.binaryLegato crossSum = pattern KeySet.groupLatch (Pattern.crossSum (pure 4)) bruijn = pattern KeySet.groupLatch (Pattern.bruijn 4 2) random = pattern KeySet.groupLatch Pattern.random randomInversions = pattern KeySet.groupLatch Pattern.randomInversions cycleUpAuto = pattern KeySet.groupLatch $ \set -> Pattern.cycleUp (fmap KeySet.size set) set pingPongAuto = pattern KeySet.groupLatch $ \set -> Pattern.pingPong (fmap KeySet.size set) set cycleUpOffset :: ReaderT Seq.Handle IO () 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 beat <- Process.beatVar times tempo 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 $ \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 $ \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 (\notes -> Seq.snapSelect (snd $ Process.pressed KeySet.groupLatch notes) ctrl) evs -} split = Seq.run $ uncurry RB.union . mapFst (RBU.mapMaybe (stranspose 12) . fmap (Common.setChannel (channel 1))) . RBU.partition (\e -> (Common.checkChannel (channel 0 ==) e && Common.checkPitch (pitch 60 >) e) || Common.checkController (controller 94 ==) e || Common.checkController (controller 95 ==) e) splitPattern = Seq.runTimesM $ \ times evs0 -> do (tempo, evs1) <- getTempo evs0 beat <- Process.beatVar times tempo let checkLeft e = do bnd <- Note.maybeBndExt e case bnd of Note.BoundaryExt (Note.Boundary pc _vel _on) -> do guard (Pitch.extract pc < pitch 60) return bnd _ -> return bnd 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.runTimesM $ \times evs -> do -- Seq.cyclePrograms (map program [13..17]) times evs defer <- Time.ticksFromSeconds $ time 0.1 pgms <- Process.cycleProgramsDefer defer (map program [13..17]) times evs return $ RB.union (RB.filterJust pgms) evs sweep = Seq.runM $ \evs -> let c = channel 0 centerCC = controller 70 depthCC = controller 17 speedCC = controller 16 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 RB.union (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 $ \evs -> (\f -> flip f evs =<< ticks 0.03) $ \del -> Seq.bypassM Note.maybeBndExt $ \notes -> let (trigger, keys) = RBU.partitionMaybe (\note -> case note of Note.BoundaryExt (Note.Boundary pc _vel on) -> do guard $ Pitch.extract pc == pitch 84 return on _ -> Nothing) notes 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.runTimesM $ \ times evs -> RB.union (fmap singletonBundle evs) <$> Process.trainer (channel 0) (time 0.5) (time 0.3) (Training.all g) times evs