diff --git a/reactive-balsa.cabal b/reactive-balsa.cabal --- a/reactive-balsa.cabal +++ b/reactive-balsa.cabal @@ -1,10 +1,10 @@ Name: reactive-balsa -Version: 0.0 +Version: 0.1 License: BSD3 License-File: LICENSE Author: Henning Thielemann Maintainer: Henning Thielemann --- Homepage: http://www.haskell.org/haskellwiki/MIDI +Homepage: http://www.haskell.org/haskellwiki/Reactive-balsa Category: Sound, Music Build-Type: Simple Synopsis: Programmatically edit MIDI events via ALSA and reactive-banana @@ -35,7 +35,7 @@ in a custom programming interface. It is most fun to play with the stream editors in GHCi. However we provide an example module that demonstrates various effects. -Tested-With: GHC==6.12.3 +Tested-With: GHC==6.12.3, GHC==7.4.1 Cabal-Version: >=1.6 Build-Type: Simple Source-Repository head @@ -45,25 +45,26 @@ Source-Repository this type: darcs location: http://code.haskell.org/~thielema/reactive-balsa/ - tag: 0.0 + tag: 0.1 Flag splitBase description: Choose the new smaller, split-up base package. Library Build-Depends: - reactive-banana >=0.4.3 && <0.5, + reactive-banana >=0.5 && <0.6, midi-alsa >=0.2 && <0.3, midi >=0.2 && <0.3, - alsa-seq >=0.5 && <0.6, + alsa-seq >=0.6 && <0.7, alsa-core >=0.5 && <0.6, event-list >=0.1 && < 0.2, non-negative >=0.1 && <0.2, data-accessor-transformers >=0.2.1 && <0.3, data-accessor >=0.2.1 && <0.3, utility-ht >=0.0.5 && <0.1, - containers >=0.2 && <0.5, - transformers >=0.2 && <0.3 + containers >=0.2 && <0.6, + transformers >=0.2 && <0.4, + extensible-exceptions >=0.1 && <0.2 If flag(splitBase) Build-Depends: random >=1 && <2, @@ -81,7 +82,9 @@ Reactive.Banana.ALSA.Pattern Reactive.Banana.ALSA.Guitar Reactive.Banana.ALSA.Training + Reactive.Banana.ALSA.Time Reactive.Banana.ALSA.Common + Reactive.Banana.ALSA.Utility Other-Modules: Reactive.Banana.ALSA.DeBruijn Reactive.Banana.ALSA.Trie diff --git a/src/Reactive/Banana/ALSA/Common.hs b/src/Reactive/Banana/ALSA/Common.hs --- a/src/Reactive/Banana/ALSA/Common.hs +++ b/src/Reactive/Banana/ALSA/Common.hs @@ -1,15 +1,21 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Reactive.Banana.ALSA.Common where +import qualified Reactive.Banana.ALSA.Time as Time + import qualified Sound.ALSA.Sequencer as SndSeq import qualified Sound.ALSA.Sequencer.Address as Addr import qualified Sound.ALSA.Sequencer.Client as Client import qualified Sound.ALSA.Sequencer.Port as Port -import qualified Sound.ALSA.Sequencer.Port.Info as PortInfo +import qualified Sound.ALSA.Sequencer.Port.InfoMonad as PortInfo import qualified Sound.ALSA.Sequencer.Queue as Queue import qualified Sound.ALSA.Sequencer.Event as Event -import qualified Sound.ALSA.Sequencer.RealTime as RealTime +import qualified Sound.ALSA.Sequencer.Connect as Connect +import qualified Sound.ALSA.Sequencer.Time as ATime +import qualified Control.Exception.Extensible as Exc +import qualified Sound.ALSA.Exception as AExc +import qualified Foreign.C.Error as Err + import qualified Sound.MIDI.ALSA as MALSA import qualified Sound.MIDI.Message.Channel as ChannelMsg import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg @@ -23,8 +29,11 @@ import Data.Accessor.Basic ((^.), (^=), ) +import Control.Monad (mplus, ) +import Data.List (intercalate, ) import Data.Maybe.HT (toMaybe, ) import Data.Tuple.HT (mapFst, mapSnd, ) +import Data.Bool.HT (if', ) import qualified Data.Map as Map @@ -35,9 +44,6 @@ import qualified Numeric.NonNegative.Class as NonNeg import qualified Data.Monoid as Mn -import Data.Ratio ((%), ) -import Data.Word (Word8, ) -import Data.Int (Int32, ) import Prelude hiding (init, filter, reverse, ) @@ -97,52 +103,83 @@ -- | make ALSA set the time stamps in incoming events setTimeStamping :: ReaderT Handle IO () -setTimeStamping = Reader.ReaderT $ \h -> do - info <- PortInfo.get (sequ h) (portPublic h) - PortInfo.setTimestamping info True - PortInfo.setTimestampReal info True - PortInfo.setTimestampQueue info (queue h) - PortInfo.set (sequ h) (portPublic h) info +setTimeStamping = + Reader.ReaderT $ \h -> + PortInfo.modify (sequ h) (portPublic h) $ do + PortInfo.setTimestamping True + PortInfo.setTimestampReal True + PortInfo.setTimestampQueue (queue h) startQueue :: ReaderT Handle IO () startQueue = Reader.ReaderT $ \h -> do - Queue.control (sequ h) (queue h) Event.QueueStart 0 Nothing + Queue.control (sequ h) (queue h) Event.QueueStart Nothing _ <- Event.drainOutput (sequ h) return () -connect :: String -> String -> ReaderT Handle IO () -connect fromName toName = Reader.ReaderT $ \h -> do - from <- Addr.parse (sequ h) fromName - to <- Addr.parse (sequ h) toName - SndSeq.connectFrom (sequ h) (portPublic h) from - SndSeq.connectTo (sequ h) (portPublic h) to +{- | +Connect ourselve to an input client and an output client. +The function expects a list of alternative clients +that are checked successively. +-} +connect :: [String] -> [String] -> ReaderT Handle IO () +connect fromNames toNames = do + _ <- connectFrom =<< parseAddresses fromNames + _ <- connectTo =<< parseAddresses toNames + return () +connectFrom, connectTo :: Addr.T -> ReaderT Handle IO Connect.T +connectFrom from = Reader.ReaderT $ \h -> + Connect.createFrom (sequ h) (portPublic h) from +connectTo to = Reader.ReaderT $ \h -> + Connect.createTo (sequ h) (portPublic h) to + +timidity, haskellSynth :: String +timidity = "TiMidity" +haskellSynth = "Haskell-LLVM-Synthesizer" + +inputs, outputs :: [String] +inputs = ["ReMOTE SL", "E-MU Xboard61", "USB Midi Cable", "SAMSON Graphite 49"] +outputs = [timidity, haskellSynth, "Haskell-Synthesizer", "Haskell-Supercollider"] + connectTimidity :: ReaderT Handle IO () connectTimidity = - connect "ReMOTE" "TiMidity" --- connect "E-MU Xboard61" "TiMidity" + connect inputs [timidity] connectLLVM :: ReaderT Handle IO () connectLLVM = --- connect "USB Midi Cable" "Haskell-LLVM-Synthesizer" - connect "E-MU Xboard61" "Haskell-LLVM-Synthesizer" --- connect "ReMOTE SL" "Haskell-LLVM-Synthesizer" --- connect "ReMOTE SL" "Haskell-Synthesizer" + connect inputs [haskellSynth] -connectSuperCollider :: ReaderT Handle IO () -connectSuperCollider = - connect "E-MU Xboard61" "Haskell-Supercollider" +connectAny :: ReaderT Handle IO () +connectAny = + connect inputs outputs +parseAddresses :: [String] -> ReaderT Handle IO Addr.T +parseAddresses names = Reader.ReaderT $ \h -> + let notFoundExc = Err.Errno 2 + go [] = + Exc.throw $ + AExc.Cons + "parseAdresses" + ("could not find any of the clients: " ++ intercalate ", " names) + notFoundExc + go (x:xs) = + AExc.catch (Addr.parse (sequ h) x) $ + \exc -> + if AExc.code exc == notFoundExc + then go xs + else Exc.throw exc + in go names + -- * send single events -sendNote :: Channel -> Time -> Velocity -> Pitch -> ReaderT Handle IO () +sendNote :: Channel -> Time.T -> Velocity -> Pitch -> ReaderT Handle IO () sendNote chan dur vel pit = let note = simpleNote chan pit vel - t = incTime dur 0 + t = Time.inc dur 0 in do outputEvent 0 (Event.NoteEv Event.NoteOn note) outputEvent t (Event.NoteEv Event.NoteOff note) @@ -195,56 +232,6 @@ --- * time - -{- | -The 'Time' types are used instead of floating point types, -because the latter ones caused unpredictable 'negative number' errors. -The denominator must always be a power of 10, -this way we can prevent unlimited grow of denominators. --} -type TimeAbs = Rational -newtype Time = Time {deconsTime :: Rational} - deriving (Show, Eq, Ord, Num, Fractional) - -consTime :: String -> Rational -> Time -consTime msg x = - if x>=0 - then Time x - else error $ msg ++ ": negative number" - -incTime :: Time -> TimeAbs -> TimeAbs -incTime dt t = t + deconsTime dt - -scaleTimeCeiling :: Double -> Time -> Time -scaleTimeCeiling k (Time t) = - Time $ ceiling (toRational k * t * nano) % nano - -nano :: Num a => a -nano = 1000^(3::Int) - -instance Mn.Monoid Time where - mempty = Time 0 - mappend (Time x) (Time y) = Time (x+y) - -instance NonNeg.C Time where - split = NonNeg.splitDefault deconsTime Time - - -timeFromStamp :: Event.TimeStamp -> TimeAbs -timeFromStamp t = - case t of - Event.RealTime rt -> - RealTime.toInteger rt % nano --- _ -> 0, - _ -> error "unsupported time stamp type" - -stampFromTime :: TimeAbs -> Event.TimeStamp -stampFromTime t = - Event.RealTime (RealTime.fromInteger (round (t*nano))) - - - defaultTempoCtrl :: (Channel,Controller) defaultTempoCtrl = (ChannelMsg.toChannel 0, VoiceMsg.toController 16) @@ -260,11 +247,14 @@ flattenEvents :: ev -> [Future Event.Data] instance Events Event.Data where - flattenEvents ev = [Future 0 ev] + flattenEvents = singletonBundle +instance Events NoteBoundary where + flattenEvents = singletonBundle . noteFromBnd + instance Events ev => Events (Future ev) where flattenEvents (Future dt ev) = - map (\(Future t e) -> Future (t+dt) e) $ + map (\(Future t e) -> Future (Mn.mappend t dt) e) $ flattenEvents ev instance Events ev => Events (Maybe ev) where @@ -281,32 +271,24 @@ flattenEvents ev0 ++ flattenEvents ev1 ++ flattenEvents ev2 -makeEvent :: Handle -> TimeAbs -> Event.Data -> Event.T +makeEvent :: Handle -> Time.Abs -> Event.Data -> Event.T makeEvent h t e = - Event.Cons - { Event.highPriority = False - , Event.tag = 0 - , Event.queue = queue h - , Event.timestamp = stampFromTime t - , Event.source = Addr.Cons (client h) (portPublic h) - , Event.dest = Addr.subscribers - , Event.body = e + (Event.simple (Addr.Cons (client h) (portPublic h)) e) + { Event.queue = queue h + , Event.time = ATime.consAbs $ Time.toStamp t } -makeEcho :: Handle -> TimeAbs -> Event.Custom -> Event.T -makeEcho h t c = - Event.Cons - { Event.highPriority = False - , Event.tag = 0 - , Event.queue = queue h - , Event.timestamp = stampFromTime t - , Event.source = Addr.Cons (client h) (portPrivate h) - , Event.dest = Addr.Cons (client h) (portPrivate h) - , Event.body = Event.CustomEv Event.Echo c - } +makeEcho :: Handle -> Time.Abs -> Event.T +makeEcho h t = + let addr = Addr.Cons (client h) (portPrivate h) + in (Event.simple addr (Event.CustomEv Event.Echo (Event.Custom 0 0 0))) + { Event.queue = queue h + , Event.time = ATime.consAbs $ Time.toStamp t + , Event.dest = addr + } -outputEvent :: TimeAbs -> Event.Data -> ReaderT Handle IO () +outputEvent :: Time.Abs -> Event.Data -> ReaderT Handle IO () outputEvent t ev = Reader.ReaderT $ \h -> Event.output (sequ h) (makeEvent h t ev) >> Event.drainOutput (sequ h) >> @@ -325,19 +307,19 @@ The times are relative to the start time of the bundle and do not need to be ordered. -} -data Future a = Future {futureTime :: Time, futureData :: a} +data Future a = Future {futureTime :: Time.T, futureData :: a} type Bundle a = [Future a] type EventBundle = Bundle Event.T type EventDataBundle = Bundle Event.Data singletonBundle :: a -> Bundle a -singletonBundle ev = [Future 0 ev] +singletonBundle ev = [now ev] immediateBundle :: [a] -> Bundle a immediateBundle = map now now :: a -> Future a -now = Future 0 +now = Future Mn.mempty instance Functor Future where fmap f (Future dt a) = Future dt $ f a @@ -397,7 +379,7 @@ > > replaceProgram [1,2,3,4] 5 [10,11,12,13] > (True,[10,11,2,13]) -} -replaceProgram :: [Int32] -> Int32 -> [Int32] -> (Bool, [Int32]) +replaceProgram :: Real i => [i] -> i -> [i] -> (Bool, [i]) replaceProgram (n:ns) pgm pt = let (p,ps) = case pt of @@ -409,7 +391,7 @@ replaceProgram ns (pgm-n) ps replaceProgram [] _ ps = (False, ps) -programFromBanks :: [Int32] -> [Int32] -> Int32 +programFromBanks :: Real i => [i] -> [i] -> i programFromBanks ns ps = foldr (\(n,p) s -> p+n*s) 0 $ zip ns ps @@ -438,17 +420,18 @@ with the same number of buttons. -} programsAsBanks :: - [Int32] -> - Event.Data -> State.State [Int32] Event.Data + [Int] -> + Event.Data -> State.State [Int] Event.Data programsAsBanks ns e = case e of Event.CtrlEv Event.PgmChange ctrl -> State.state $ \ps0 -> let pgm = Event.ctrlValue ctrl - (valid, ps1) = replaceProgram ns pgm ps0 + (valid, ps1) = + replaceProgram ns (fromIntegral $ Event.unValue pgm) ps0 in (Event.CtrlEv Event.PgmChange $ ctrl{Event.ctrlValue = if valid - then programFromBanks ns ps1 + then Event.Value $ fromIntegral $ programFromBanks ns ps1 else pgm}, ps1) _ -> return e @@ -463,7 +446,7 @@ Event.CtrlEv Event.PgmChange $ Event.Ctrl { Event.ctrlChannel = Event.noteChannel note, - Event.ctrlParam = 0, + Event.ctrlParam = Event.Parameter 0, Event.ctrlValue = MALSA.fromProgram pgm}, rest) [] -> (Nothing, []) @@ -516,16 +499,16 @@ _ -> return Nothing reduceNoteVelocity :: - Word8 -> Event.Note -> Event.Note -reduceNoteVelocity decay note = + Event.Velocity -> Event.Note -> Event.Note +reduceNoteVelocity (Event.Velocity decay) note = note{Event.noteVelocity = - let vel = Event.noteVelocity note + let Event.Velocity vel = Event.noteVelocity note in if vel==0 - then 0 - else vel - min decay (vel-1)} + then Event.offVelocity + else Event.Velocity $ vel - min decay (vel-1)} delayAdd :: - Word8 -> Time -> Event.Data -> EventDataBundle + Event.Velocity -> Time.T -> Event.Data -> EventDataBundle delayAdd decay d e = singletonBundle e ++ case e of @@ -567,7 +550,7 @@ type KeyQueue = [((Pitch, Channel), Velocity)] eventsFromKey :: - Time -> Time -> ((Pitch, Channel), Velocity) -> + Time.T -> Time.T -> ((Pitch, Channel), Velocity) -> EventDataBundle eventsFromKey start dur ((pit,chan), vel) = Future start (Event.NoteEv Event.NoteOn $ simpleNote chan pit vel) : @@ -599,52 +582,27 @@ n -> (n, x - fromIntegral n) +fraction :: RealFrac a => a -> a +fraction x = + let n = floor x + in x - fromIntegral (n::Integer) + + ctrlDur :: - (Time, Time) -> Int -> Time + (Time.T, Time.T) -> Int -> Time.T ctrlDur = ctrlDurExponential ctrlDurLinear :: - (Time, Time) -> Int -> Time + (Time.T, Time.T) -> Int -> Time.T ctrlDurLinear (minDur, maxDur) val = - minDur + (maxDur-minDur) - * fromIntegral val / 127 + let k = fromIntegral val / 127 + in Time.scale (1-k) minDur `Mn.mappend` Time.scale k maxDur +-- minDur + Time.scale (fromIntegral val / 127) (maxDur-minDur) ctrlDurExponential :: - (Time, Time) -> Int -> Time + (Time.T, Time.T) -> Int -> Time.T ctrlDurExponential (minDur, maxDur) val = - minDur * - Time - (powerRationalFromFloat 10 3 - (fromRational $ deconsTime maxDur/deconsTime minDur :: Double) - (fromIntegral val / 127)) - -{- | -Compute @base ** expo@ -approximately to result type 'Rational' -such that the result has a denominator which is a power of @digitBase@ -and a relative precision of numerator of @precision@ digits -with respect to @digitBase@-ary numbers. --} -powerRationalFromFloat :: - (Floating a, RealFrac a) => - Int -> Int -> a -> a -> Rational -powerRationalFromFloat digitBase precision base expo = - let digitBaseFloat = fromIntegral digitBase - {- - It would be nice, if properFraction would warrant @0<=x<1@. - Actually it can be @-1 a -> a -fraction x = - let n = floor x - in x - fromIntegral (n::Integer) - + Time.scale (Time.div maxDur minDur ** (fromIntegral val / 127)) minDur {- @@ -724,6 +682,41 @@ mode == Mode.AllSoundOff || mode == Mode.AllNotesOff + + +data NoteBoundary = + NoteBoundary (Pitch, Channel) Velocity Bool + deriving (Eq, Show) + +data NoteBoundaryExt = + NoteBoundaryExt NoteBoundary + | AllNotesOff + deriving (Eq, Show) + +maybeNote :: Event.Data -> Maybe NoteBoundary +maybeNote ev = + case ev of + Event.NoteEv notePart note -> + let key = + (note ^. MALSA.notePitch, + note ^. MALSA.noteChannel) + in case normalNoteFromEvent notePart note of + (Event.NoteOn, vel) -> Just $ NoteBoundary key vel True + (Event.NoteOff, vel) -> Just $ NoteBoundary key vel False + _ -> Nothing + _ -> Nothing + +maybeNoteExt :: Event.Data -> Maybe NoteBoundaryExt +maybeNoteExt ev = + mplus + (fmap NoteBoundaryExt $ maybeNote ev) + (toMaybe (isAllNotesOff ev) AllNotesOff) + +noteFromBnd :: NoteBoundary -> Event.Data +noteFromBnd (NoteBoundary (pit,chan) vel on) = + Event.NoteEv + (if' on Event.NoteOn Event.NoteOff) + (simpleNote chan pit vel) -- * event list support diff --git a/src/Reactive/Banana/ALSA/DeBruijn.hs b/src/Reactive/Banana/ALSA/DeBruijn.hs --- a/src/Reactive/Banana/ALSA/DeBruijn.hs +++ b/src/Reactive/Banana/ALSA/DeBruijn.hs @@ -18,6 +18,11 @@ import Prelude hiding (all, ) +{- | +@'lexLeast' n k@ is a sequence with length n^k +where @cycle ('lexLeast' n k)@ contains all n-ary numbers with k digits as infixes. +The function computes the lexicographically smallest of such sequences. +-} lexLeast :: Int -> Int -> [Int] lexLeast n k = concat $ 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,29 +1,36 @@ +{-# LANGUAGE Rank2Types #-} module Reactive.Banana.ALSA.Example where import qualified Reactive.Banana.ALSA.Training as Training import qualified Reactive.Banana.ALSA.Pattern as Pattern import qualified Reactive.Banana.ALSA.KeySet as KeySet import qualified Reactive.Banana.ALSA.Sequencer as Seq +import qualified Reactive.Banana.ALSA.Time as Time import qualified Reactive.Banana.ALSA.Common as Common -import Reactive.Banana.ALSA.Common (program, channel, pitch, controller, ) +import Reactive.Banana.ALSA.Common + (NoteBoundaryExt(NoteBoundaryExt), NoteBoundary(NoteBoundary), + program, channel, pitch, controller, ) -import qualified Reactive.Banana.Model as RB +import qualified Reactive.Banana.ALSA.Utility as RBU -import qualified Sound.MIDI.ALSA as MALSA -import Data.Accessor.Basic ((^.), ) +import qualified Reactive.Banana.Combinators as RB +import Reactive.Banana.Combinators ((<@>), ) -import qualified Sound.ALSA.Sequencer.Event as Event +import qualified Sound.MIDI.Message.Class.Check as Check import qualified System.Random as Random import Control.Monad.Trans.Reader (ReaderT, ) import Control.Monad (guard, ) +import Control.Applicative (pure, (<*>), ) +import Data.Tuple.HT (mapFst, ) +import Data.Maybe (mapMaybe, ) import Prelude hiding (reverse, ) run, runLLVM, runTimidity :: ReaderT Common.Handle IO a -> IO a -run = runTimidity +run x = Common.with $ Common.connectAny >> x runLLVM x = Common.with $ Common.connectLLVM >> x runTimidity x = Common.with $ Common.connectTimidity >> x @@ -37,63 +44,175 @@ delayAdd, delayTranspose, cycleUp, + cycleUpAuto, pingPong, --- binary, + pingPongAuto, + binary, crossSum, bruijn, random, randomInversions, serialCycleUp, + split, + splitPattern, cyclePrograms, sweep, - guitar :: ReaderT Common.Handle IO () + guitar, + snapSelect, + continuousSelect :: ReaderT Common.Handle IO () +time :: Rational -> Time.T +time = Time.cons "example" + pass = Seq.run id -transpose = Seq.run $ Seq.mapMaybe $ Common.transpose 2 -reverse = Seq.run $ Seq.mapMaybe $ Common.reverse -latch = Seq.run (fst . Seq.latch) -groupLatch = Seq.run (fst . Seq.pressed KeySet.groupLatch) -delay = Seq.run (Seq.delay 0.2) -delayAdd = Seq.run (Seq.delayAdd 0.2) +transpose = Seq.run $ RBU.mapMaybe $ Common.transpose 2 +reverse = Seq.run $ RBU.mapMaybe $ Common.reverse +-- works, but does not interact nicely with AllNotesOff +-- latch = Seq.run (Seq.bypass Common.maybeNote (fst . Seq.latch)) +latch = Seq.run (Seq.bypass Common.maybeNoteExt (fst . Seq.pressed KeySet.latch)) +groupLatch = Seq.run (Seq.bypass Common.maybeNoteExt (fst . Seq.pressed KeySet.groupLatch)) +delay = Seq.run (Seq.delay $ time 0.2) +delayAdd = Seq.run (Seq.delayAdd $ time 0.2) delayTranspose = Seq.run $ \ evs -> let proc p dt = - Seq.delay dt $ - Seq.mapMaybe (Common.transpose p) evs + Seq.delay (time dt) $ + RBU.mapMaybe (Common.transpose p) evs evs1 = proc 4 0.2 evs2 = proc 7 0.4 evs3 = proc 12 0.6 in foldl RB.union (fmap Common.now evs) [evs1, evs2, evs3] -pattern :: - (KeySet.C set) => - set -> Pattern.Mono set i -> ReaderT Common.Handle IO () -pattern set pat = Seq.runM $ \ _times evs -> do +getTempo :: + (Check.C ev) => + RB.Event t ev -> (RB.Behavior t Time.T, RB.Event t ev) +getTempo = + uncurry Seq.tempoCtrl Common.defaultTempoCtrl + (time 0.15) (time 0.5, time 0.05) {- - let tempo = Seq.constant 0.2 + pure 0.2 -} - let tempo = - uncurry Seq.tempoCtrl Common.defaultTempoCtrl 0.15 (0.5,0.05) evs - fmap (RB.union - (fmap Common.singletonBundle $ - RB.filterE (not . Common.checkPitch (const True)) evs)) $ - Seq.patternQuant 0.1 pat tempo (snd $ Seq.pressed set evs) -serialCycleUp = pattern (KeySet.serialLatch 4) (Pattern.cycleUp 4) -cycleUp = pattern KeySet.groupLatch (Pattern.cycleUp 4) -pingPong = pattern KeySet.groupLatch (Pattern.pingPong 4) --- binary = pattern KeySet.groupLatch Pattern.binaryLegato -crossSum = pattern KeySet.groupLatch (Pattern.crossSum 4) -bruijn = pattern KeySet.groupLatch (Pattern.bruijnPat 4 2) +pattern :: + (KeySet.C set) => + set -> + (forall t. + RB.Behavior t set -> + RB.Event t Time.Abs -> + RB.Event t [NoteBoundary]) -> + ReaderT Common.Handle IO () +pattern set pat = Seq.runM $ \ times evs0 -> do + let (tempo, evs1) = getTempo evs0 + beat <- Seq.beatVar times tempo + return $ + Seq.bypass Common.maybeNoteExt + (\notes -> + pat (snd $ Seq.pressed set notes) 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 Common.Handle IO () +cycleUpOffset = Seq.runM $ \ times evs0 -> do + let (tempo, evs1) = getTempo evs0 + n = 4 + range = 3 * fromIntegral n + offset = + fmap round $ + Seq.controllerLinear (channel 0) (controller 17) + (0::Float) (-range,range) evs1 + beat <- Seq.beatVar times tempo + return $ + Seq.bypass Common.maybeNoteExt + (\notes -> + Pattern.mono Pattern.selectFromOctaveChord + (snd $ Seq.pressed KeySet.groupLatch notes) + (pure (\o i -> mod (i-o) n + o) + <*> offset + <@> Pattern.cycleUpIndex (pure n) beat)) evs1 + + +continuousSelect = Seq.runM $ \ _times evs -> + fmap + (Pattern.mono + Pattern.selectFromOctaveChord + (snd $ Seq.pressed KeySet.groupLatch $ + RBU.mapMaybe Common.maybeNoteExt evs)) $ + Seq.uniqueChanges $ + fmap round $ + Seq.controllerLinear (channel 0) (controller 17) (0::Float) (-8,16) evs + +snapSelect = Seq.runM $ \ _times evs -> do + Seq.snapSelect + (snd $ Seq.pressed KeySet.groupLatch $ RBU.mapMaybe Common.maybeNoteExt evs) + (Seq.controllerRaw (channel 0) (controller 17) 64 evs) +{- + let ctrl = Seq.controllerRaw (channel 0) (controller 17) 64 evs + Seq.bypass Common.maybeNoteExt + (\notes -> + Seq.snapSelect (snd $ Seq.pressed KeySet.groupLatch notes) ctrl) evs +-} + +split = Seq.run $ + uncurry RB.union + . + mapFst + (RBU.mapMaybe (Common.transpose 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.runM $ \ times evs0 -> do + let (tempo, evs1) = getTempo evs0 + beat <- Seq.beatVar times tempo + + let checkLeft e = do + bnd <- Common.maybeNoteExt e + case bnd of + NoteBoundaryExt (NoteBoundary (pit,_chan) _vel _on) -> do + guard (pit < pitch 60) + return bnd + _ -> return bnd + + return $ + Seq.bypass checkLeft + (\left -> + fmap (mapMaybe (Common.transpose 12) . map Common.noteFromBnd) $ + Pattern.cycleUp (pure 4) + (snd $ Seq.pressed KeySet.groupLatch left) beat) + evs1 +{- + RBU.mapMaybe (Common.transpose 12) left)) beat +-} + + cyclePrograms = Seq.runM $ \times evs -> return $ -- Seq.cyclePrograms (map program [13..17]) times evs RB.union (RB.filterJust $ - Seq.cycleProgramsDefer 0.1 (map program [13..17]) times evs) + Seq.cycleProgramsDefer (time 0.1) (map program [13..17]) times evs) evs sweep = @@ -111,24 +230,22 @@ (Seq.controllerRaw c centerCC 64 evs))) $ Seq.sweep - 0.01 (sin . (2*pi*)) + (time 0.01) (sin . (2*pi*)) (Seq.controllerExponential c speedCC 0.3 (0.1, 1) evs) guitar = - Seq.run $ \ evs -> + Seq.run $ + Seq.bypass Common.maybeNoteExt $ \notes -> let (trigger, keys) = - Seq.partitionMaybe - (\ev -> - case ev of - Event.NoteEv notePart note -> do - guard $ (note ^. MALSA.notePitch) == pitch 84 - return $ notePart == Event.NoteOn + RBU.partitionMaybe + (\note -> + case note of + NoteBoundaryExt (NoteBoundary (pit,_chan) _vel on) -> do + guard $ pit == pitch 84 + return on _ -> Nothing) - evs - in Seq.guitar 0.03 (snd $ Seq.pressed KeySet.groupLatch keys) trigger - `RB.union` - fmap Common.singletonBundle - (RB.filterE (not . Common.checkPitch (const True)) evs) + notes + in Seq.guitar (time 0.03) (snd $ Seq.pressed KeySet.groupLatch keys) trigger trainer :: (Random.RandomGen g) => @@ -136,4 +253,4 @@ trainer g = Seq.runM $ \ times evs -> fmap (RB.union (fmap Common.singletonBundle evs)) $ - Seq.trainer (channel 0) 0.5 0.3 (Training.all g) times evs + Seq.trainer (channel 0) (time 0.5) (time 0.3) (Training.all g) times evs diff --git a/src/Reactive/Banana/ALSA/KeySet.hs b/src/Reactive/Banana/ALSA/KeySet.hs --- a/src/Reactive/Banana/ALSA/KeySet.hs +++ b/src/Reactive/Banana/ALSA/KeySet.hs @@ -1,27 +1,21 @@ module Reactive.Banana.ALSA.KeySet where -import qualified Reactive.Banana.ALSA.Common as Common - -import qualified Sound.ALSA.Sequencer.Event as Event - -import qualified Sound.MIDI.ALSA as MALSA -import Sound.MIDI.ALSA (normalNoteFromEvent, ) - --- import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg +import Reactive.Banana.ALSA.Common (NoteBoundary(NoteBoundary), ) import Sound.MIDI.Message.Channel (Channel, ) import Sound.MIDI.Message.Channel.Voice (Velocity, Pitch, ) +import qualified Data.Traversable as Trav + import qualified Data.Accessor.Monad.Trans.State as AccState --- import qualified Data.Accessor.Tuple as AccTuple import qualified Data.Accessor.Basic as Acc -import Data.Accessor.Basic ((^.), (^=), ) import qualified Control.Monad.Trans.State as MS import qualified Data.Map as Map import qualified Data.Set as Set +import Data.Maybe.HT (toMaybe, ) import Data.Maybe (maybeToList, ) @@ -37,13 +31,11 @@ -} class C set where - reset :: MS.State set [(Event.NoteEv, Event.Note)] + reset :: MS.State set [NoteBoundary] size :: set -> Int toList :: set -> [((Pitch, Channel), Velocity)] index :: Int -> set -> Maybe ((Pitch, Channel), Velocity) - change :: - Event.NoteEv -> Event.Note -> - MS.State set [(Event.NoteEv, Event.Note)] + change :: NoteBoundary -> MS.State set [NoteBoundary] @@ -64,18 +56,12 @@ case drop k $ Map.toAscList set of x:_ -> Just x _ -> Nothing - change notePart note = - let key = - (note ^. MALSA.notePitch, - note ^. MALSA.noteChannel) - in do - case normalNoteFromEvent notePart note of - (Event.NoteOn, vel) -> - MS.modify $ Pressed . Map.insert key vel . deconsPressed - (Event.NoteOff, _) -> - MS.modify $ Pressed . Map.delete key . deconsPressed - _ -> return () - return [(notePart, note)] + change bnd@(NoteBoundary key vel on) = do + AccState.modify pressedAcc $ + if on + then Map.insert key vel + else Map.delete key + return [bnd] @@ -89,28 +75,18 @@ latchAcc = Acc.fromWrapper Latch deconsLatch latchChange :: - Event.NoteEv -> - Event.Note -> - MS.State Latch (Maybe (Event.NoteEv, Event.Note)) -latchChange notePart note = - case normalNoteFromEvent notePart note of - (Event.NoteOn, vel) -> do - let key = - (note ^. MALSA.notePitch, - note ^. MALSA.noteChannel) - newNote = - (MALSA.noteVelocity ^= vel) note - isPressed <- MS.gets (Map.member key . deconsLatch) - if isPressed - then - MS.modify (Latch . Map.delete key . deconsLatch) >> - return (Just (Event.NoteOff, newNote)) - else - MS.modify (Latch . Map.insert key vel . deconsLatch) >> - return (Just (Event.NoteOn, newNote)) - (Event.NoteOff, _vel) -> - return Nothing - _ -> return Nothing + NoteBoundary -> + MS.State Latch (Maybe NoteBoundary) +latchChange (NoteBoundary key vel on) = + Trav.sequence $ toMaybe on $ do + isPressed <- MS.gets (Map.member key . deconsLatch) + if isPressed + then + AccState.modify latchAcc (Map.delete key) >> + return (NoteBoundary key vel False) + else + AccState.modify latchAcc (Map.insert key vel) >> + return (NoteBoundary key vel True) instance C Latch where reset = AccState.lift latchAcc releasePlayedKeys @@ -120,8 +96,7 @@ case drop k $ Map.toAscList set of x:_ -> Just x _ -> Nothing - change notePart note = - fmap maybeToList $ latchChange notePart note + change = fmap maybeToList . latchChange @@ -160,32 +135,28 @@ case drop k $ Map.toAscList $ groupLatchPlayed_ set of x:_ -> Just x _ -> Nothing - change notePart note = - let key = - (note ^. MALSA.notePitch, - note ^. MALSA.noteChannel) - in case normalNoteFromEvent notePart note of - (Event.NoteOn, vel) -> do - pressd <- AccState.get groupLatchPressed - noteOffs <- - if Set.null pressd - then AccState.lift groupLatchPlayed releasePlayedKeys - else return [] - AccState.modify groupLatchPressed (Set.insert key) - played <- AccState.get groupLatchPlayed - noteOn <- - if Map.member key played - then - return [] - else do - AccState.modify groupLatchPlayed (Map.insert key vel) - return [(Event.NoteOn, note)] - return $ - noteOffs ++ noteOn - (Event.NoteOff, _vel) -> - AccState.modify groupLatchPressed (Set.delete key) >> - return [] - _ -> return [] + change (NoteBoundary key vel on) = + if on + then do + pressd <- AccState.get groupLatchPressed + noteOffs <- + if Set.null pressd + then AccState.lift groupLatchPlayed releasePlayedKeys + else return [] + AccState.modify groupLatchPressed (Set.insert key) + played <- AccState.get groupLatchPlayed + noteOn <- + if Map.member key played + then + return [] + else do + AccState.modify groupLatchPlayed (Map.insert key vel) + return [NoteBoundary key vel True] + return $ + noteOffs ++ noteOn + else + AccState.modify groupLatchPressed (Set.delete key) >> + return [] @@ -226,32 +197,27 @@ size = serialLatchSize_ toList = Map.elems . serialLatchPlayed_ index k = Map.lookup k . serialLatchPlayed_ - change notePart note = - let key = - (note ^. MALSA.notePitch, - note ^. MALSA.noteChannel) - in case normalNoteFromEvent notePart note of - (Event.NoteOn, vel) -> do - n <- MS.gets serialLatchSize_ - k <- AccState.getAndModify serialLatchCursor (flip mod n . (1+)) - oldKey <- fmap (Map.lookup k) $ AccState.get serialLatchPlayed - AccState.modify serialLatchPlayed (Map.insert k (key, vel)) - return $ maybeToList (fmap (uncurry releaseKey) oldKey) - ++ [(notePart, note)] - (Event.NoteOff, _vel) -> return [] - _ -> return [(notePart, note)] + change bnd@(NoteBoundary key vel on) = + if on + then do + n <- MS.gets serialLatchSize_ + k <- AccState.getAndModify serialLatchCursor (flip mod n . (1+)) + oldKey <- fmap (Map.lookup k) $ AccState.get serialLatchPlayed + AccState.modify serialLatchPlayed (Map.insert k (key, vel)) + return $ maybeToList (fmap (uncurry releaseKey) oldKey) + ++ [bnd] + else return [] releasePlayedKeys :: MS.State (Map.Map (Pitch, Channel) Velocity) - [(Event.NoteEv, Event.Note)] + [NoteBoundary] releasePlayedKeys = fmap (map (uncurry releaseKey) . Map.toList) $ AccState.getAndModify Acc.self (const Map.empty) releaseKey :: (Pitch, Channel) -> - Velocity -> - (Event.NoteEv, Event.Note) -releaseKey (p,c) vel = - (Event.NoteOff, Common.simpleNote c p vel) + Velocity -> NoteBoundary +releaseKey key vel = + NoteBoundary key vel False diff --git a/src/Reactive/Banana/ALSA/Pattern.hs b/src/Reactive/Banana/ALSA/Pattern.hs --- a/src/Reactive/Banana/ALSA/Pattern.hs +++ b/src/Reactive/Banana/ALSA/Pattern.hs @@ -4,34 +4,126 @@ import qualified Reactive.Banana.ALSA.DeBruijn as DeBruijn import Reactive.Banana.ALSA.Common - (Time, EventDataBundle, eventsFromKey, splitFraction, increasePitch, ) + (NoteBoundary(NoteBoundary), splitFraction, increasePitch, ) +import qualified Reactive.Banana.ALSA.Utility as RBU +import qualified Reactive.Banana.Combinators as RB +import Reactive.Banana.Combinators ((<@>), ) + +import qualified Sound.MIDI.Message.Channel as ChannelMsg +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg + +import qualified Data.EventList.Absolute.TimeBody as AbsEventList import qualified Data.EventList.Relative.TimeBody as EventList +import qualified Data.EventList.Relative.TimeMixed as EventListTM import Data.EventList.Relative.MixedBody ((/.), (./), ) +import qualified Numeric.NonNegative.Wrapper as NonNegW import qualified Data.List.HT as ListHT import qualified Data.List as List import qualified System.Random as Rnd +import qualified Control.Monad.Trans.State as MS + +import qualified Data.Traversable as Trav +import qualified Data.Foldable as Fold + import Control.Monad (guard, ) +import Control.Applicative (Applicative, pure, (<*>), ) +import Data.Maybe (mapMaybe, maybeToList, ) +import Data.Bool.HT (if', ) +import Data.Ord.HT (comparing, ) import Prelude hiding (init, filter, reverse, ) --- * selectors +-- * reactive patterns -type Selector set i = i -> Time -> set -> EventDataBundle +type T t time set = + RB.Behavior t set -> + RB.Event t time -> + RB.Event t [NoteBoundary] -data Mono set i = Mono (Selector set i) [i] +mono :: + (KeySet.C set) => + Selector set i -> + RB.Behavior t set -> + RB.Event t i -> + RB.Event t [NoteBoundary] +mono select pressed pattern = + fst $ RBU.sequence [] $ + pure + (\set i -> do + off <- MS.get + let mnote = select i set + on = + fmap + (\(key, vel) -> NoteBoundary key vel True) + mnote + MS.put $ fmap + (\(key, _vel) -> NoteBoundary key VoiceMsg.normalVelocity False) + mnote + return $ off ++ on) + <*> pressed + <@> pattern -data IndexNote i = IndexNote Int i +poly :: + (KeySet.C set) => + Selector set i -> + RB.Behavior t set -> + RB.Event t [IndexNote i] -> + RB.Event t [NoteBoundary] +poly select pressed pattern = + fst $ RBU.sequence EventList.empty $ + pure + (\set is -> do + off <- MS.get + let (nowOff, laterOff) = EventListTM.splitAtTime 1 off + sel = concatMap (Trav.traverse (flip select set)) is + on = + fmap + (\(IndexNote _ (key, vel)) -> + NoteBoundary key vel True) + sel + MS.put $ + EventList.mergeBy (\ _ _ -> False) laterOff $ + EventList.fromAbsoluteEventList $ + AbsEventList.fromPairList $ + List.sortBy (comparing fst) $ + map + (\(IndexNote dur (key, _vel)) -> + (dur, NoteBoundary key VoiceMsg.normalVelocity False)) + sel + return $ Fold.toList nowOff ++ on) + <*> pressed + <@> pattern + + + +-- * selectors + +type Selector set i = + i -> set -> [((VoiceMsg.Pitch, ChannelMsg.Channel), VoiceMsg.Velocity)] + + +data IndexNote i = IndexNote NonNegW.Int i deriving (Show, Eq, Ord) +instance Functor IndexNote where + fmap f (IndexNote d i) = IndexNote d $ f i + +instance Fold.Foldable IndexNote where + foldMap = Trav.foldMapDefault + +instance Trav.Traversable IndexNote where + sequenceA (IndexNote d i) = fmap (IndexNote d) i + + item :: i -> Int -> IndexNote i -item i n = IndexNote n i +item i n = IndexNote (NonNegW.fromNumberMsg "Pattern.item" n) i data Poly set i = Poly (Selector set i) (EventList.T Int [IndexNote i]) @@ -44,8 +136,8 @@ selectFromOctaveChord :: KeySet.C set => Selector set Int -selectFromOctaveChord d dur chord = - maybe [] (eventsFromKey 0 dur) $ do +selectFromOctaveChord d chord = + maybeToList $ do let size = KeySet.size chord guard (size>0) let (q,r) = divMod d size @@ -56,29 +148,29 @@ selectFromChord :: KeySet.C set => Selector set Int -selectFromChord n dur chord = - maybe [] (eventsFromKey 0 dur) (KeySet.index n chord) +selectFromChord n chord = + maybeToList $ KeySet.index n chord selectFromChordRatio :: KeySet.C set => Selector set Double -selectFromChordRatio d dur chord = - selectFromChord (floor $ d * fromIntegral (KeySet.size chord)) dur chord +selectFromChordRatio d chord = + selectFromChord (floor $ d * fromIntegral (KeySet.size chord)) chord selectInversion :: KeySet.C set => Selector set Double -selectInversion d dur chord = +selectInversion d chord = let makeNote octave ((pit,chan), vel) = - maybe [] - (\pitchTrans -> eventsFromKey 0 dur ((pitchTrans,chan), vel)) + fmap + (\pitchTrans -> ((pitchTrans,chan), vel)) (increasePitch (octave*12) pit) (oct,p) = splitFraction d pivot = floor (p * fromIntegral (KeySet.size chord)) (low,high) = splitAt pivot $ KeySet.toList chord - in concatMap (makeNote oct) high ++ - concatMap (makeNote (oct+1)) low + in mapMaybe (makeNote oct) high ++ + mapMaybe (makeNote (oct+1)) low @@ -100,77 +192,94 @@ in z ++ recourse (y++z) in [0] ++ recourse [0] -{- | -@bruijn n k@ is a sequence with length n^k -where @cycle (bruijn n k)@ contains all n-ary numbers with k digits as infixes. -The function computes the lexicographically smallest of such sequences. --} -bruijn :: Int -> Int -> [Int] -bruijn n k = DeBruijn.lexLeast n k +cycleUpIndex, cycleDownIndex, pingPongIndex :: + RB.Behavior t Int -> + RB.Event t time -> + RB.Event t Int +cycleUpIndex numbers times = + fst $ RB.mapAccum 0 $ + pure + (\number _time i -> (i, mod (succ i) (max 1 number))) + <*> numbers + <@> times +cycleDownIndex numbers times = + RB.accumE 0 $ + pure + (\number _time i -> mod (pred i) (max 1 number)) + <*> numbers + <@> times + +pingPongIndex numbers times = + fst $ RB.mapAccum (0,1) $ + pure + (\number _time (i,d0) -> + (i, let j = i+d0 + d1 = + if' (j>=number) (-1) $ + if' (j<0) 1 d0 + in (i+d1, d1))) + <*> numbers + <@> times + +crossSumIndex :: + RB.Behavior t Int -> + RB.Event t time -> + RB.Event t Int +crossSumIndex numbers times = + pure + (\number i -> + let m = fromIntegral number + in if m <= 1 + then 0 + else fromInteger $ flip mod m $ sum $ decomposePositional m i) + <*> numbers + <@> fromList [0..] times + + +crossSumStaticIndex :: + Int -> + RB.Event t time -> + RB.Event t Int +crossSumStaticIndex number = + fromList (flipSeq number) + +fromList :: [a] -> RB.Event t time -> RB.Event t a +fromList xs times = + RB.filterJust $ fst $ RB.mapAccum xs $ + fmap + (\_time xs0 -> + case xs0 of + [] -> (Nothing, []) + x:xs1 -> (Just x, xs1)) + times + + cycleUp, cycleDown, pingPong, crossSum :: KeySet.C set => - Int -> Mono set Int -cycleUp number = - Mono selectFromChord (cycle [0..(number-1)]) -cycleDown number = - Mono selectFromChord (cycle $ List.reverse [0..(number-1)]) -pingPong number = - Mono selectFromChord $ - cycle $ [0..(number-2)] ++ List.reverse [1..(number-1)] -crossSum number = - Mono selectFromChord (flipSeq number) + RB.Behavior t Int -> T t time set +cycleUp numbers sets times = + mono selectFromChord sets (cycleUpIndex numbers times) +cycleDown numbers sets times = + mono selectFromChord sets (cycleDownIndex numbers times) +pingPong numbers sets times = + mono selectFromChord sets (pingPongIndex numbers times) +crossSum numbers sets times = + mono selectFromChord sets (crossSumIndex numbers times) -bruijnPat :: +bruijn :: KeySet.C set => - Int -> Int -> Mono set Int -bruijnPat n k = - Mono selectFromChord $ cycle $ bruijn n k + Int -> Int -> T t time set +bruijn n k sets times = + mono selectFromChord sets $ + fromList (cycle $ DeBruijn.lexLeast n k) times -{- -We should increment the index at each step and wrap around according to current chord. -This way we avoid jumps in the pattern. -cycleUpAuto, cycleDownAuto, pingPongAuto, crossSumAuto :: - KeySet.C set => - Mono set Integer -cycleUpAuto = - Mono - (\ d dur chord -> - selectFromChord (mod d (fromIntegral $ length chord)) dur chord) - [0..] -cycleDownAuto = - Mono - (\ d dur chord -> - selectFromChord (mod d (fromIntegral $ length chord)) dur chord) - [0,(-1)..] -pingPongAuto = - Mono - (\ d dur chord -> - let s = 2 * (fromIntegral (length chord) - 1) - m = - if s<=0 - then 0 - else min (mod d s) (mod (-d) s) - in selectFromChord m dur chord) - [0..] -crossSumAuto = - Mono - (\ d dur chord -> - let m = fromIntegral $ length chord - s = - if m <= 1 - then 0 - else sum $ decomposePositional m d - in selectFromChord (mod s m) dur chord) - [0..] --} - binaryStaccato, binaryLegato, binaryAccident :: - KeySet.C set => Poly set Int + KeySet.C set => T t time set {- -binary number Pattern.Mono: +binary number Pattern.T: 0 1 0 1 @@ -180,11 +289,11 @@ 0 1 2 3 -} -binaryStaccato = - Poly +binaryStaccato sets times = + poly selectFromChord - (EventList.fromPairList $ - zip (0 : repeat 1) $ + sets + (flip fromList times $ map (map (IndexNote 1 . fst) . List.filter ((/=0) . snd) . @@ -192,11 +301,11 @@ decomposePositional 2) [0..]) -binaryLegato = - Poly +binaryLegato sets times = + poly selectFromChord - (EventList.fromPairList $ - zip (0 : repeat 1) $ + sets + (flip fromList times $ map (\m -> map (uncurry IndexNote) $ @@ -209,11 +318,11 @@ This was my first try to implement binaryLegato. It was not what I wanted, but it sounded nice. -} -binaryAccident = - Poly +binaryAccident sets times = + poly selectFromChord - (EventList.fromPairList $ - zip (0 : repeat 1) $ + sets + (flip fromList times $ map (zipWith IndexNote (iterate (2*) 1) . map fst . @@ -234,14 +343,17 @@ cycleUpOctave :: KeySet.C set => - Int -> Mono set Int -cycleUpOctave number = - Mono selectFromOctaveChord (cycle [0..(number-1)]) + RB.Behavior t Int -> T t time set +cycleUpOctave numbers sets times = + mono selectFromOctaveChord sets (cycleUpIndex numbers times) + random, randomInversions :: - KeySet.C set => Mono set Double -random = - Mono selectFromChordRatio (Rnd.randomRs (0,1) (Rnd.mkStdGen 42)) + KeySet.C set => T t time set +random sets times = + mono selectFromChordRatio sets $ + fst $ RB.mapAccum (Rnd.mkStdGen 42) $ + fmap (const $ Rnd.randomR (0,1)) times randomInversions = inversions $ @@ -250,14 +362,14 @@ Rnd.randomRs (-1,1) $ Rnd.mkStdGen 42 -cycleUpInversions :: KeySet.C set => Int -> Mono set Double +cycleUpInversions :: KeySet.C set => Int -> T t time set cycleUpInversions n = inversions $ cycle $ take n $ map (\i -> fromInteger i / fromIntegral n) [0..] -inversions :: KeySet.C set => [Double] -> Mono set Double -inversions rs = - Mono selectInversion rs +inversions :: KeySet.C set => [Double] -> T t time set +inversions rs sets times = + mono selectInversion sets (fromList rs times) 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,16 +1,18 @@ {-# 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.Pattern as Pattern 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 as RB -import qualified Reactive.Banana.Model as RBM -import qualified Reactive.Banana.Implementation as RBI -import Reactive.Banana.Model ((<@>), ) +import qualified Reactive.Banana.Combinators as RB +import qualified Reactive.Banana.Frameworks as RBF +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 @@ -20,7 +22,8 @@ import Sound.MIDI.Message.Channel (Channel, ) import Sound.MIDI.Message.Channel.Voice - (Pitch, Controller, Velocity, Program, normalVelocity, ) + (Pitch, Controller, Velocity, Program, normalVelocity, + fromPitch, toPitch, ) import qualified Data.EventList.Relative.TimeBody as EventList import qualified Data.EventList.Absolute.TimeBody as EventListAbs @@ -35,16 +38,18 @@ import Control.Monad.Trans.Reader (ReaderT(ReaderT), ) import Control.Monad.IO.Class (MonadIO, liftIO, ) import Control.Monad.Fix (MonadFix, ) -import Control.Monad (forever, when, ) -import Control.Monad.HT ((<=<), ) -import Control.Applicative (Applicative, pure, (<*>), ) -import Data.Tuple.HT (mapPair, ) +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.Word (Word32, ) +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, ) @@ -53,113 +58,147 @@ -- * make ALSA reactive -newtype Reactor a = +newtype Reactor t a = Reactor { runReactor :: MR.ReaderT - (RBI.AddHandler Event.T, Common.Handle) - (MS.StateT Schedule RBI.NetworkDescription) + (RBF.AddHandler Event.T, Common.Handle) + (MS.StateT Schedule (RBF.NetworkDescription t)) a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix) + +liftNetworkDescription :: RBF.NetworkDescription 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 -getHandle :: Reactor Common.Handle +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) => - (RB.Event Event.Data -> RB.Event ev) -> + (forall 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) => - (RB.Behavior Common.TimeAbs -> - RB.Event Event.Data -> Reactor (RB.Event ev)) -> + (forall t. + RB.Behavior t Time.Abs -> + RB.Event t Event.Data -> Reactor t (RB.Event t ev)) -> ReaderT Common.Handle IO () runM f = do Common.startQueue MR.ReaderT $ \h -> do - (addEventHandler, runEventHandler) <- RBI.newAddHandler - (addEchoHandler, runEchoHandler) <- RBI.newAddHandler - (addTimeHandler, runTimeHandler) <- RBI.newAddHandler - RBI.actuate <=< RBI.compile $ do + (addEventHandler, runEventHandler) <- RBF.newAddHandler + (addEchoHandler, runEchoHandler) <- RBF.newAddHandler + (addTimeHandler, runTimeHandler) <- RBF.newAddHandler + RBF.actuate =<< RBF.compile (do time <- fmap (RB.stepper 0) $ - RBI.fromAddHandler addTimeHandler + RBF.fromAddHandler addTimeHandler evs <- - flip MS.evalStateT (Schedule 0) + flip MS.evalStateT startSchedule . flip MR.runReaderT (addEchoHandler, h) . runReactor . f time . fmap Event.body - =<< RBI.fromAddHandler addEventHandler - RBI.reactimate $ - pure (outputEvents h) <*> time <@> evs + =<< RBF.fromAddHandler addEventHandler + RBF.reactimate $ + pure (outputEvents h) <*> time <@> evs) forever $ do ev <- Event.input (Common.sequ h) - runTimeHandler $ Common.timeFromStamp $ Event.timestamp ev + 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 -> Common.TimeAbs -> evs -> IO () + 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 (Common.incTime dt time) body) $ + Common.makeEvent h (Time.inc dt time) body) $ Common.flattenEvents evs _ <- Event.drainOutput (Common.sequ h) return () checkSchedule :: Schedule -> Event.T -> Bool -checkSchedule (Schedule sched) echo = +checkSchedule sched echo = maybe False (sched ==) $ do - Event.CustomEv Event.Echo s <- Just $ Event.body echo - let Event.Custom echoSchedule 0 0 = s - return echoSchedule - -scheduleData :: Schedule -> Event.Custom -scheduleData (Schedule sched) = - Event.Custom sched 0 0 + Event.CustomEv Event.Echo _ <- Just $ Event.body echo + return $ Event.tag echo -reactimate :: RB.Event (IO ()) -> Reactor () +reactimate :: RB.Event t (IO ()) -> Reactor t () reactimate evs = - Reactor $ MT.lift $ MT.lift $ RB.reactimate evs + Reactor $ MT.lift $ MT.lift $ RBF.reactimate evs -sendEchos :: Common.Handle -> Schedule -> [Common.TimeAbs] -> IO () +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 (scheduleData sched) + (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.setOutput + Remove.setEventType Event.Echo + Remove.setTag sched + reserveSchedule :: - Reactor (RB.Event Common.TimeAbs, [Common.TimeAbs] -> IO ()) + Reactor t (RB.Event t Time.Abs, [Time.Abs] -> IO (), IO ()) reserveSchedule = Reactor $ ReaderT $ \(addH,h) -> do sched <- MS.get - MS.modify succ + MS.modify nextSchedule eEcho <- MT.lift $ - fmap (fmap (Common.timeFromStamp . Event.timestamp) . + fmap (fmap Time.fromEvent . RB.filterE (checkSchedule sched)) $ - RBI.fromAddHandler addH - return (eEcho, sendEchos h sched) + RBF.fromAddHandler addH + return (eEcho, sendEchos h sched, cancelEchos h sched) scheduleQueue :: Show a => - RB.Behavior Common.TimeAbs -> - RB.Event (Common.Bundle a) -> Reactor (RB.Event 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 + (eEcho, send, _) <- reserveSchedule let -- maintain queue and generate Echo events remove echoTime = MS.state $ uncurry $ \_lastTime -> @@ -167,29 +206,30 @@ (error "scheduleQueue: received more events than sent") (\(_t,x) xs -> ((Just x, debug $ "got echo for event: " ++ show x), - ({- Common.incTime t lastTime -} + ({- Time.inc t lastTime -} echoTime, xs))) add time new = do MS.modify $ \(lastTime, old) -> (time, Common.mergeStable - (EventList.fromAbsoluteEventList $ + (EventList.mapTime (Time.cons "scheduleQueue") $ + EventList.fromAbsoluteEventList $ EventListAbs.fromPairList $ - map (\(Common.Future dt a) -> (dt,a)) $ + map (\(Common.Future dt a) -> (Time.decons dt, a)) $ List.sortBy (comparing Common.futureTime) new) $ EventList.decreaseStart - (Common.consTime "Causal.process.decreaseStart" + (Time.cons "Causal.process.decreaseStart" (time-lastTime)) old) - return (Nothing, send $ map (flip Common.incTime time . Common.futureTime) new) + 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) = - sequence (0, EventList.empty) $ + RBU.sequence (0, EventList.empty) $ RB.union (fmap remove eEcho) (pure add <*> times <@> e) reactimate $ fmap snd eEchoEvent - return $ RB.filterJust $ fmap fst eEchoEvent + return $ RBU.mapMaybe fst eEchoEvent debug :: String -> IO () @@ -198,38 +238,13 @@ -- putStrLn --- * utility functions - -mapMaybe :: - (RB.FRP f) => (a -> Maybe b) -> RBM.Event f a -> RBM.Event f b -mapMaybe f = RB.filterJust . fmap f - -partitionMaybe :: - (RB.FRP f) => - (a -> Maybe b) -> RBM.Event f a -> (RBM.Event f b, RBM.Event f a) -partitionMaybe f = - (\x -> - (mapMaybe fst x, - mapMaybe (\(mb,a) -> maybe (Just a) (const Nothing) mb) x)) . - fmap (\a -> (f a, a)) - -traverse :: - (RB.FRP f) => - s -> (a -> MS.State s b) -> RBM.Event f a -> - (RBM.Event f b, RBM.Behavior f s) -traverse s f = sequence s . fmap f - -sequence :: - (RB.FRP f) => - s -> RBM.Event f (MS.State s a) -> - (RBM.Event f a, RBM.Behavior f s) -sequence s = - RB.mapAccum s . fmap MS.runState - -constant :: - (RB.FRP f) => - a -> RBM.Behavior f a -constant a = RB.stepper a RB.never +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 @@ -238,37 +253,24 @@ register pressed keys -} pressed :: - (RB.FRP f, KeySet.C set) => + (KeySet.C set) => set -> - RBM.Event f Event.Data -> - (RBM.Event f [Event.Data], RBM.Behavior f set) + RB.Event f Common.NoteBoundaryExt -> + (RB.Event f [Common.NoteBoundary], RB.Behavior f set) pressed empty = - traverse empty + RBU.traverse empty (\e -> case e of - Event.NoteEv notePart note -> - fmap (map (uncurry Event.NoteEv)) $ - KeySet.change notePart note - body -> - if Common.isAllNotesOff body - then fmap (map (uncurry Event.NoteEv)) - KeySet.reset - else return [e]) + Common.NoteBoundaryExt bnd -> KeySet.change bnd + Common.AllNotesOff -> KeySet.reset) latch :: - (RB.FRP f) => - RBM.Event f Event.Data -> - (RBM.Event f Event.Data, RBM.Behavior f (Map.Map (Pitch, Channel) Velocity)) + 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) . - traverse KeySet.latch - (\e -> do - _ <- case e of - Event.NoteEv notePart note -> - fmap (fmap (uncurry Event.NoteEv)) $ - KeySet.latchChange notePart note - _ -> return Nothing - return $ Just e) + RBU.traverse KeySet.latch KeySet.latchChange {- | Demonstration of scheduleQueue, @@ -276,22 +278,22 @@ since this uses precisely timed delivery by ALSA. -} delaySchedule :: - Common.Time -> - RB.Behavior Common.TimeAbs -> - RB.Event Event.Data -> Reactor (RB.Event Event.Data) + 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 :: - Common.Time -> - RB.Event ev -> RB.Event (Common.Future ev) + Time.T -> + RB.Event t ev -> RB.Event t (Common.Future ev) delay dt = fmap (Common.Future dt) delayAdd :: - Common.Time -> - RB.Event ev -> RB.Event (Common.Future ev) + Time.T -> + RB.Event t ev -> RB.Event t (Common.Future ev) delayAdd dt evs = RB.union (fmap Common.now evs) $ delay dt evs @@ -301,17 +303,16 @@ The output events hold the times, where they occur. -} beat :: - RB.Behavior Common.Time -> Reactor (RB.Event Common.TimeAbs) + RB.Behavior t Time.T -> Reactor t (RB.Event t Time.Abs) beat tempo = do - (eEcho, send) <- reserveSchedule + (eEcho, send, _) <- reserveSchedule liftIO $ send [0] let next dt time = - (time, send [Common.incTime dt time]) + (time, send [Time.inc dt time]) - eEchoEvent = - RB.apply (fmap next tempo) eEcho + eEchoEvent = fmap next tempo <@> eEcho reactimate $ fmap snd eEchoEvent return $ fmap fst eEchoEvent @@ -324,16 +325,16 @@ {- Instead of this we could use the reciprocal of Time, that is frequency, and integrate that. -But integration of a piecewise constant function means a linear function. +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 :: - Common.Time -> - RB.Behavior Common.Time -> Reactor (RB.Event Common.TimeAbs) + Time.T -> + RB.Behavior t Time.T -> Reactor t (RB.Event t Time.Abs) beatQuant maxDur tempo = do - (eEcho, send) <- reserveSchedule + (eEcho, send, _) <- reserveSchedule liftIO $ send [0] @@ -341,30 +342,88 @@ complete <- MS.gets (>=1) when complete $ MS.modify (subtract 1) portion <- MS.get - let dur = limit (0,maxDur) (Common.scaleTimeCeiling (1-portion) dt) - MS.modify (fromRational (Common.deconsTime dur / Common.deconsTime dt) +) + let dur = limit (mempty,maxDur) (Time.scaleCeiling (1-portion) dt) + MS.modify (Time.div dur dt +) return (toMaybe complete time, - send [Common.incTime dur time] + send [Time.inc dur time] {- print (dur, time, dt, portion) -} ) eEchoEvent = - fst $ sequence 0 $ RB.apply (fmap next tempo) eEcho + fst $ RBU.sequence 0 $ fmap next tempo <@> eEcho reactimate $ fmap snd eEchoEvent - return $ RB.filterJust $ fmap fst 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 :: + 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 -> + MS.State + (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) + return + (Nothing, + cancel >> + send [Time.inc (Time.scale r1 p1) t1]) + + eEchoEvent = + fst $ RBU.sequence (0, 0, tempoInit) $ + RB.union + (fmap next eEcho) + (fmap (flip change) time <@> tempoChanges) + + reactimate $ fmap snd eEchoEvent + return $ RBU.mapMaybe fst eEchoEvent + + tempoCtrl :: (Check.C ev) => Channel -> Controller -> - Common.Time -> (Common.Time, Common.Time) -> - RB.Event ev -> RB.Behavior Common.Time + 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) = - RB.stepper deflt . - RB.filterJust . - fmap (fmap (Common.ctrlDur (lower, upper)) + mapFst (RB.stepper deflt) . + RBU.partitionMaybe + (fmap (Common.ctrlDur (lower, upper)) . Check.controller chan ctrl) @@ -373,22 +432,22 @@ Channel -> Controller -> Int -> - RB.Event ev -> RB.Behavior Int + RB.Event t ev -> RB.Behavior t Int controllerRaw chan ctrl deflt = - RB.stepper deflt . RB.filterJust . - fmap (Check.controller chan ctrl) + RB.stepper deflt . + RBU.mapMaybe (Check.controller chan ctrl) controllerExponential :: (Floating a, Check.C ev) => Channel -> Controller -> a -> (a,a) -> - RB.Event ev -> RB.Behavior 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 . - RB.filterJust . - fmap (fmap ((lower*) . exp . (k*) . fromIntegral) + RBU.mapMaybe + (fmap ((lower*) . exp . (k*) . fromIntegral) . Check.controller chan ctrl) controllerLinear :: @@ -396,64 +455,21 @@ Channel -> Controller -> a -> (a,a) -> - RB.Event ev -> RB.Behavior a + RB.Event t ev -> RB.Behavior t a controllerLinear chan ctrl deflt (lower,upper) = let k = (upper-lower) / 127 in RB.stepper deflt . - RB.filterJust . - fmap (fmap ((lower+) . (k*) . fromIntegral) + RBU.mapMaybe + (fmap ((lower+) . (k*) . fromIntegral) . Check.controller chan ctrl) -pattern :: - (KeySet.C set) => - Pattern.Mono set i -> - RB.Behavior Common.Time -> - RB.Behavior set -> - Reactor (RB.Event Common.EventDataBundle) -pattern pat tempo sets = - fmap (patternAux pat tempo sets) $ - beat tempo - -patternQuant :: - (KeySet.C set) => - Common.Time -> - Pattern.Mono set i -> - RB.Behavior Common.Time -> - RB.Behavior set -> - Reactor (RB.Event Common.EventDataBundle) -patternQuant quant pat tempo sets = - fmap (patternAux pat tempo sets) $ - beatQuant quant tempo - -patternAux :: - (KeySet.C set) => - Pattern.Mono set i -> - RB.Behavior Common.Time -> - RB.Behavior set -> - RB.Event Common.TimeAbs -> - RB.Event Common.EventDataBundle -patternAux (Pattern.Mono select ixs) tempo sets times = - pure - (\dur set i -> select i dur set) - <*> tempo - <*> sets - <@> (RB.filterJust $ fst $ - RB.mapAccum ixs $ - fmap (\ _time is -> - case is of - [] -> (Nothing, is) - i:rest -> (Just i, rest)) - times) - - - cyclePrograms :: [Program] -> - RB.Event Event.Data -> RB.Event (Maybe Event.Data) + RB.Event t Event.Data -> RB.Event t (Maybe Event.Data) cyclePrograms pgms = fst . - traverse (cycle pgms) + RBU.traverse (cycle pgms) (Common.traverseProgramsSeek (length pgms)) @@ -471,12 +487,12 @@ the program would be reset to the initial program. -} cycleProgramsDefer :: - Common.Time -> [Program] -> - RB.Behavior Common.TimeAbs -> - RB.Event Event.Data -> RB.Event (Maybe Event.Data) + Time.T -> [Program] -> + RB.Behavior t Time.Abs -> + RB.Event t Event.Data -> RB.Event t (Maybe Event.Data) cycleProgramsDefer defer pgms times = fst . - traverse (cycle pgms, 0) + RBU.traverse (cycle pgms, 0) (\(eventTime,e) -> case e of Event.CtrlEv Event.PgmChange ctrl -> @@ -490,7 +506,7 @@ case fst $ normalNoteFromEvent notePart note of Event.NoteOn -> do AccState.set AccTuple.second $ - Common.incTime defer eventTime + Time.inc defer eventTime AccState.lift AccTuple.first $ Common.nextProgram note _ -> return Nothing @@ -517,11 +533,11 @@ return $ PitchChannel ((p',c), v) noteSequence :: - Common.Time -> + Time.T -> Event.NoteEv -> [Event.Note] -> Common.EventDataBundle noteSequence stepTime onOff = - zipWith Common.Future (iterate (stepTime+) 0) . + zipWith Common.Future (iterate (mappend stepTime) mempty) . map (Event.NoteEv onOff) {- | @@ -546,13 +562,13 @@ -} guitar :: (KeySet.C set) => - Common.Time -> - RB.Behavior set -> - RB.Event Bool -> - RB.Event Common.EventDataBundle + Time.T -> + RB.Behavior t set -> + RB.Event t Bool -> + RB.Event t Common.EventDataBundle guitar stepTime pressd trigger = fst $ - traverse [] + RBU.traverse [] (\(set, on) -> do played <- MS.get let toPlay = @@ -590,7 +606,7 @@ possible tasks: - - replay a sequence of pitches on the keyboard: + - 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 @@ -627,11 +643,11 @@ -} trainer :: Channel -> - Common.Time -> Common.Time -> + Time.T -> Time.T -> [([Pitch], [Pitch])] -> - RB.Behavior Common.TimeAbs -> - RB.Event Event.Data -> - Reactor (RB.Event Common.EventDataBundle) + 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 @@ -641,15 +657,15 @@ (\t p -> Common.eventsFromKey t duration ((p,chan), normalVelocity)) - (iterate (duration+) pause) target, - pause + duration * fromIntegral (length target)) - [] -> ([], 0) + (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 (traverse (sets0, [], Common.incTime initIgnoreUntil 0)) + flip (RBU.traverse (sets0, [], Time.inc initIgnoreUntil 0)) (fmap (,) times <@> evs0) $ \(time,ev) -> case ev of Event.NoteEv notePart note -> @@ -674,7 +690,7 @@ fmap makeSeq $ AccState.get AccTuple.first3 AccState.set AccTuple.third3 $ - Common.incTime newIgnoreUntil time + Time.inc newIgnoreUntil time return notes else return [] _ -> return [] @@ -683,13 +699,13 @@ sweep :: - Common.Time -> + Time.T -> (Double -> Double) -> - RB.Behavior Double -> - Reactor (RB.Event Common.TimeAbs, RB.Behavior Double) + RB.Behavior t Double -> + Reactor t (RB.Event t Time.Abs, RB.Behavior t Double) sweep dur wave speed = do - bt <- beat $ constant dur - let durD = realToFrac $ Common.deconsTime dur + bt <- beat $ pure dur + let durD = realToFrac $ Time.decons dur return (bt, fmap wave $ RB.accumB 0 $ @@ -697,10 +713,10 @@ makeControllerLinear :: Channel -> Controller -> - RB.Behavior Int -> - RB.Behavior Int -> - RB.Event Common.TimeAbs -> RB.Behavior Double -> - RB.Event Event.Data + 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 = pure (\y depth center _time -> @@ -712,3 +728,57 @@ <*> 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 :: + (KeySet.C set) => + RB.Behavior t set -> + RB.Behavior t Int -> + Reactor t (RB.Event t [Event.Data]) +-- RBF.NetworkDescription 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 $ + liftA2 + (\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 :: + (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 diff --git a/src/Reactive/Banana/ALSA/Time.hs b/src/Reactive/Banana/ALSA/Time.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/ALSA/Time.hs @@ -0,0 +1,80 @@ +module Reactive.Banana.ALSA.Time where + +import qualified Sound.ALSA.Sequencer.Event as Event +import qualified Sound.ALSA.Sequencer.RealTime as RealTime +import qualified Sound.ALSA.Sequencer.Time as ATime + +import qualified Numeric.NonNegative.Class as NonNeg + +import qualified Data.Monoid as Mn +import Data.Ratio ((%), ) + +import Prelude hiding (div, ) + +{- | +The 'T' types are used instead of floating point types, +because the latter ones caused unpredictable 'negative number' errors. +The denominator must always be a power of 10, +this way we can prevent unlimited grow of denominators. +-} +type Abs = Rational +newtype T = Cons {decons :: Rational} + deriving (Show, Eq, Ord) + +cons :: String -> Rational -> T +cons msg x = + if x>=0 + then Cons x + else error $ msg ++ ": negative number" + +inc :: T -> Abs -> Abs +inc dt t = t + decons dt + +subSat :: Abs -> Abs -> T +subSat t1 t0 = cons "Time.sub" $ max 0 $ t1 - t0 + +scale :: Double -> T -> T +scale k (Cons t) = + cons "Time.scale" $ round (toRational k * t * nano) % nano + +scaleCeiling :: Double -> T -> T +scaleCeiling k (Cons t) = + cons "Time.scaleCeiling" $ ceiling (toRational k * t * nano) % nano + +scaleInt :: Integral i => i -> T -> T +scaleInt k (Cons t) = + cons "Time.scaleInt" $ t * fromIntegral k + +div :: T -> T -> Double +div dt1 dt0 = + fromRational (decons dt1 / decons dt0) + +nano :: Num a => a +nano = 1000^(3::Int) + +instance Mn.Monoid T where + mempty = Cons 0 + mappend (Cons x) (Cons y) = Cons (x+y) + +instance NonNeg.C T where + split = NonNeg.splitDefault decons Cons + + +fromStamp :: ATime.Stamp -> Abs +fromStamp t = + case t of + ATime.Real rt -> + RealTime.toInteger rt % nano +-- _ -> 0, + _ -> error "unsupported time stamp type" + +toStamp :: Abs -> ATime.Stamp +toStamp t = + ATime.Real (RealTime.fromInteger (round (t*nano))) + + +fromEvent :: Event.T -> Abs +fromEvent ev = + case Event.time ev of + ATime.Cons ATime.Absolute stamp -> fromStamp stamp + _ -> error "timeFromEvent: we can only handle absolute time stamps" diff --git a/src/Reactive/Banana/ALSA/Utility.hs b/src/Reactive/Banana/ALSA/Utility.hs new file mode 100644 --- /dev/null +++ b/src/Reactive/Banana/ALSA/Utility.hs @@ -0,0 +1,49 @@ +-- basic reactive functions that could as well be in reactive-banana +module Reactive.Banana.ALSA.Utility where + +import qualified Reactive.Banana.Combinators as RB + +import qualified Control.Monad.Trans.State as MS + +import Prelude hiding (sequence, ) + + +partition :: + (a -> Bool) -> RB.Event f a -> (RB.Event f a, RB.Event f a) +partition p = + (\x -> + (fmap snd $ RB.filterE fst x, + fmap snd $ RB.filterE (not . fst) x)) . + fmap (\a -> (p a, a)) + +mapMaybe :: + (a -> Maybe b) -> RB.Event f a -> RB.Event f b +mapMaybe f = RB.filterJust . fmap f + +partitionMaybe :: + (a -> Maybe b) -> RB.Event f a -> (RB.Event f b, RB.Event f a) +partitionMaybe f = + (\x -> + (mapMaybe fst x, + mapMaybe (\(mb,a) -> maybe (Just a) (const Nothing) mb) x)) . + fmap (\a -> (f a, a)) + +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 +bypass p fa fb evs = + let (eb,ea) = partitionMaybe p evs + in RB.union (fb eb) (fa ea) + +traverse :: + s -> (a -> MS.State s b) -> RB.Event f a -> + (RB.Event f b, RB.Behavior f 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) +sequence s = + RB.mapAccum s . fmap MS.runState