reactive-balsa 0.0 → 0.1
raw patch · 9 files changed
+1027/−632 lines, 9 filesdep +extensible-exceptionsdep ~alsa-seqdep ~containersdep ~reactive-banana
Dependencies added: extensible-exceptions
Dependency ranges changed: alsa-seq, containers, reactive-banana, transformers
Files
- reactive-balsa.cabal +11/−8
- src/Reactive/Banana/ALSA/Common.hs +151/−158
- src/Reactive/Banana/ALSA/DeBruijn.hs +5/−0
- src/Reactive/Banana/ALSA/Example.hs +165/−48
- src/Reactive/Banana/ALSA/KeySet.hs +61/−95
- src/Reactive/Banana/ALSA/Pattern.hs +212/−100
- src/Reactive/Banana/ALSA/Sequencer.hs +293/−223
- src/Reactive/Banana/ALSA/Time.hs +80/−0
- src/Reactive/Banana/ALSA/Utility.hs +49/−0
reactive-balsa.cabal view
@@ -1,10 +1,10 @@ Name: reactive-balsa-Version: 0.0+Version: 0.1 License: BSD3 License-File: LICENSE Author: Henning Thielemann <haskell@henning-thielemann.de> Maintainer: Henning Thielemann <haskell@henning-thielemann.de>--- 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
src/Reactive/Banana/ALSA/Common.hs view
@@ -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<x<=0@ in which case we lose one digit of precision.- -}- (n,x) = properFraction (logBase digitBaseFloat base * expo)- frac = round (digitBaseFloat ** (x + fromIntegral precision))- in fromInteger frac *- fromIntegral digitBase ^^ (n-precision)---fraction :: RealFrac a => 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
src/Reactive/Banana/ALSA/DeBruijn.hs view
@@ -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 $
src/Reactive/Banana/ALSA/Example.hs view
@@ -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
src/Reactive/Banana/ALSA/KeySet.hs view
@@ -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
src/Reactive/Banana/ALSA/Pattern.hs view
@@ -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)
src/Reactive/Banana/ALSA/Sequencer.hs view
@@ -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
+ src/Reactive/Banana/ALSA/Time.hs view
@@ -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"
+ src/Reactive/Banana/ALSA/Utility.hs view
@@ -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