reactive-balsa 0.1.1 → 0.2
raw patch · 14 files changed
+315/−2265 lines, 14 filesdep +reactive-midyimdep ~transformersdep ~utility-ht
Dependencies added: reactive-midyim
Dependency ranges changed: transformers, utility-ht
Files
- LICENSE +1/−1
- reactive-balsa.cabal +8/−13
- src/Reactive/Banana/ALSA/Common.hs +50/−419
- src/Reactive/Banana/ALSA/DeBruijn.hs +0/−138
- src/Reactive/Banana/ALSA/Example.hs +117/−85
- src/Reactive/Banana/ALSA/Guitar.hs +0/−37
- src/Reactive/Banana/ALSA/KeySet.hs +0/−223
- src/Reactive/Banana/ALSA/Pattern.hs +0/−403
- src/Reactive/Banana/ALSA/Private.hs +80/−0
- src/Reactive/Banana/ALSA/Sequencer.hs +46/−688
- src/Reactive/Banana/ALSA/Time.hs +13/−55
- src/Reactive/Banana/ALSA/Training.hs +0/−110
- src/Reactive/Banana/ALSA/Trie.hs +0/−44
- src/Reactive/Banana/ALSA/Utility.hs +0/−49
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2012, Henning Thielemann+Copyright (c) 2012-2013, Henning Thielemann All rights reserved.
reactive-balsa.cabal view
@@ -1,5 +1,5 @@ Name: reactive-balsa-Version: 0.1.1+Version: 0.2 License: BSD3 License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de>@@ -40,18 +40,19 @@ Build-Type: Simple Source-Repository head type: darcs- location: http://code.haskell.org/~thielema/reactive-balsa/+ location: http://hub.darcs.net/thielema/reactive-balsa/ Source-Repository this type: darcs- location: http://code.haskell.org/~thielema/reactive-balsa/- tag: 0.1.1+ location: http://hub.darcs.net/thielema/reactive-balsa/+ tag: 0.2 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.8, midi-alsa >=0.2 && <0.3, midi >=0.2 && <0.3,@@ -61,9 +62,9 @@ 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,+ utility-ht >=0.0.8 && <0.1, containers >=0.2 && <0.6,- transformers >=0.2 && <0.4,+ transformers >=0.2 && <0.6, extensible-exceptions >=0.1 && <0.2 If flag(splitBase) Build-Depends:@@ -78,13 +79,7 @@ Exposed-Modules: Reactive.Banana.ALSA.Sequencer Reactive.Banana.ALSA.Example- Reactive.Banana.ALSA.KeySet- 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+ Reactive.Banana.ALSA.Private
src/Reactive/Banana/ALSA/Common.hs view
@@ -1,7 +1,15 @@ module Reactive.Banana.ALSA.Common where -import qualified Reactive.Banana.ALSA.Time as Time+import qualified Reactive.Banana.ALSA.Private as Priv+import Reactive.Banana.ALSA.Private (Handle(..), ) +import qualified Reactive.Banana.ALSA.Time as AlsaTime+import qualified Reactive.Banana.MIDI.Time as Time++import qualified Reactive.Banana.MIDI.Note as Note+import qualified Reactive.Banana.MIDI.Common as Common+import Reactive.Banana.MIDI.Common (VelocityField, singletonBundle, )+ import qualified Sound.ALSA.Sequencer as SndSeq import qualified Sound.ALSA.Sequencer.Address as Addr import qualified Sound.ALSA.Sequencer.Client as Client@@ -17,32 +25,22 @@ 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 import qualified Sound.MIDI.Message.Channel.Mode as Mode -import Sound.MIDI.ALSA (normalNoteFromEvent, )+import Sound.MIDI.ALSA.Construct ()+import Sound.MIDI.ALSA.Query () import Sound.MIDI.Message.Channel (Channel, ) import Sound.MIDI.Message.Channel.Voice (Velocity, Pitch, Controller, Program, ) -import qualified Data.EventList.Relative.TimeBody as EventList- import Data.Accessor.Basic ((^.), (^=), ) -import Control.Monad (mplus, )+import Control.Functor.HT (void, )+import Data.Maybe (maybeToList, ) 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--import qualified Control.Monad.Trans.State as State import qualified Control.Monad.Trans.Reader as Reader import Control.Monad.Trans.Reader (ReaderT, ) -import qualified Numeric.NonNegative.Class as NonNeg- import qualified Data.Monoid as Mn import Prelude hiding (init, filter, reverse, )@@ -50,14 +48,6 @@ -- * helper functions -data Handle =- Handle {- sequ :: SndSeq.T SndSeq.DuplexMode,- client :: Client.T,- portPublic, portPrivate :: Port.T,- queue :: Queue.T- }- init :: IO Handle init = do h <- SndSeq.open SndSeq.defaultName SndSeq.Block@@ -79,7 +69,7 @@ exit :: Handle -> IO () exit h = do- _ <- Event.outputPending (sequ h)+ void $ Event.outputPending (sequ h) Queue.free (sequ h) (queue h) Port.delete (sequ h) (portPublic h) Port.delete (sequ h) (portPrivate h)@@ -114,8 +104,7 @@ startQueue :: ReaderT Handle IO () startQueue = Reader.ReaderT $ \h -> do Queue.control (sequ h) (queue h) Event.QueueStart Nothing- _ <- Event.drainOutput (sequ h)- return ()+ void $ Event.drainOutput (sequ h) {- |@@ -125,9 +114,8 @@ -} connect :: [String] -> [String] -> ReaderT Handle IO () connect fromNames toNames = do- _ <- connectFrom =<< parseAddresses fromNames- _ <- connectTo =<< parseAddresses toNames- return ()+ void $ connectFrom =<< parseAddresses fromNames+ void $ connectTo =<< parseAddresses toNames connectFrom, connectTo :: Addr.T -> ReaderT Handle IO Connect.T connectFrom from = Reader.ReaderT $ \h ->@@ -176,69 +164,47 @@ -- * send single events -sendNote :: Channel -> Time.T -> Velocity -> Pitch -> ReaderT Handle IO ()+sendNote :: Channel -> AlsaTime.RelativeTicks -> Velocity -> Pitch -> ReaderT Handle IO () sendNote chan dur vel pit = let note = simpleNote chan pit vel- t = Time.inc dur 0- in do outputEvent 0 (Event.NoteEv Event.NoteOn note)+ z = Mn.mempty+ t = Time.inc dur z+ in do outputEvent z (Event.NoteEv Event.NoteOn note) outputEvent t (Event.NoteEv Event.NoteOff note) sendKey :: Channel -> Bool -> Velocity -> Pitch -> ReaderT Handle IO () sendKey chan noteOn vel pit =- outputEvent 0 $+ outputEvent Mn.mempty $ Event.NoteEv (if noteOn then Event.NoteOn else Event.NoteOff) (simpleNote chan pit vel) sendController :: Channel -> Controller -> Int -> ReaderT Handle IO () sendController chan ctrl val =- outputEvent 0 $+ outputEvent Mn.mempty $ Event.CtrlEv Event.Controller $ MALSA.controllerEvent chan ctrl (fromIntegral val) sendProgram :: Channel -> Program -> ReaderT Handle IO () sendProgram chan pgm =- outputEvent 0 $+ outputEvent Mn.mempty $ Event.CtrlEv Event.PgmChange $ MALSA.programChangeEvent chan pgm sendMode :: Channel -> Mode.T -> ReaderT Handle IO () sendMode chan mode =- outputEvent 0 $+ outputEvent Mn.mempty $ Event.CtrlEv Event.Controller $ MALSA.modeEvent chan mode --- * constructors--channel :: Int -> Channel-channel = ChannelMsg.toChannel--pitch :: Int -> Pitch-pitch = VoiceMsg.toPitch--velocity :: Int -> Velocity-velocity = VoiceMsg.toVelocity--controller :: Int -> Controller-controller = VoiceMsg.toController--program :: Int -> Program-program = VoiceMsg.toProgram---normalVelocity :: VoiceMsg.Velocity-normalVelocity = VoiceMsg.normalVelocity----defaultTempoCtrl :: (Channel,Controller)-defaultTempoCtrl =- (ChannelMsg.toChannel 0, VoiceMsg.toController 16)-+-- * events +class Reactor reactor where+ reactorTime :: Time.T reactor t a -> Time.T Priv.Reactor t a --- * events+instance Reactor Priv.Reactor where+ reactorTime = id {- | This class unifies several ways of handling multiple events at once.@@ -249,12 +215,16 @@ instance Events Event.Data where flattenEvents = singletonBundle -instance Events NoteBoundary where- flattenEvents = singletonBundle . noteFromBnd+instance+ (Note.Make key, VelocityField value) =>+ Events (Note.Boundary key value) where+ flattenEvents = singletonBundle . Note.fromBnd -instance Events ev => Events (Future ev) where- flattenEvents (Future dt ev) =- map (\(Future t e) -> Future (Mn.mappend t dt) e) $+instance (Reactor m, Events ev) => Events (Common.Future m ev) where+ flattenEvents (Common.Future dt ev) =+ map+ (\(Common.Future t e) ->+ Common.Future (Mn.mappend t $ reactorTime dt) e) $ flattenEvents ev instance Events ev => Events (Maybe ev) where@@ -271,28 +241,27 @@ flattenEvents ev0 ++ flattenEvents ev1 ++ flattenEvents ev2 -makeEvent :: Handle -> Time.Abs -> Event.Data -> Event.T+makeEvent :: Handle -> AlsaTime.AbsoluteTicks -> Event.Data -> Event.T makeEvent h t e = (Event.simple (Addr.Cons (client h) (portPublic h)) e) { Event.queue = queue h- , Event.time = ATime.consAbs $ Time.toStamp t+ , Event.time = ATime.consAbs $ AlsaTime.toStamp t } -makeEcho :: Handle -> Time.Abs -> Event.T+makeEcho :: Handle -> AlsaTime.AbsoluteTicks -> 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.time = ATime.consAbs $ AlsaTime.toStamp t , Event.dest = addr } -outputEvent :: Time.Abs -> Event.Data -> ReaderT Handle IO ()+outputEvent :: AlsaTime.AbsoluteTicks -> Event.Data -> ReaderT Handle IO () outputEvent t ev = Reader.ReaderT $ \h -> Event.output (sequ h) (makeEvent h t ev) >>- Event.drainOutput (sequ h) >>- return ()+ void (Event.drainOutput (sequ h)) simpleNote :: Channel -> Pitch -> Velocity -> Event.Note@@ -303,66 +272,14 @@ (MALSA.fromVelocity v) -{- |-The times are relative to the start time of the bundle-and do not need to be ordered.--}-data Future a = Future {futureTime :: Time.T, futureData :: a}-type Bundle a = [Future a]+type Future = Common.Future Priv.Reactor+type Bundle a = Common.Bundle Priv.Reactor a type EventBundle = Bundle Event.T type EventDataBundle = Bundle Event.Data -singletonBundle :: a -> Bundle a-singletonBundle ev = [now ev] -immediateBundle :: [a] -> Bundle a-immediateBundle = map now--now :: a -> Future a-now = Future Mn.mempty--instance Functor Future where- fmap f (Future dt a) = Future dt $ f a-- -- * effects -{- |-Transpose a note event by the given number of semitones.-Non-note events are returned without modification.-If by transposition a note leaves the range of representable MIDI notes,-then we return Nothing.--}-transpose ::- Int -> Event.Data -> Maybe Event.Data-transpose d e =- case e of- Event.NoteEv notePart note ->- fmap (\p ->- Event.NoteEv notePart $- (MALSA.notePitch ^= p) note) $- increasePitch d $- note ^. MALSA.notePitch- _ -> Just e--{- |-Swap order of keys.-Non-note events are returned without modification.-If by reversing a note leaves the range of representable MIDI notes,-then we return Nothing.--}-reverse ::- Event.Data -> Maybe Event.Data-reverse e =- case e of- Event.NoteEv notePart note ->- fmap (\p ->- Event.NoteEv notePart $- (MALSA.notePitch ^= p) note) $- maybePitch $ (60+64 -) $ VoiceMsg.fromPitch $- note ^. MALSA.notePitch- _ -> Just e- setChannel :: Channel -> Event.Data -> Event.Data setChannel chan e =@@ -375,247 +292,16 @@ (MALSA.ctrlChannel ^= chan) ctrl _ -> e -{- |-> > replaceProgram [1,2,3,4] 5 [10,11,12,13]-> (True,[10,11,2,13])--}-replaceProgram :: Real i => [i] -> i -> [i] -> (Bool, [i])-replaceProgram (n:ns) pgm pt =- let (p,ps) =- case pt of- [] -> (0,[])- (x:xs) -> (x,xs)- in if pgm<n- then (True, pgm:ps)- else mapSnd (p:) $- replaceProgram ns (pgm-n) ps-replaceProgram [] _ ps = (False, ps) -programFromBanks :: Real i => [i] -> [i] -> i-programFromBanks ns ps =- foldr (\(n,p) s -> p+n*s) 0 $- zip ns ps--{- |-Interpret program changes as a kind of bank switches-in order to increase the range of instruments-that can be selected via a block of patch select buttons.--@programAsBanks ns@ divides the first @sum ns@ instruments-into sections of sizes @ns!!0, ns!!1, ...@.-Each program in those sections is interpreted as a bank in a hierarchy,-where the lower program numbers are the least significant banks.-Programs from @sum ns@ on are passed through as they are.-@product ns@ is the number of instruments-that you can address using this trick.-In order to avoid overflow it should be less than 128.--E.g. @programAsBanks [n,m]@ interprets subsequent program changes to-@a@ (@0<=a<n@) and @n+b@ (@0<=b<m@)-as a program change to @b*n+a@.-@programAsBanks [8,8]@ allows to select 64 instruments-by 16 program change buttons,-whereas @programAsBanks [8,4,4]@-allows to address the full range of MIDI 128 instruments-with the same number of buttons.--}-programsAsBanks ::- [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 (fromIntegral $ Event.unValue pgm) ps0- in (Event.CtrlEv Event.PgmChange $- ctrl{Event.ctrlValue =- if valid- then Event.Value $ fromIntegral $ programFromBanks ns ps1- else pgm},- ps1)- _ -> return e---nextProgram :: Event.Note -> State.State [Program] (Maybe Event.Data)-nextProgram note =- State.state $ \pgms ->- case pgms of- pgm:rest ->- (Just $- Event.CtrlEv Event.PgmChange $- Event.Ctrl {- Event.ctrlChannel = Event.noteChannel note,- Event.ctrlParam = Event.Parameter 0,- Event.ctrlValue = MALSA.fromProgram pgm},- rest)- [] -> (Nothing, [])--seekProgram :: Int -> Program -> State.State [Program] (Maybe Event.Data)-seekProgram maxSeek pgm =- fmap (const Nothing) $- State.modify $- uncurry (++) .- mapFst (dropWhile (pgm/=)) .- splitAt maxSeek---{- |-Before every note switch to another instrument-according to a list of programs given as state of the State monad.-I do not know how to handle multiple channels in a reasonable way.-Currently I just switch the instrument independent from the channel,-and send the program switch to the same channel as the beginning note.--}-traversePrograms ::- Event.Data -> State.State [Program] (Maybe Event.Data)-traversePrograms e =- case e of- Event.NoteEv notePart note ->- (case fst $ normalNoteFromEvent notePart note of- Event.NoteOn -> nextProgram note- _ -> return Nothing)- _ -> return Nothing--{- |-This function extends 'traversePrograms'.-It reacts on external program changes-by seeking an according program in the list.-This way we can reset the pointer into the instrument list.-However the search must be limited in order to prevent an infinite loop-if we receive a program that is not contained in the list.--}-traverseProgramsSeek ::- Int ->- Event.Data -> State.State [Program] (Maybe Event.Data)-traverseProgramsSeek maxSeek e =- case e of- Event.NoteEv notePart note ->- case fst $ normalNoteFromEvent notePart note of- Event.NoteOn -> nextProgram note- _ -> return Nothing- Event.CtrlEv Event.PgmChange ctrl ->- seekProgram maxSeek (ctrl ^. MALSA.ctrlProgram)- _ -> return Nothing--reduceNoteVelocity ::- Event.Velocity -> Event.Note -> Event.Note-reduceNoteVelocity (Event.Velocity decay) note =- note{Event.noteVelocity =- let Event.Velocity vel = Event.noteVelocity note- in if vel==0- then Event.offVelocity- else Event.Velocity $ vel - min decay (vel-1)}- delayAdd ::- Event.Velocity -> Time.T -> Event.Data -> EventDataBundle+ Velocity -> AlsaTime.RelativeTicks -> Event.Data -> EventDataBundle delayAdd decay d e = singletonBundle e ++- case e of- Event.NoteEv notePart note ->- [Future d $- Event.NoteEv notePart $- reduceNoteVelocity decay note]- _ -> []+ (maybeToList $ fmap (Common.Future d) $+ Note.lift (Note.reduceVelocity decay) e) -{- |-Map NoteOn events to a controller value.-This way you may play notes via the resonance frequency of a filter.--}-controllerFromNote ::- (Int -> Int) ->- VoiceMsg.Controller ->- Event.Data -> Maybe Event.Data-controllerFromNote f ctrl e =- case e of- Event.NoteEv notePart note ->- case fst $ normalNoteFromEvent notePart note of- Event.NoteOn ->- Just $- Event.CtrlEv Event.Controller $- MALSA.controllerEvent- (note ^. MALSA.noteChannel)- ctrl- (fromIntegral $ f $- fromIntegral $ VoiceMsg.fromPitch $- note ^. MALSA.notePitch)- Event.NoteOff -> Nothing- _ -> Just e- _ -> Just e---type KeySet = Map.Map (Pitch, Channel) Velocity-type KeyQueue = [((Pitch, Channel), Velocity)]--eventsFromKey ::- Time.T -> Time.T -> ((Pitch, Channel), Velocity) ->- EventDataBundle-eventsFromKey start dur ((pit,chan), vel) =- Future start (Event.NoteEv Event.NoteOn $ simpleNote chan pit vel) :- Future (Mn.mappend start dur)- (Event.NoteEv Event.NoteOff $ simpleNote chan pit vel) :- []---maybePitch :: Int -> Maybe Pitch-maybePitch p =- toMaybe- (VoiceMsg.fromPitch minBound <= p &&- p <= VoiceMsg.fromPitch maxBound)- (VoiceMsg.toPitch p)--increasePitch :: Int -> Pitch -> Maybe Pitch-increasePitch d p =- maybePitch $ d + VoiceMsg.fromPitch p--subtractPitch :: Pitch -> Pitch -> Int-subtractPitch p0 p1 =- VoiceMsg.fromPitch p1 - VoiceMsg.fromPitch p0----- | properFraction is useless for negative numbers-splitFraction :: (RealFrac a) => a -> (Int, a)-splitFraction x =- case floor x of- n -> (n, x - fromIntegral n)---fraction :: RealFrac a => a -> a-fraction x =- let n = floor x- in x - fromIntegral (n::Integer)---ctrlDur ::- (Time.T, Time.T) -> Int -> Time.T-ctrlDur = ctrlDurExponential--ctrlDurLinear ::- (Time.T, Time.T) -> Int -> Time.T-ctrlDurLinear (minDur, maxDur) val =- 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.T, Time.T) -> Int -> Time.T-ctrlDurExponential (minDur, maxDur) val =- Time.scale (Time.div maxDur minDur ** (fromIntegral val / 127)) minDur---{--ctrlRange ::- (RealFrac b) =>- (b,b) -> (a -> b) -> (a -> Int)-ctrlRange (l,u) f x =- round $- limit (0,127) $- 127*(f x - l)/(u-l)--}-- -- * predicates - may be moved to midi-alsa package controllerMatch ::@@ -681,58 +367,3 @@ checkMode $ \mode -> 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--mergeStable ::- (NonNeg.C time) =>- EventList.T time body ->- EventList.T time body ->- EventList.T time body-mergeStable =- EventList.mergeBy (\_ _ -> True)--mergeEither ::- (NonNeg.C time) =>- EventList.T time a ->- EventList.T time b ->- EventList.T time (Either a b)-mergeEither xs ys =- mergeStable (fmap Left xs) (fmap Right ys)
− src/Reactive/Banana/ALSA/DeBruijn.hs
@@ -1,138 +0,0 @@-module Reactive.Banana.ALSA.DeBruijn where--import qualified Reactive.Banana.ALSA.Trie as Trie--import qualified Data.List.Match as Match-import qualified Data.List.HT as ListHT-import qualified Data.List as List-import Data.Maybe.HT (toMaybe, )--import qualified Data.Map as Map-import qualified Data.Set as Set--import qualified Data.Bits as Bits-import Data.Bits ((.&.), )--import Control.Monad (guard, replicateM, )--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 $- filter ((0==) . mod k . length) $- takeWhile (not . null) $- iterate (nextLyndonWord n k) [0]--nextLyndonWord :: Int -> Int -> [Int] -> [Int]-nextLyndonWord n k =- foldr- (\x xs ->- if null xs- then (if x<n-1 then [x+1] else [])- else x:xs) [] .- take k . cycle---{- |-All Bruijn sequences with a certain alphabet and a certain length of infixes.--}-all :: Int -> Int -> [[Int]]-all n k =- let start = replicate k 0- go _ str 0 = do- guard $ str==start- return []- go set str c = do- d <- [0 .. n-1]- let newStr = tail str ++ [d]- guard $ Set.notMember newStr set- rest <- go (Set.insert newStr set) newStr (c-1)- return $ d:rest- in map (ListHT.rotate (-k)) $- go Set.empty start (n^k)--allMap :: Int -> Int -> [[Int]]-allMap n k =- let start = replicate k 0- delete d =- Map.update (\set ->- let newSet = Set.delete d set- in toMaybe (not $ Set.null newSet) newSet)- go [] _ = error "infixes must have positive length"- go (_:str) todo =- case Map.lookup str todo of- Nothing -> do- guard $ Map.null todo- return []- Just set -> do- d <- Set.toList set- rest <- go (str ++ [d]) $ delete d str todo- return $ d:rest- in map (take (n^k) . (start ++)) $- go start $- delete 0 (tail start) $- Map.fromAscList $- map (flip (,) $ Set.fromList [0 .. n-1]) $- replicateM (k-1) [0 .. n-1]---allTrie :: Int -> Int -> [[Int]]-allTrie n k =- let start = replicate k 0- go [] _ = error "infixes must have positive length"- go (_:str) todo =- case Trie.lookup str todo of- Nothing -> do- guard $ Trie.null todo- return []- Just set -> do- d <- set- rest <- go (str ++ [d]) $ Trie.delete d str todo- return $ d:rest- in map (take (n^k) . (start ++)) $- go start $- Trie.delete 0 (tail start) $- Trie.full [0 .. n-1] [0 .. n-1] (k-1)---allBits :: Int -> Int -> [[Int]]-allBits n k =- let go code todo =- let shiftedCode = mod (code*n) (n^k)- in case Bits.shiftR todo shiftedCode .&. (2^n-1) of- 0 -> do- guard $ todo == 0- return []- set -> do- d <- [0 .. n-1]- guard $ Bits.testBit set d- rest <-- let newCode = shiftedCode + d- in go newCode $ Bits.clearBit todo newCode- return $ d:rest- in map (take (n^k) . (replicate k 0 ++)) $- go 0 $ (2^n^k-2 :: Integer)----- * tests--testLexLeast :: Int -> Int -> Bool-testLexLeast n k =- lexLeast n k == head (allMap n k)--test :: Int -> Int -> [Int] -> Bool-test n k xs =- replicateM k [0 .. n-1]- ==- (List.sort $ Match.take xs $ map (take k) $ List.tails $ cycle xs)--testAll :: Int -> Int -> Bool-testAll n k =- List.all (test n k) $ allMap n k
src/Reactive/Banana/ALSA/Example.hs view
@@ -1,28 +1,39 @@ {-# 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- (NoteBoundaryExt(NoteBoundaryExt), NoteBoundary(NoteBoundary),- program, channel, pitch, controller, )+import qualified Reactive.Banana.ALSA.Time as AlsaTime -import qualified Reactive.Banana.ALSA.Utility as RBU+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.Frameworks as RBF import qualified Reactive.Banana.Combinators as RB import Reactive.Banana.Combinators ((<@>), ) -import qualified Sound.MIDI.Message.Class.Check as Check+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, )+import Control.Monad (guard, liftM2, liftM3, ) import Control.Applicative (pure, (<*>), ) import Data.Tuple.HT (mapFst, ) import Data.Maybe (mapMaybe, )@@ -30,7 +41,7 @@ import Prelude hiding (reverse, ) -run, runLLVM, runTimidity :: ReaderT Common.Handle IO a -> IO a+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@@ -60,56 +71,72 @@ sweep, guitar, snapSelect,- continuousSelect :: ReaderT Common.Handle IO ()+ continuousSelect :: ReaderT Seq.Handle IO () -time :: Rational -> Time.T-time = Time.cons "example"+time :: Rational -> AlsaTime.RelativeSeconds+time = Time.relative "example" . Time.Seconds +ticks ::+ (RBF.Frameworks t) =>+ Rational -> Seq.Reactor t 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 $ Common.transpose 2-reverse = Seq.run $ RBU.mapMaybe $ Common.reverse--- works, but does not interact nicely with AllNotesOff+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.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 (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]+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+ 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 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)+ (Check.C ev, RBF.Frameworks t) =>+ RB.Event t ev ->+ Seq.Reactor t (RB.Behavior t AlsaTime.RelativeTicks, RB.Event t ev)+getTempo ctrl =+ 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 ->+ set PitchChannel Velocity -> (forall t. (RBF.Frameworks t) =>- RB.Behavior t set ->- RB.Event t Time.Abs ->- RB.Event t [NoteBoundary]) ->- ReaderT Common.Handle IO ()+ RB.Behavior t (set PitchChannel Velocity) ->+ RB.Event t AlsaTime.AbsoluteTicks ->+ RB.Event t [Note.Boundary PitchChannel Velocity]) ->+ ReaderT Seq.Handle IO () pattern set pat = Seq.runM $ \ times evs0 -> do- let (tempo, evs1) = getTempo evs0- beat <- Seq.beatVar times tempo+ (tempo, evs1) <- getTempo evs0+ beat <- Process.beatVar times tempo return $- Seq.bypass Common.maybeNoteExt+ Seq.bypass Note.maybeBndExt (\notes ->- pat (snd $ Seq.pressed set notes) beat) evs1+ pat (snd $ Process.pressed set notes) beat) evs1 serialCycleUp@@ -129,21 +156,21 @@ \set -> Pattern.pingPong (fmap KeySet.size set) set cycleUpOffset ::- ReaderT Common.Handle IO ()+ ReaderT Seq.Handle IO () cycleUpOffset = Seq.runM $ \ times evs0 -> do- let (tempo, evs1) = getTempo evs0- n = 4+ (tempo, evs1) <- getTempo evs0+ let n = 4 range = 3 * fromIntegral n offset = fmap round $- Seq.controllerLinear (channel 0) (controller 17)+ Process.controllerLinear (channel 0) (controller 17) (0::Float) (-range,range) evs1- beat <- Seq.beatVar times tempo+ beat <- Process.beatVar times tempo return $- Seq.bypass Common.maybeNoteExt+ Seq.bypass Note.maybeBndExt (\notes -> Pattern.mono Pattern.selectFromOctaveChord- (snd $ Seq.pressed KeySet.groupLatch notes)+ (snd $ Process.pressed KeySet.groupLatch notes) (pure (\o i -> mod (i-o) n + o) <*> offset <@> Pattern.cycleUpIndex (pure n) beat)) evs1@@ -153,28 +180,28 @@ fmap (Pattern.mono Pattern.selectFromOctaveChord- (snd $ Seq.pressed KeySet.groupLatch $- RBU.mapMaybe Common.maybeNoteExt evs)) $- Seq.uniqueChanges $+ (snd $ Process.pressed KeySet.groupLatch $+ RBU.mapMaybe Note.maybeBndExt evs)) $+ Process.uniqueChanges $ fmap round $- Seq.controllerLinear (channel 0) (controller 17) (0::Float) (-8,16) evs+ Process.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)+ Process.snapSelect+ (snd $ Process.pressed KeySet.groupLatch $ RBU.mapMaybe Note.maybeBndExt evs)+ (Process.controllerRaw (channel 0) (controller 17) 64 evs) {-- let ctrl = Seq.controllerRaw (channel 0) (controller 17) 64 evs- Seq.bypass Common.maybeNoteExt+ let ctrl = Process.controllerRaw (channel 0) (controller 17) 64 evs+ Seq.bypass Note.maybeBndExt (\notes ->- Seq.snapSelect (snd $ Seq.pressed KeySet.groupLatch notes) ctrl) evs+ Seq.snapSelect (snd $ Process.pressed KeySet.groupLatch notes) ctrl) evs -} split = Seq.run $ uncurry RB.union . mapFst- (RBU.mapMaybe (Common.transpose 12)+ (RBU.mapMaybe (stranspose 12) . fmap (Common.setChannel (channel 1))) .@@ -187,34 +214,35 @@ splitPattern = Seq.runM $ \ times evs0 -> do- let (tempo, evs1) = getTempo evs0- beat <- Seq.beatVar times tempo+ (tempo, evs1) <- getTempo evs0+ beat <- Process.beatVar times tempo let checkLeft e = do- bnd <- Common.maybeNoteExt e+ bnd <- Note.maybeBndExt e case bnd of- NoteBoundaryExt (NoteBoundary (pit,_chan) _vel _on) -> do- guard (pit < pitch 60)+ Note.BoundaryExt (Note.Boundary pc _vel _on) -> do+ guard (Pitch.extract pc < pitch 60) return bnd _ -> return bnd return $ Seq.bypass checkLeft (\left ->- fmap (mapMaybe (Common.transpose 12) . map Common.noteFromBnd) $+ fmap (mapMaybe (stranspose 12 . Note.fromBnd)) $ Pattern.cycleUp (pure 4)- (snd $ Seq.pressed KeySet.groupLatch left) beat)+ (snd $ Process.pressed KeySet.groupLatch left) beat) evs1 {-- RBU.mapMaybe (Common.transpose 12) left)) beat+ RBU.mapMaybe (stranspose 12) left)) beat -} -cyclePrograms = Seq.runM $ \times evs -> return $+cyclePrograms = Seq.runM $ \times evs -> do -- Seq.cyclePrograms (map program [13..17]) times evs- RB.union+ defer <- Time.ticksFromSeconds $ time 0.1+ return $ RB.union (RB.filterJust $- Seq.cycleProgramsDefer (time 0.1) (map program [13..17]) times evs)+ Process.cycleProgramsDefer defer (map program [13..17]) times evs) evs sweep =@@ -227,32 +255,36 @@ (RB.filterE (not. Common.checkController (flip elem [centerCC, depthCC, speedCC])) evs) . uncurry- (Seq.makeControllerLinear c centerCC- (Seq.controllerRaw c depthCC 64 evs)- (Seq.controllerRaw c centerCC 64 evs)))+ (Process.makeControllerLinear c centerCC+ (Process.controllerRaw c depthCC 64 evs)+ (Process.controllerRaw c centerCC 64 evs))) $- Seq.sweep+ Process.sweep (time 0.01) (sin . (2*pi*))- (Seq.controllerExponential c speedCC 0.3 (0.1, 1) evs)+ (Process.controllerExponential c speedCC 0.3 (0.1, 1) evs) guitar =- Seq.run $- Seq.bypass Common.maybeNoteExt $ \notes ->+ Seq.runM $ \ _times evs ->+ (\f -> fmap (flip f evs) (ticks 0.03)) $ \del ->+ Seq.bypass Note.maybeBndExt $ \notes -> let (trigger, keys) = RBU.partitionMaybe (\note -> case note of- NoteBoundaryExt (NoteBoundary (pit,_chan) _vel on) -> do- guard $ pit == pitch 84+ Note.BoundaryExt (Note.Boundary pc _vel on) -> do+ guard $ Pitch.extract pc == pitch 84 return on _ -> Nothing) notes- in Seq.guitar (time 0.03) (snd $ Seq.pressed KeySet.groupLatch keys) trigger+ 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 trainer :: (Random.RandomGen g) =>- g -> ReaderT Common.Handle IO ()+ g -> ReaderT Seq.Handle IO () trainer g = Seq.runM $ \ times evs ->- fmap (RB.union (fmap Common.singletonBundle evs)) $- Seq.trainer (channel 0) (time 0.5) (time 0.3) (Training.all g) times evs+ fmap (RB.union (fmap singletonBundle evs)) $+ Process.trainer (channel 0) (time 0.5) (time 0.3) (Training.all g) times evs
− src/Reactive/Banana/ALSA/Guitar.hs
@@ -1,37 +0,0 @@--- cf. Haskore/Guitar-module Reactive.Banana.ALSA.Guitar where--import qualified Reactive.Banana.ALSA.Common as Common-import Sound.MIDI.Message.Channel.Voice (Pitch, toPitch, )-import Data.Maybe (mapMaybe, )---class Transpose pitch where- getPitch :: pitch -> Pitch- transpose :: Int -> pitch -> Maybe pitch--instance Transpose Pitch where- getPitch = id- transpose = Common.increasePitch---mapChordToString ::- (Transpose pitch, Ord pitch) =>- [Pitch] -> [pitch] -> [pitch]-mapChordToString strings chord =- mapMaybe (choosePitchForString chord) strings--choosePitchForString ::- (Transpose pitch, Ord pitch) =>- [pitch] -> Pitch -> Maybe pitch-choosePitchForString chord string =- let roundDown x d = x - mod x d- minAbove x =- transpose- (- roundDown (Common.subtractPitch string (getPitch x)) 12) x- in maximum (map minAbove chord)--stringPitches :: [Pitch]-stringPitches =- reverse $ map toPitch [40, 45, 50, 55, 59, 64]--- reverse [(-2,E), (-2,A), (-1,D), (-1,G), (-1,B), (0,E)]
− src/Reactive/Banana/ALSA/KeySet.hs
@@ -1,223 +0,0 @@-module Reactive.Banana.ALSA.KeySet where--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.Basic as Acc--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, )---{--class C set where- press :: Channel -> (Velocity, Pitch) -> set -> set- release :: Channel -> (Velocity, Pitch) -> set -> set- reset :: set -> set--change :: C set => Channel -> (Velocity, Pitch, Bool) -> set -> set-change chan (vel, pitch, True) = press chan (vel, pitch)-change chan (vel, pitch, False) = release chan (vel, pitch)--}--class C set where- reset :: MS.State set [NoteBoundary]- size :: set -> Int- toList :: set -> [((Pitch, Channel), Velocity)]- index :: Int -> set -> Maybe ((Pitch, Channel), Velocity)- change :: NoteBoundary -> MS.State set [NoteBoundary]----newtype Pressed = Pressed {deconsPressed :: Map.Map (Pitch, Channel) Velocity}- deriving (Show)--pressed :: Pressed-pressed = Pressed Map.empty--pressedAcc :: Acc.T Pressed (Map.Map (Pitch, Channel) Velocity)-pressedAcc = Acc.fromWrapper Pressed deconsPressed--instance C Pressed where- reset = AccState.lift pressedAcc releasePlayedKeys- size = Map.size . deconsPressed- toList = Map.toAscList . deconsPressed- index k (Pressed set) =- case drop k $ Map.toAscList set of- x:_ -> Just x- _ -> Nothing- change bnd@(NoteBoundary key vel on) = do- AccState.modify pressedAcc $- if on- then Map.insert key vel- else Map.delete key- return [bnd]----newtype Latch = Latch {deconsLatch :: Map.Map (Pitch, Channel) Velocity}- deriving (Show)--latch :: Latch-latch = Latch Map.empty--latchAcc :: Acc.T Latch (Map.Map (Pitch, Channel) Velocity)-latchAcc = Acc.fromWrapper Latch deconsLatch--latchChange ::- 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- size = Map.size . deconsLatch- toList = Map.toAscList . deconsLatch- index k (Latch set) =- case drop k $ Map.toAscList set of- x:_ -> Just x- _ -> Nothing- change = fmap maybeToList . latchChange----data GroupLatch =- GroupLatch {- groupLatchPressed_ {- input -} :: Set.Set (Pitch, Channel),- groupLatchPlayed_ {- output -} :: Map.Map (Pitch, Channel) Velocity- } deriving (Show)--groupLatch :: GroupLatch-groupLatch = GroupLatch Set.empty Map.empty--groupLatchPressed :: Acc.T GroupLatch (Set.Set (Pitch, Channel))-groupLatchPressed =- Acc.fromSetGet- (\mp grp -> grp{groupLatchPressed_ = mp})- groupLatchPressed_--groupLatchPlayed :: Acc.T GroupLatch (Map.Map (Pitch, Channel) Velocity)-groupLatchPlayed =- Acc.fromSetGet- (\mp grp -> grp{groupLatchPlayed_ = mp})- groupLatchPlayed_--{- |-All pressed keys are latched until a key is pressed after a pause-(i.e. all keys released).-For aborting the pattern you have to send-a 'ModeMsg.AllNotesOff' or 'ModeMsg.AllSoundOff' message.--}-instance C GroupLatch where- reset = AccState.lift groupLatchPlayed releasePlayedKeys- size = Map.size . groupLatchPlayed_- toList = Map.toAscList . groupLatchPlayed_- index k set =- case drop k $ Map.toAscList $ groupLatchPlayed_ set of- x:_ -> Just x- _ -> Nothing- 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 []----data SerialLatch =- SerialLatch {- serialLatchSize_ :: Int,- serialLatchCursor_ :: Int,- serialLatchPlayed_ :: Map.Map Int ((Pitch, Channel), Velocity)- } deriving (Show)--serialLatch :: Int -> SerialLatch-serialLatch num = SerialLatch num 0 Map.empty--serialLatchCursor :: Acc.T SerialLatch Int-serialLatchCursor =- Acc.fromSetGet- (\mp grp -> grp{serialLatchCursor_ = mp})- serialLatchCursor_--serialLatchPlayed :: Acc.T SerialLatch (Map.Map Int ((Pitch, Channel), Velocity))-serialLatchPlayed =- Acc.fromSetGet- (\mp grp -> grp{serialLatchPlayed_ = mp})- serialLatchPlayed_----{- |-A key is hold until @n@ times further keys are pressed.-The @n@-th pressed key replaces the current one.--}-instance C SerialLatch where--- reset = AccState.lift serialLatchPlayed releasePlayedKeys--- (0, Map.empty)- reset =- fmap (map (uncurry releaseKey) . Map.elems) $- AccState.getAndModify serialLatchPlayed (const Map.empty)- size = serialLatchSize_- toList = Map.elems . serialLatchPlayed_- index k = Map.lookup k . serialLatchPlayed_- 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)- [NoteBoundary]-releasePlayedKeys =- fmap (map (uncurry releaseKey) . Map.toList) $- AccState.getAndModify Acc.self (const Map.empty)--releaseKey ::- (Pitch, Channel) ->- Velocity -> NoteBoundary-releaseKey key vel =- NoteBoundary key vel False
− src/Reactive/Banana/ALSA/Pattern.hs
@@ -1,403 +0,0 @@-module Reactive.Banana.ALSA.Pattern where--import qualified Reactive.Banana.ALSA.KeySet as KeySet-import qualified Reactive.Banana.ALSA.DeBruijn as DeBruijn--import Reactive.Banana.ALSA.Common- (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, )------ * reactive patterns--type T t time set =- RB.Behavior t set ->- RB.Event t time ->- RB.Event t [NoteBoundary]--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---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 (NonNegW.fromNumberMsg "Pattern.item" n) i--data Poly set i = Poly (Selector set i) (EventList.T Int [IndexNote i])---{- |-Generate notes according to the key set,-where notes for negative and too large indices-are padded with keys that are transposed by octaves.--}-selectFromOctaveChord ::- KeySet.C set =>- Selector set Int-selectFromOctaveChord d chord =- maybeToList $ do- let size = KeySet.size chord- guard (size>0)- let (q,r) = divMod d size- ((pit,chan), vel) <- KeySet.index r chord- transPitch <- increasePitch (12*q) pit- return ((transPitch,chan), vel)--selectFromChord ::- KeySet.C set =>- Selector set Int-selectFromChord n chord =- maybeToList $ KeySet.index n chord--selectFromChordRatio ::- KeySet.C set =>- Selector set Double-selectFromChordRatio d chord =- selectFromChord (floor $ d * fromIntegral (KeySet.size chord)) chord---selectInversion ::- KeySet.C set =>- Selector set Double-selectInversion d chord =- let makeNote octave ((pit,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 mapMaybe (makeNote oct) high ++- mapMaybe (makeNote (oct+1)) low------ * patterns--{- |-See Haskore/FlipSong-- flipSeq m !! n = cross sum of the m-ary representation of n modulo m.-- For m=2 this yields- http://www.research.att.com/cgi-bin/access.cgi/as/njas/sequences/eisA.cgi?Anum=A010060--}-flipSeq :: Int -> [Int]-flipSeq n =- let incList m = map (\x -> mod (x+m) n)- recourse y =- let z = concatMap (flip incList y) [1 .. n-1]- in z ++ recourse (y++z)- in [0] ++ recourse [0]---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 =>- 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)--bruijn ::- KeySet.C set =>- Int -> Int -> T t time set-bruijn n k sets times =- mono selectFromChord sets $- fromList (cycle $ DeBruijn.lexLeast n k) times---binaryStaccato, binaryLegato, binaryAccident ::- KeySet.C set => T t time set-{--binary number Pattern.T:- 0- 1- 0 1- 2- 0 2- 1 2- 0 1 2- 3--}-binaryStaccato sets times =- poly- selectFromChord- sets- (flip fromList times $- map- (map (IndexNote 1 . fst) .- List.filter ((/=0) . snd) .- zip [0..] .- decomposePositional 2)- [0..])--binaryLegato sets times =- poly- selectFromChord- sets- (flip fromList times $- map- (\m ->- map (uncurry IndexNote) $- List.filter (\(p,_i) -> mod m p == 0) $- takeWhile ((<=m) . fst) $- zip (iterate (2*) 1) [0..])- [0..])--{--This was my first try to implement binaryLegato.-It was not what I wanted, but it sounded nice.--}-binaryAccident sets times =- poly- selectFromChord- sets- (flip fromList times $- map- (zipWith IndexNote (iterate (2*) 1) .- map fst .- List.filter ((/=0) . snd) .- zip [0..] .- decomposePositional 2)- [0..])----- cf. htam:NumberTheory-decomposePositional :: Integer -> Integer -> [Integer]-decomposePositional b =- let recourse 0 = []- recourse x =- let (q,r) = divMod x b- in r : recourse q- in recourse--cycleUpOctave ::- KeySet.C set =>- RB.Behavior t Int -> T t time set-cycleUpOctave numbers sets times =- mono selectFromOctaveChord sets (cycleUpIndex numbers times)---random, randomInversions ::- 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 $- map sum $- ListHT.sliceVertical 3 $- Rnd.randomRs (-1,1) $- Rnd.mkStdGen 42--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] -> T t time set-inversions rs sets times =- mono selectInversion sets (fromList rs times)------ * tests--{--We cannot use cycle function here, because we need to cycle a Body-Time list-which is incompatible to a Body-Body list,-even if the end is never reached.--}-examplePolyTempo0 ::- EventList.T Int [IndexNote Int]-examplePolyTempo0 =- let pat =- [item 0 1] ./ 1 /. [item 1 1, item 2 1] ./ 2 /.- [item 1 1, item 2 1] ./ 1 /. [item 0 1] ./ 2 /.- pat- in 0 /. pat--examplePolyTempo1 ::- EventList.T Int [IndexNote Int]-examplePolyTempo1 =- let pat =- [item 0 1] ./ 1 /.- [item 2 1, item 3 1, item 4 1] ./ 1 /.- [item 2 1, item 3 1, item 4 1] ./ 1 /.- [item 1 1] ./ 1 /.- [item 2 1, item 3 1, item 4 1] ./ 1 /.- [item 2 1, item 3 1, item 4 1] ./ 1 /.- pat- in 0 /. pat
+ src/Reactive/Banana/ALSA/Private.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Reactive.Banana.ALSA.Private where++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.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+import qualified Sound.ALSA.Sequencer.Port as Port+import qualified Sound.ALSA.Sequencer.Queue as Queue+import qualified Sound.ALSA.Sequencer.Event as Event++import qualified Control.Monad.Trans.Class as MT+import qualified Control.Monad.Trans.State as MS+import qualified Control.Monad.Trans.Reader as MR+import Control.Monad.IO.Class (MonadIO, )+import Control.Monad.Fix (MonadFix, )+import Control.Applicative (Applicative, )++++data Handle =+ Handle {+ sequ :: SndSeq.T SndSeq.DuplexMode,+ client :: Client.T,+ portPublic, portPrivate :: Port.T,+ queue :: Queue.T+ }+++newtype Reactor t a =+ Reactor {+ runReactor ::+ MR.ReaderT+ (RBF.AddHandler Event.T, Handle)+ (MS.StateT Schedule (RBS.Moment t))+ a+ } deriving (Functor, Applicative, Monad, MonadIO, MonadFix)+++instance Process.Moment Reactor where+ liftMoment = Reactor . MT.lift . MT.lift++instance IxMonad.C Reactor where+ point = return+ bind = (>>=)++instance Time.Timed Reactor where+ ticksFromSeconds =+ return .+ Time.cons . Time.Ticks .+ round . (nano *) .+ Time.unSeconds . Time.decons+++nano :: Num a => a+nano = 1000^(3::Int)+++{-+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)+-}
src/Reactive/Banana/ALSA/Sequencer.hs view
@@ -1,97 +1,42 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE Rank2Types #-}-module Reactive.Banana.ALSA.Sequencer where+module Reactive.Banana.ALSA.Sequencer (+ Handle,+ Reactor,+ 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.KeySet as KeySet-import qualified Reactive.Banana.ALSA.Time as Time-import qualified Reactive.Banana.ALSA.Utility as RBU+import qualified Reactive.Banana.ALSA.Time as AlsaTime+import Reactive.Banana.ALSA.Private+ (Reactor(Reactor, runReactor), Schedule,+ Handle(sequ, client, portPrivate), ) +import qualified Reactive.Banana.MIDI.Time as Time+import qualified Reactive.Banana.MIDI.Process as Process+import qualified Reactive.Banana.MIDI.Utility as RBU+import Reactive.Banana.MIDI.Common (Future(Future), )+ import qualified Reactive.Banana.Combinators as RB import qualified Reactive.Banana.Frameworks as RBF-import qualified Reactive.Banana.Switch as RBS import Reactive.Banana.Combinators ((<@>), ) import qualified Sound.ALSA.Sequencer.Event.RemoveMonad as Remove import qualified Sound.ALSA.Sequencer.Event as Event import qualified Sound.ALSA.Sequencer.Address as Addr -import qualified Sound.MIDI.ALSA.Check as Check-import qualified Sound.MIDI.ALSA as MALSA-import Sound.MIDI.ALSA (normalNoteFromEvent, )--import Sound.MIDI.Message.Channel (Channel, )-import Sound.MIDI.Message.Channel.Voice- (Pitch, Controller, Velocity, Program, normalVelocity,- fromPitch, toPitch, )--import qualified Data.EventList.Relative.TimeBody as EventList-import qualified Data.EventList.Absolute.TimeBody as EventListAbs--import qualified Data.Accessor.Monad.Trans.State as AccState-import qualified Data.Accessor.Tuple as AccTuple-import Data.Accessor.Basic ((^.), )- import qualified Control.Monad.Trans.Class as MT 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.IO.Class (MonadIO, liftIO, )-import Control.Monad.Fix (MonadFix, )-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.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 Control.Monad (forever, )+import Control.Applicative (Applicative, pure, (<*>), )+import Control.Functor.HT (void, )+import Data.Monoid (mempty, ) import Prelude hiding (sequence, ) --- * make ALSA reactive--newtype Reactor t a =- Reactor {- runReactor ::- MR.ReaderT- (RBF.AddHandler Event.T, Common.Handle)- (MS.StateT Schedule (RBS.Moment t))- a- } deriving (Functor, Applicative, Monad, MonadIO, MonadFix)---liftNetworkDescription :: RBS.Moment 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 @@ -102,7 +47,7 @@ else Event.Tag $ succ s -getHandle :: Reactor t Common.Handle+getHandle :: Reactor t Handle getHandle = Reactor $ MR.asks snd run ::@@ -110,7 +55,7 @@ (forall t. (RBF.Frameworks t) => RB.Event t Event.Data -> RB.Event t ev) ->- ReaderT Common.Handle IO ()+ ReaderT Handle IO () run f = runM (\ _ts xs -> return $ f xs) @@ -118,9 +63,9 @@ (Common.Events ev) => (forall t. (RBF.Frameworks t) =>- RB.Behavior t Time.Abs ->+ RB.Behavior t AlsaTime.AbsoluteTicks -> RB.Event t Event.Data -> Reactor t (RB.Event t ev)) ->- ReaderT Common.Handle IO ()+ ReaderT Handle IO () runM f = do Common.startQueue MR.ReaderT $ \h -> do@@ -128,9 +73,7 @@ (addEchoHandler, runEchoHandler) <- RBF.newAddHandler (addTimeHandler, runTimeHandler) <- RBF.newAddHandler RBF.actuate =<< RBF.compile (do- time <-- fmap (RB.stepper 0) $- RBF.fromAddHandler addTimeHandler+ time <- RBF.fromChanges mempty addTimeHandler evs <- flip MS.evalStateT startSchedule . flip MR.runReaderT (addEchoHandler, h)@@ -141,22 +84,21 @@ RBF.reactimate $ pure (outputEvents h) <*> time <@> evs) forever $ do- ev <- Event.input (Common.sequ h)- runTimeHandler $ Time.fromEvent ev- if Event.dest ev == Addr.Cons (Common.client h) (Common.portPrivate h)+ ev <- Event.input (sequ h)+ runTimeHandler $ AlsaTime.fromEvent ev+ if Event.dest ev == Addr.Cons (client h) (portPrivate h) then debug "input: echo" >> runEchoHandler ev else debug "input: event" >> runEventHandler ev outputEvents :: Common.Events evs =>- Common.Handle -> Time.Abs -> evs -> IO ()+ Handle -> AlsaTime.AbsoluteTicks -> evs -> IO () outputEvents h time evs = do- mapM_ (Event.output (Common.sequ h)) $- map (\(Common.Future dt body) ->+ mapM_ (Event.output (sequ h)) $+ map (\(Future dt body) -> Common.makeEvent h (Time.inc dt time) body) $ Common.flattenEvents evs- _ <- Event.drainOutput (Common.sequ h)- return ()+ void $ Event.drainOutput (sequ h) checkSchedule :: Schedule -> Event.T -> Bool@@ -169,75 +111,34 @@ (RBF.Frameworks t) => RB.Event t (IO ()) -> Reactor t () reactimate evs =- Reactor $ MT.lift $ MT.lift $ RBF.reactimate evs+ Process.liftMoment $ RBF.reactimate evs -sendEchos :: Common.Handle -> Schedule -> [Time.Abs] -> IO ()+sendEchos :: Handle -> Schedule -> [AlsaTime.AbsoluteTicks] -> IO () sendEchos h sched echos = do flip mapM_ echos $ \time ->- Event.output (Common.sequ h) $+ Event.output (sequ h) $ (Common.makeEcho h time) { Event.tag = sched }- _ <- Event.drainOutput (Common.sequ h)+ void $ Event.drainOutput (sequ h) debug "echos sent" -cancelEchos :: Common.Handle -> Schedule -> IO ()+cancelEchos :: Handle -> Schedule -> IO () cancelEchos h sched =- Remove.run (Common.sequ h) $ do+ Remove.run (sequ h) $ do Remove.setOutput Remove.setEventType Event.Echo Remove.setTag sched -reserveSchedule ::- (RBF.Frameworks t) =>- Reactor t (RB.Event t Time.Abs, [Time.Abs] -> IO (), IO ())-reserveSchedule = Reactor $ ReaderT $ \(addH,h) -> do- sched <- MS.get- MS.modify nextSchedule- eEcho <-- MT.lift $- fmap (fmap Time.fromEvent .- RB.filterE (checkSchedule sched)) $- RBF.fromAddHandler addH- return (eEcho, sendEchos h sched, cancelEchos h sched)---scheduleQueue ::- (RBF.Frameworks t, Show 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- let -- maintain queue and generate Echo events- remove echoTime =- MS.state $ uncurry $ \_lastTime ->- EventList.switchL- (error "scheduleQueue: received more events than sent")- (\(_t,x) xs ->- ((Just x, debug $ "got echo for event: " ++ show x),- ({- Time.inc t lastTime -}- echoTime, xs)))- add time new = do- MS.modify $ \(lastTime, old) ->- (time,- Common.mergeStable- (EventList.mapTime (Time.cons "scheduleQueue") $- EventList.fromAbsoluteEventList $- EventListAbs.fromPairList $- map (\(Common.Future dt a) -> (Time.decons dt, a)) $- List.sortBy (comparing Common.futureTime) new) $- EventList.decreaseStart- (Time.cons "Causal.process.decreaseStart"- (time-lastTime)) old)- return (Nothing, send $ map (flip Time.inc time . Common.futureTime) new)-- -- (Queue that keeps track of events to schedule- -- , duration of the new alarm if applicable) - (eEchoEvent, _bQueue) =- RBU.sequence (0, EventList.empty) $- RB.union (fmap remove eEcho) (pure add <*> times <@> e)-- reactimate $ fmap snd eEchoEvent- return $ RBU.mapMaybe fst eEchoEvent+instance Process.Reactor Reactor where+ reserveSchedule = Reactor $ ReaderT $ \(addH,h) -> do+ sched <- MS.get+ MS.modify nextSchedule+ eEcho <-+ MT.lift $+ fmap (fmap AlsaTime.fromEvent .+ RB.filterE (checkSchedule sched)) $+ RBF.fromAddHandler addH+ return (sendEchos h sched, cancelEchos h sched, eEcho) debug :: String -> IO ()@@ -253,546 +154,3 @@ 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--{- |-register pressed keys--}-pressed ::- (KeySet.C set) =>- set ->- RB.Event f Common.NoteBoundaryExt ->- (RB.Event f [Common.NoteBoundary], RB.Behavior f set)-pressed empty =- RBU.traverse empty- (\e ->- case e of- Common.NoteBoundaryExt bnd -> KeySet.change bnd- Common.AllNotesOff -> KeySet.reset)--latch ::- 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) .- RBU.traverse KeySet.latch KeySet.latchChange--{- |-Demonstration of scheduleQueue,-but for real use prefer 'delay',-since this uses precisely timed delivery by ALSA.--}-delaySchedule ::- (RBF.Frameworks t) =>- 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 ::- Time.T ->- RB.Event t ev -> RB.Event t (Common.Future ev)-delay dt =- fmap (Common.Future dt)--delayAdd ::- Time.T ->- RB.Event t ev -> RB.Event t (Common.Future ev)-delayAdd dt evs =- RB.union (fmap Common.now evs) $ delay dt evs--{- |-Generate a beat according to the tempo control.-The input signal specifies the period between two beats.-The output events hold the times, where they occur.--}-beat ::- (RBF.Frameworks t) =>- RB.Behavior t Time.T -> Reactor t (RB.Event t Time.Abs)-beat tempo = do- (eEcho, send, _) <- reserveSchedule-- liftIO $ send [0]-- let next dt time =- (time, send [Time.inc dt time])-- eEchoEvent = fmap next tempo <@> eEcho-- reactimate $ fmap snd eEchoEvent- return $ fmap fst eEchoEvent---{- |-Similar to 'beat' but warrants a maximum reaction time to tempo changes.-This way you can alter slow tempos to faster one more quickly.--}-{--Instead of this we could use the reciprocal of Time, that is frequency,-and integrate that.-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 ::- (RBF.Frameworks t) =>- Time.T ->- RB.Behavior t Time.T -> Reactor t (RB.Event t Time.Abs)-beatQuant maxDur tempo = do- (eEcho, send, _) <- reserveSchedule-- liftIO $ send [0]-- let next dt time = do- complete <- MS.gets (>=1)- when complete $ MS.modify (subtract 1)- portion <- MS.get- let dur = limit (mempty,maxDur) (Time.scaleCeiling (1-portion) dt)- MS.modify (Time.div dur dt +)- return- (toMaybe complete time,- send [Time.inc dur time]- {- print (dur, time, dt, portion) -} )-- eEchoEvent =- fst $ RBU.sequence 0 $ fmap next tempo <@> eEcho-- reactimate $ fmap snd 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 ::- (RBF.Frameworks t) =>- 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 ->- 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) =- mapFst (RB.stepper deflt) .- RBU.partitionMaybe- (fmap (Common.ctrlDur (lower, upper))- . Check.controller chan ctrl)---controllerRaw ::- (Check.C ev) =>- Channel ->- Controller ->- Int ->- RB.Event t ev -> RB.Behavior t Int-controllerRaw chan ctrl deflt =- RB.stepper deflt .- RBU.mapMaybe (Check.controller chan ctrl)--controllerExponential ::- (Floating a, Check.C ev) =>- Channel ->- Controller ->- a -> (a,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 .- RBU.mapMaybe- (fmap ((lower*) . exp . (k*) . fromIntegral)- . Check.controller chan ctrl)--controllerLinear ::- (Fractional a, Check.C ev) =>- Channel ->- Controller ->- a -> (a,a) ->- RB.Event t ev -> RB.Behavior t a-controllerLinear chan ctrl deflt (lower,upper) =- let k = (upper-lower) / 127- in RB.stepper deflt .- RBU.mapMaybe- (fmap ((lower+) . (k*) . fromIntegral)- . Check.controller chan ctrl)---cyclePrograms ::- [Program] ->- RB.Event t Event.Data -> RB.Event t (Maybe Event.Data)-cyclePrograms pgms =- fst .- RBU.traverse (cycle pgms)- (Common.traverseProgramsSeek (length pgms))---{- |-> cycleProgramsDefer t--After a note that triggers a program change,-we won't change the program in the next 't' seconds.-This is in order to allow chords being played-and in order to skip accidentally played notes.--}-{--In the future we might also add a time-out:-After a certain time, where no key is pressed,-the program would be reset to the initial program.--}-cycleProgramsDefer ::- Time.T -> [Program] ->- RB.Behavior t Time.Abs ->- RB.Event t Event.Data -> RB.Event t (Maybe Event.Data)-cycleProgramsDefer defer pgms times =- fst .- RBU.traverse (cycle pgms, 0)- (\(eventTime,e) ->- case e of- Event.CtrlEv Event.PgmChange ctrl ->- AccState.lift AccTuple.first $- Common.seekProgram (length pgms) (ctrl ^. MALSA.ctrlProgram)- Event.NoteEv notePart note -> do- blockTime <- MS.gets snd- if eventTime < blockTime- then return Nothing- else- case fst $ normalNoteFromEvent notePart note of- Event.NoteOn -> do- AccState.set AccTuple.second $- Time.inc defer eventTime- AccState.lift AccTuple.first $- Common.nextProgram note- _ -> return Nothing- _ -> return Nothing) .- RB.apply (fmap (,) times)---newtype PitchChannel =- PitchChannel ((Pitch, Channel), Velocity)- deriving (Show)--instance Eq PitchChannel where- (PitchChannel ((p0,_), _)) == (PitchChannel ((p1,_), _)) =- p0 == p1--instance Ord PitchChannel where- compare (PitchChannel ((p0,_), _)) (PitchChannel ((p1,_), _)) =- compare p0 p1--instance Guitar.Transpose PitchChannel where- getPitch (PitchChannel ((p,_), _)) = p- transpose d (PitchChannel ((p,c),v)) = do- p' <- Common.increasePitch d p- return $ PitchChannel ((p',c), v)--noteSequence ::- Time.T ->- Event.NoteEv -> [Event.Note] ->- Common.EventDataBundle-noteSequence stepTime onOff =- zipWith Common.Future (iterate (mappend stepTime) mempty) .- map (Event.NoteEv onOff)--{- |-This process simulates playing chords on a guitar.-If you press some keys like C, E, G on the keyboard,-then this process figures out what tones would be played on a guitar.--Call it like @guitar stepTime chords triggers@.--@stepTime@ is the delay between to successive notes.-A good value is 0.03 (seconds).-The chords to be played are passed in by @chords@.-This should be the output of 'pressed'.-Further on the function needs events-that trigger playing the chord in @trigger@ argument.-The trigger consists of the trigger time-and the direction to be played-('True' = down from high to low pitches,-'False' = up from low to high pitches).-The trigger may be derived from a specific key that is pressed and released,-or two keys, one for each direction.--}-guitar ::- (KeySet.C set) =>- Time.T ->- RB.Behavior t set ->- RB.Event t Bool ->- RB.Event t Common.EventDataBundle-guitar stepTime pressd trigger =- fst $- RBU.traverse []- (\(set, on) -> do- played <- MS.get- let toPlay =- case KeySet.toList set of- [] -> []- list ->- fmap (\(PitchChannel ((p,c),v)) ->- MALSA.noteEvent c p v v 0) $- Guitar.mapChordToString Guitar.stringPitches $- fmap PitchChannel list- MS.put toPlay- return $- if on- then- noteSequence stepTime Event.NoteOff- (List.reverse played)- ++- noteSequence stepTime Event.NoteOn toPlay- else- noteSequence stepTime Event.NoteOff played- ++- noteSequence stepTime Event.NoteOn- (List.reverse toPlay)) $- pure (,) <*> pressd <@> trigger----{- |-Audio perception trainer--Play sets of notes and-let the human player answer to them according to a given scheme.-Repeat playing the notes sets until the trainee answers correctly.-Then continue with other sequences, maybe more complicated ones.--possible tasks:-- - 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-- - transpose a set of pitches:- tranpose to a certain base note,- transpose by a certain interval-- - play a set of pitches in a different order:- reversed order,- in increasing pitch-- - replay a set of simultaneously pressed keys--The difficulty can be increased by not connecting-the keyboard directly with the sound generator.-This way, the trainee cannot verify,-how the pressed keys differ from the target keys.--Sometimes it seems that you are catched in an infinite loop.-This happens if there were too many keys pressed.-The trainer collects all key press events,-not only the ones that occur after the target set is played.-This way you can correct yourself immediately,-before the target is repeatedly played.-The downside is, that there may be key press events hanging around.-You can get rid of them by pressing a key again and again,-but slowly, until the target is played, again.-Then the queue of registered keys should be empty-and you can proceed training.--}-{--The Reactor monad is only needed for sending the initial notes.--}-trainer ::- (RBF.Frameworks t) =>- Channel ->- Time.T -> Time.T ->- [([Pitch], [Pitch])] ->- 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- (target, _) : _ ->- (concat $- zipWith- (\t p ->- Common.eventsFromKey t duration- ((p,chan), normalVelocity))- (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 (RBU.traverse (sets0, [], Time.inc initIgnoreUntil 0))- (fmap (,) times <@> evs0) $ \(time,ev) ->- case ev of- Event.NoteEv notePart note ->- case fst $ normalNoteFromEvent notePart note of- Event.NoteOn -> do- ignoreUntil <- AccState.get AccTuple.third3- if time <= ignoreUntil- then return []- else do- pressd <- AccState.get AccTuple.second3- let newPressd = (note ^. MALSA.notePitch) : pressd- AccState.set AccTuple.second3 newPressd- sets <- AccState.get AccTuple.first3- case sets of- (_, target) : rest ->- if Match.lessOrEqualLength target newPressd- then do- AccState.set AccTuple.second3 []- when (newPressd == List.reverse target) $- AccState.set AccTuple.first3 rest- (notes, newIgnoreUntil) <-- fmap makeSeq $- AccState.get AccTuple.first3- AccState.set AccTuple.third3 $- Time.inc newIgnoreUntil time- return notes- else return []- _ -> return []- _ -> return []- _ -> return []---sweep ::- (RBF.Frameworks t) =>- Time.T ->- (Double -> Double) ->- RB.Behavior t Double ->- Reactor t (RB.Event t Time.Abs, RB.Behavior t Double)-sweep dur wave speed = do- bt <- beat $ pure dur- let durD = realToFrac $ Time.decons dur- return- (bt,- fmap wave $ RB.accumB 0 $- fmap (\d _ phase -> Common.fraction (phase + durD * d)) speed <@> bt)--makeControllerLinear ::- Channel -> Controller ->- 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 ->- Event.CtrlEv Event.Controller $- MALSA.controllerEvent chan cc $- round $ limit (0,127) $- fromIntegral center + fromIntegral depth * y)- <*> ctrl- <*> 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 ::- (RBF.Frameworks t, KeySet.C set) =>- RB.Behavior t set ->- RB.Behavior t Int ->- Reactor t (RB.Event t [Event.Data])--- RBS.Moment 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 ::- (RBF.Frameworks t, 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
src/Reactive/Banana/ALSA/Time.hs view
@@ -1,80 +1,38 @@ module Reactive.Banana.ALSA.Time where +import qualified Reactive.Banana.MIDI.Time as Time+import Reactive.Banana.ALSA.Private (Reactor, )+ 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"+type AbsoluteTicks = Time.T Reactor Time.Absolute Time.Ticks+type RelativeTicks = Time.T Reactor Time.Relative Time.Ticks -inc :: T -> Abs -> Abs-inc dt t = t + decons dt+type AbsoluteSeconds = Time.T Reactor Time.Absolute Time.Seconds+type RelativeSeconds = Time.T Reactor Time.Relative Time.Seconds -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 :: ATime.Stamp -> AbsoluteTicks fromStamp t = case t of ATime.Real rt ->- RealTime.toInteger rt % nano+ Time.cons $ Time.Ticks $ RealTime.toInteger rt -- _ -> 0, _ -> error "unsupported time stamp type" -toStamp :: Abs -> ATime.Stamp+toStamp :: AbsoluteTicks -> ATime.Stamp toStamp t =- ATime.Real (RealTime.fromInteger (round (t*nano)))+ ATime.Real $ RealTime.fromInteger $ Time.unTicks $ Time.decons t -fromEvent :: Event.T -> Abs+fromEvent :: Event.T -> AbsoluteTicks fromEvent ev = case Event.time ev of ATime.Cons ATime.Absolute stamp -> fromStamp stamp- _ -> error "timeFromEvent: we can only handle absolute time stamps"+ _ -> error "Time.fromEvent: we can only handle absolute time stamps"
− src/Reactive/Banana/ALSA/Training.hs
@@ -1,110 +0,0 @@-module Reactive.Banana.ALSA.Training (- all,- intervals,- twoNotes,- threeNotes,- reverseThreeNotes,- sortThreeNotes,- transposeTwoNotes,- ) where--import Reactive.Banana.ALSA.Common (pitch, increasePitch, subtractPitch, )-import Sound.MIDI.Message.Channel.Voice (Pitch, )--import System.Random (RandomGen, Random, randomR, )-import Control.Monad.Trans.State (State, state, evalState, )-import Control.Monad (liftM2, )-import Data.Maybe (mapMaybe, )-import qualified Data.List as List-import Prelude hiding (all, )---{- | chose a random item from a list -}--- from htam-randomItem :: (RandomGen g) => [a] -> State g a-randomItem x = fmap (x!!) (randomRState (length x - 1))--randomRState :: (RandomGen g, Random a, Num a) => a -> State g a-randomRState upper = state (randomR (0, upper))---baseKey :: Pitch-baseKey = pitch 60--notes :: [Pitch]-notes =- mapMaybe (flip increasePitch baseKey)- [0, 12, 7, 5, 4, 2, 9, 11, 3, 10, 1, 6, 8]---all :: RandomGen g => g -> [([Pitch], [Pitch])]-all g =- intervals g ++ twoNotes g ++ threeNotes g ++- reverseThreeNotes g ++ sortThreeNotes g ++- transposeTwoNotes g---- | intervals within an octave, all starting with a C-intervals :: RandomGen g => g -> [([Pitch], [Pitch])]-intervals g =- flip evalState g $- mapM randomItem $- concat $ zipWith replicate [3,6..] $- drop 3 $ List.inits $- map (\p -> let ps = [baseKey, p] in (ps, ps)) $- notes---- | choose two arbitrary notes from an increasing set of notes-twoNotes :: RandomGen g => g -> [([Pitch], [Pitch])]-twoNotes g =- flip evalState g $- mapM (\ps ->- fmap (\pso -> (pso,pso)) $- mapM randomItem [ps,ps]) $- concat $ zipWith replicate [3,6..] $- drop 3 $ List.inits $- notes---- | choose three arbitrary notes from an increasing set of notes-threeNotes :: RandomGen g => g -> [([Pitch], [Pitch])]-threeNotes g =- flip evalState g $- mapM (\ps ->- fmap (\pso -> (pso,pso)) $- mapM randomItem [ps,ps,ps]) $- concat $ zipWith replicate [3,6..] $- drop 3 $ List.inits $- notes--reverseThreeNotes :: RandomGen g => g -> [([Pitch], [Pitch])]-reverseThreeNotes g =- flip evalState g $- mapM (\ps ->- fmap (\pso -> (pso, reverse pso)) $- mapM randomItem [ps,ps,ps]) $- concat $ zipWith replicate [3,6..] $- drop 3 $ List.inits $- notes--sortThreeNotes :: RandomGen g => g -> [([Pitch], [Pitch])]-sortThreeNotes g =- flip evalState g $- mapM (\ps ->- fmap (\pso -> (pso, List.sort pso)) $- mapM randomItem [ps,ps,ps]) $- concat $ zipWith replicate [3,6..] $- drop 3 $ List.inits $- notes---- | transpose an interval to begin with C-transposeTwoNotes :: RandomGen g => g -> [([Pitch], [Pitch])]-transposeTwoNotes g =- flip evalState g $- mapM (\ps ->- liftM2- (\p0 p1 ->- let pso = [p0,p1]- in (pso, mapMaybe (increasePitch (subtractPitch p0 baseKey)) pso))- (randomItem ps) (randomItem ps)) $- concat $ zipWith replicate [3,6..] $- drop 3 $ List.inits $- notes
− src/Reactive/Banana/ALSA/Trie.hs
@@ -1,44 +0,0 @@-{- |-This module is only needed for DeBruijn sequence generation.--}-module Reactive.Banana.ALSA.Trie where--import qualified Data.List as List-import Data.Maybe.HT (toMaybe, )-import Data.Maybe (mapMaybe, )--import Prelude hiding (null, lookup)---data Trie a b = Leaf b | Branch [(a, Trie a b)]- deriving (Show)--full :: b -> [a] -> Int -> Trie a b-full b _ 0 = Leaf b-full b as n =- Branch $- map (\a -> (a, full b as (n-1))) as--null :: Trie a [b] -> Bool-null (Branch []) = True-null (Leaf []) = True-null _ = False--delete :: (Eq a, Eq b) => b -> [a] -> Trie a [b] -> Trie a [b]-delete b [] (Leaf bs) = Leaf (List.delete b bs)-delete b (a:as) (Branch subTries) =- Branch $ mapMaybe- (\(key,trie) ->- fmap ((,) key) $- if key==a- then let delTrie = delete b as trie- in toMaybe (not (null delTrie)) delTrie- else Just trie)- subTries-delete _ _ _ = error "Trie.delete: key and trie depth mismatch"--lookup :: (Eq a) => [a] -> Trie a b -> Maybe b-lookup [] (Leaf b) = Just b-lookup (a:as) (Branch subTries) =- List.lookup a subTries >>= lookup as-lookup _ _ = error "Trie.lookup: key and trie depth mismatch"
− src/Reactive/Banana/ALSA/Utility.hs
@@ -1,49 +0,0 @@--- 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