module Sound.MIDI.ALSA.EventList where {- ToDo: controller mapping fix laziness issues in splitting and merging change pattern according to program change events -} import Sound.MIDI.ALSA.Common (Bundle, EventDataBundle, Time, TimeAbs, Handle, Pattern, PatternMulti, Selector, sequ, with, incTime, singletonBundle, checkController, checkChannel, checkProgram, checkPitch, SweepState, sweepSpeed, sweepPhase, sweepDepth, sweepCenter, updateDur, updateChord, ) import qualified Sound.MIDI.ALSA.Common as Common import qualified Sound.ALSA.Sequencer.Event as Event import qualified Sound.ALSA.Exception as Exc 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 Sound.MIDI.Message.Channel (Channel, ) import Sound.MIDI.Message.Channel.Voice (Velocity, Pitch, Controller, Program, ) import qualified Data.EventList.Relative.TimeBody as EventList import qualified Data.EventList.Relative.MixedBody as EventListMB import qualified Data.EventList.Absolute.TimeBody as EventListAbs import qualified Data.Accessor.Basic as Acc import Data.Accessor.Basic ((^.), ) import qualified Data.List.HT as ListHT import qualified Data.List.Match as Match import Data.Tuple.HT (mapFst, mapSnd, mapPair, ) import Data.Ord.HT (limit, ) import qualified Data.List as List import Data.Maybe (mapMaybe, ) 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 Control.Monad.IO.Class (liftIO, ) import qualified Control.Applicative as App import Control.Monad (liftM2, guard, ) import qualified Data.Foldable as Fold import qualified Data.Traversable as Trav import qualified Numeric.NonNegative.Class as NonNeg import Data.Int (Int32, ) import System.IO.Unsafe (unsafeInterleaveIO, ) import Prelude hiding (init, filter, ) ioToLazyList :: IO a -> IO [a] ioToLazyList m = let go = unsafeInterleaveIO $ liftM2 (:) m go in go inputEventsCore :: ReaderT Handle IO [Event.T] inputEventsCore = Reader.ReaderT $ \h -> ioToLazyList (Event.input (sequ h)) inputEvents :: ReaderT Handle IO (EventList.T Time Event.Data) inputEvents = fmap (EventList.fromAbsoluteEventList . EventListAbs.fromPairList . map (\ev -> (Common.timeFromStamp (Event.timestamp ev), Event.body ev))) $ inputEventsCore pairListFromRelativeEvents :: EventList.T Time a -> [(TimeAbs,a)] pairListFromRelativeEvents = EventListAbs.toPairList . EventListAbs.mapTime Common.deconsTime . EventList.toAbsoluteEventList 0 outputEvent :: TimeAbs -> Event.Data -> ReaderT Handle IO () outputEvent t ev = Reader.ReaderT $ \h -> Event.output (sequ h) (Common.makeEvent h t ev) >> Event.drainOutput (sequ h) >> return () outputEvents :: EventList.T Time Event.Data -> ReaderT Handle IO () outputEvents = mapM_ (uncurry outputEvent) . pairListFromRelativeEvents {- | Sends (drain) each event individually since the events in the bundle might be created in a lazy manner. -} outputEventBundles :: EventList.T Time EventDataBundle -> ReaderT Handle IO () outputEventBundles = mapM_ (\(t,evs) -> flip mapM_ evs (\(dt,ev) -> outputEvent (incTime dt t) ev)) . pairListFromRelativeEvents outputEventBundled :: EventList.T Time EventDataBundle -> ReaderT Handle IO () outputEventBundled = mapM_ (\(t,evs) -> Reader.ReaderT $ \h -> flip mapM_ evs (\(dt,ev) -> Event.output (sequ h) (Common.makeEvent h (incTime dt t) ev)) >> Event.drainOutput (sequ h) >> return ()) . pairListFromRelativeEvents data Trigger a = Regular a | Trigger instance Functor Trigger where fmap f (Regular a) = Regular (f a) fmap _ Trigger = Trigger instance Fold.Foldable Trigger where foldMap = Trav.foldMapDefault instance Trav.Traversable Trigger where sequenceA (Regular a) = fmap Regular a sequenceA Trigger = App.pure Trigger type EventDataTrigger = Bundle (Trigger Event.Data) makeTriggerEvent :: Handle -> TimeAbs -> Trigger Event.Data -> Event.T makeTriggerEvent h t x = case x of Regular ev -> Common.makeEvent h t ev Trigger -> Common.makeEcho h t (Event.Custom 0 0 0) makeTriggerEvents :: Handle -> TimeAbs -> EventDataTrigger -> [Event.T] makeTriggerEvents h t = map (\(dt,ev) -> makeTriggerEvent h (incTime dt t) ev) {- | This function distinguishes between events from portIn and events that are generated by us. Our generated events must also send an echo to the input port in order to break 'event_input' and thus trigger their delivery. -} outputTriggerEvents :: EventList.T Time EventDataTrigger -> ReaderT Handle IO () outputTriggerEvents = mapM_ (\(t,ee) -> Reader.ReaderT $ \h -> mapM_ (\e -> Event.output (sequ h) e >> Event.drainOutput (sequ h)) (makeTriggerEvents h t ee) >> return ()) . pairListFromRelativeEvents mergeGenerated :: EventList.T Time (Bundle a) -> EventList.T Time (Bundle a) -> EventList.T Time (Bundle (Trigger a)) mergeGenerated gens ins = merge (fmap (\t -> [(t, Trigger)]) $ EventList.fromPairList $ ListHT.mapAdjacent (,) (0 : EventList.getTimes gens)) (fmap (map (mapSnd Regular)) $ merge gens ins) {- ToDo: move to eventlist package -} equidistantEvents :: Time -> [a] -> EventList.T Time a equidistantEvents dur as = case as of [] -> EventList.empty x:xs -> EventList.cons 0 x $ EventList.fromPairList (map ((,) dur) xs) whirl :: EventList.T Time EventDataBundle whirl = let dur = 0.125 notes = cycle $ concat $ concatMap (replicate 4) $ [57, 59, 60, 64] : [57, 59, 60, 65] : [57, 62, 64, 65] : [57, 59, 60, 64] : [] ctrls = map (\t -> round (80 + 47 * sin t)) (iterate (0.1+) (0::Double)) events = zipWith (:) (map (\k -> (0, Event.CtrlEv Event.Controller (Event.Ctrl {Event.ctrlChannel = 0, Event.ctrlParam = 23, Event.ctrlValue = k}))) ctrls) (map (\k -> (0, Event.NoteEv Event.NoteOn $ Event.simpleNote 0 k 64) : (dur, Event.NoteEv Event.NoteOff $ Event.simpleNote 0 k 64) : []) notes) in EventList.cons 0 [(0, Event.CtrlEv Event.PgmChange (Event.Ctrl {Event.ctrlChannel = 0, Event.ctrlParam = 0, Event.ctrlValue = 5}))] $ equidistantEvents dur events mergeGeneratedAtoms :: (Time -> a) -> EventList.T Time a -> EventList.T Time a -> EventList.T Time a mergeGeneratedAtoms trigger gens ins = EventList.mergeBy (\_ _ -> True) (fmap trigger $ EventList.fromPairList $ ListHT.mapAdjacent (,) (0 : EventList.getTimes gens)) (EventList.mergeBy (\_ _ -> True) gens ins) pattern :: Selector i -> [i] -> Time -> EventList.T Time Event.Data -> EventList.T Time EventDataTrigger pattern select ixs dur ins = flip State.evalState Map.empty $ Trav.sequenceA $ mergeGeneratedAtoms (\dt -> return [(dt, Trigger)]) (fmap (\n -> State.gets (map (mapSnd Regular) . select n dur . Map.toAscList)) (equidistantEvents dur ixs)) (fmap (\e -> case e of Event.NoteEv notePart note -> do State.modify (updateChord notePart note) return [] _ -> return $ singletonBundle (Regular e)) ins) patternTempo :: Selector i -> [i] -> ((Channel,Controller), (Time,Time,Time)) -> EventList.T Time Event.Data -> EventList.T Time EventDataTrigger patternTempo select ixs0 ((chan,ctrl), (minDur, defltDur, maxDur)) = let recourse dur chord ixs = EventList.switchL EventList.empty $ \(time,me) rest -> uncurry (EventList.cons time) $ case me of Nothing -> case ixs of [] -> ([], recourse dur chord ixs rest) i:ir -> ((dur, Trigger) : map (mapSnd Regular) (select i dur $ Map.toAscList chord), recourse dur chord ir $ EventList.insertBy (\_ _ -> True) dur Nothing rest) Just e -> case e of Event.NoteEv notePart note -> ([], recourse dur (updateChord notePart note chord) ixs rest) Event.CtrlEv Event.Controller param | Common.controllerMatch chan ctrl param -> ([], recourse (updateDur param (minDur,maxDur)) chord ixs rest) _ -> (singletonBundle (Regular e), recourse dur chord ixs rest) in recourse defltDur Map.empty ixs0 . EventList.insertBy (\_ _ -> True) defltDur Nothing . fmap Just {- | This allows more complex patterns including pauses, notes of different lengths and simultaneous notes. -} patternMultiTempo :: Selector i -> EventList.T Int [Common.IndexNote i] -> ((Channel,Controller), (Time,Time,Time)) -> EventList.T Time Event.Data -> EventList.T Time EventDataTrigger patternMultiTempo select ixs0 ((chan,ctrl), (minDur, defltDur, maxDur)) = let recourse dur chord ixs = EventList.switchL EventList.empty $ \(time,me) rest -> uncurry (EventList.cons time) $ case me of Nothing -> EventList.switchL ([], recourse dur chord ixs rest) (\(t,is) ir0 -> let (notes,ir1) = if t>0 then ([], EventList.cons (t-1) is ir0) else (do Common.IndexNote d i <- is evs <- select i (fromIntegral d * dur) $ Map.toAscList chord return (mapSnd Regular evs), ir0) in ((dur, Trigger) : notes, recourse dur chord ir1 $ EventList.insertBy (\_ _ -> True) dur Nothing rest)) ixs Just e -> case e of Event.NoteEv notePart note -> ([], recourse dur (updateChord notePart note chord) ixs rest) Event.CtrlEv Event.Controller param | Common.controllerMatch chan ctrl param -> ([], recourse (updateDur param (minDur,maxDur)) chord ixs rest) _ -> (singletonBundle (Regular e), recourse dur chord ixs rest) in recourse defltDur Map.empty ixs0 . EventList.insertBy (\_ _ -> True) defltDur Nothing . fmap Just {- | Automatically changes the value of a MIDI controller every @period@ seconds according to a periodic wave. The wave function is a mapping from the phase in @[0,1)@ to a controller value in the range @(-1,1)@. The generation of the wave is controlled by a speed controller (@minSpeed@ and @maxSpeed@ are in waves per second), the modulation depth and the center value. The center controller is also the one where we emit our wave. That is, when modulation depth is zero then this effect is almost the same as forwarding the controller without modification. The small difference is, that we emit a controller value at a regular pattern, whereas direct control would mean that only controller value changes are transfered. > sweep channel > period (speedCtrl, (minSpeed, maxSpeed)) depthCtrl centerCtrl > (ctrlRange (-1,1) (sin . (2*pi*))) We could use the nice Wave abstraction from the synthesizer package, but that's a heavy dependency because of multi-parameter type classes. -} sweep :: Channel -> Time -> (Controller, (Time,Time)) -> Controller -> Controller -> (Double -> Double) -> EventList.T Time Event.Data -> EventList.T Time EventDataTrigger sweep chan dur (speedCtrl, (minSpeed, maxSpeed)) depthCtrl centerCtrl wave ins = flip State.evalState (Common.SweepState { sweepSpeed = realToFrac $ Common.deconsTime $ dur*(minSpeed+maxSpeed)/2, sweepDepth = 64, sweepCenter = 64, sweepPhase = 0 }) $ Trav.sequenceA $ mergeGeneratedAtoms (\dt -> return [(dt, Trigger)]) (fmap (\() -> do ev <- State.gets (\s -> Event.CtrlEv Event.Controller $ Event.Ctrl { Event.ctrlChannel = MALSA.fromChannel chan, Event.ctrlParam = MALSA.fromController centerCtrl, Event.ctrlValue = round $ limit (0,127) $ sweepCenter s + sweepDepth s * wave (sweepPhase s) }) State.modify (\s -> s{sweepPhase = Common.fraction (sweepPhase s + sweepSpeed s)}) return $ singletonBundle (Regular ev)) (equidistantEvents dur $ repeat ())) (fmap (\e -> maybe (return $ singletonBundle (Regular e)) (\f -> State.modify f >> return []) $ do Event.CtrlEv Event.Controller param <- Just e let c = param ^. MALSA.ctrlChannel ctrl = param ^. MALSA.ctrlController x :: Num a => a x = fromIntegral (Event.ctrlValue param) guard (c==chan) lookup ctrl $ (speedCtrl, \s -> s{sweepSpeed = realToFrac $ Common.deconsTime $ (dur *) $ minSpeed + (maxSpeed-minSpeed) * x/127}) : (depthCtrl, \s -> s{sweepDepth = x}) : (centerCtrl, \s -> s{sweepCenter = x}) : []) ins) -- * combinators {- | The function maintains empty bundles in order to maintain laziness breaks. These breaks are import for later merging of the streams. -} filter :: (a -> Bool) -> State.State (EventList.T Time (Bundle a)) (EventList.T Time (Bundle a)) filter p = State.state $ EventList.foldrPair (\t evs -> let (evsT,evsF) = List.partition (p . snd) evs in mapPair (EventList.cons t evsT, EventList.cons t evsF)) (EventList.empty, EventList.empty) filterSimple :: (a -> Bool) -> EventList.T Time (Bundle a) -> EventList.T Time (Bundle a) filterSimple p = EventList.foldrPair (\t evs -> EventList.cons t (List.filter (p . snd) evs)) EventList.empty {- merge :: EventList.T Time (Bundle a) -> EventList.T Time (Bundle a) -> EventList.T Time (Bundle a) merge x y = {- fmap concat $ EventList.collectCoincident $ -} EventList.mergeBy (\_ _ -> True) x y -} merge :: EventList.T Time (Bundle a) -> EventList.T Time (Bundle a) -> EventList.T Time (Bundle a) merge x0 y0 = flip (EventList.switchL y0) x0 $ \(tx,bx) rx -> flip (EventList.switchL x0) y0 $ \(ty,by) ry -> let (tz, ~(bz, rz)) = mapSnd (\ ~(b,d) -> if b then mapFst (bx++) $ if d == NonNeg.zero then (by, merge rx ry) else ([], merge rx (EventList.cons d by ry)) else (by, merge (EventList.cons d bx rx) ry)) $ NonNeg.split tx ty in EventList.cons tz bz rz -- * run filters process :: (EventList.T Time Event.Data -> EventList.T Time EventDataTrigger) -> ReaderT Handle IO () process f = do Common.startQueue outputTriggerEvents . f =<< inputEvents processSimple :: (EventList.T Time Event.Data -> EventList.T Time EventDataBundle) -> ReaderT Handle IO () processSimple f = do Common.startQueue outputEventBundles . f =<< inputEvents runWhirl :: ReaderT Handle IO () runWhirl = process ({- we must prepend the trigger event, otherwise 'mergeGenerated' makes us wait for the first user event -} EventList.cons 0 [(0,Trigger)] . mergeGenerated whirl . fmap singletonBundle) runDelay :: ReaderT Handle IO () runDelay = processSimple (fmap (Common.delayAdd 50 0.3)) runKeyboardSplit :: ReaderT Handle IO () runKeyboardSplit = processSimple $ uncurry merge . State.runState (do low <- filter (\e -> (checkChannel (ChannelMsg.toChannel 0 ==) e && checkPitch (VoiceMsg.toPitch 60 >) e) || checkController (VoiceMsg.toController 91 ==) e || checkController (VoiceMsg.toController 93 ==) e) return $ fmap (mapMaybe (\(t,p) -> fmap ((,) t) $ Common.transpose 12 p) . map (mapSnd (Common.setChannel (ChannelMsg.toChannel 1)))) low) . fmap singletonBundle runKeyboardSplitLow :: ReaderT Handle IO () runKeyboardSplitLow = processSimple $ fmap (mapMaybe (\(t,p) -> fmap ((,) t) $ Common.transpose 12 p) . map (mapSnd (Common.setChannel (ChannelMsg.toChannel 1)))) . filterSimple (\e -> (checkChannel (ChannelMsg.toChannel 0 ==) e && checkPitch (VoiceMsg.toPitch 60 >) e) || checkController (VoiceMsg.toController 91 ==) e || checkController (VoiceMsg.toController 93 ==) e) . fmap singletonBundle runKeyboardSplitHigh :: ReaderT Handle IO () runKeyboardSplitHigh = processSimple $ -- fmap (map (mapSnd (setChannel (ChannelMsg.toChannel 0)))) . filterSimple (\e -> (checkChannel (ChannelMsg.toChannel 0 ==) e && checkPitch (VoiceMsg.toPitch 60 <=) e) || checkController (const True) e || checkProgram (const True) e) . fmap singletonBundle {- this defers events occasionally EventList.collectCoincident . fmap ((,) 0) -} runNote :: Channel -> Time -> Velocity -> Pitch -> ReaderT Handle IO () runNote chan dur vel pit = let note = Event.simpleNote (MALSA.fromChannel chan) (MALSA.fromPitch pit) (MALSA.fromVelocity vel) in do outputEvent 0 (Event.NoteEv Event.NoteOn note) outputEvent (incTime dur 0) (Event.NoteEv Event.NoteOff note) runKey :: Channel -> Bool -> Velocity -> Pitch -> ReaderT Handle IO () runKey chan noteOn vel pit = outputEvent 0 (Event.NoteEv (if noteOn then Event.NoteOn else Event.NoteOff) (Event.simpleNote (MALSA.fromChannel chan) (MALSA.fromPitch pit) (MALSA.fromVelocity vel))) runController :: Channel -> Controller -> Int -> ReaderT Handle IO () runController chan ctrl val = outputEvent 0 (Event.CtrlEv Event.Controller $ Event.Ctrl { Event.ctrlChannel = MALSA.fromChannel chan, Event.ctrlParam = MALSA.fromController ctrl, Event.ctrlValue = fromIntegral val }) runProgram :: Channel -> Program -> ReaderT Handle IO () runProgram chan pgm = outputEvent 0 (Event.CtrlEv Event.PgmChange $ Event.Ctrl { Event.ctrlChannel = MALSA.fromChannel chan, Event.ctrlParam = 0, Event.ctrlValue = MALSA.fromProgram pgm }) {- | > runCyclePrograms (map VoiceMsg.toProgram [8..12]) -} runCyclePrograms :: [Program] -> ReaderT Handle IO () runCyclePrograms pgms = processSimple (flip State.evalState (cycle pgms) . Trav.traverse (Common.traverseProgramsSeek (length pgms))) {- | > runProgramsAsBanks [8,4,4] -} runProgramsAsBanks :: [Int32] -> ReaderT Handle IO () runProgramsAsBanks ns = processSimple (fmap singletonBundle . flip State.evalState (Match.replicate ns 0) . Trav.traverse (Common.programsAsBanks ns)) {- | > runPattern 0.12 (cycleUp 4) -} runPattern :: Time -> Pattern i -> ReaderT Handle IO () runPattern dur pat = process (uncurry pattern pat dur) {- | > runPatternTempo 0.12 (cycleUp 4) > runPatternTempo 0.2 (selectFromOctaveChord, cycle [0,1,2,0,1,2,0,1]) -} runPatternTempo :: Time -> Pattern i -> ReaderT Handle IO () runPatternTempo dur pat = process (uncurry patternTempo pat (Common.defaultTempoCtrl, (0.5*dur, dur, 1.5*dur))) {- | > runPatternMultiTempo 0.1 (selectFromLimittedChord, let pat = [item 0 1] ./ 1 /. [item 1 1] ./ 2 /. [item 1 1] ./ 1 /. [item 0 1] ./ 2 /. pat in 0 /. pat) -} runPatternMultiTempo :: Time -> PatternMulti i -> ReaderT Handle IO () runPatternMultiTempo dur pat = process (uncurry patternMultiTempo pat (Common.defaultTempoCtrl, (0.5*dur, dur, 1.5*dur))) runFilterSweep :: ReaderT Handle IO () runFilterSweep = process (sweep (ChannelMsg.toChannel 1) 0.01 (VoiceMsg.toController 72, (0.1, 1)) (VoiceMsg.toController 73) (VoiceMsg.toController 91) (sin . (2*pi*))) main :: IO () main = (with $ do liftIO $ putStrLn "Please connect me to a synth" liftIO $ getLine Common.startQueue liftIO . mapM_ print =<< inputEventsCore outputEvents =<< inputEvents outputEventBundles whirl outputEvents . EventList.mapMaybe (Common.transpose 1) =<< inputEvents) `Exc.catch` \e -> putStrLn $ "alsa_exception: " ++ Exc.show e {- stateless map: only send an output event if there was an input event without maintaining a state change channel, program, transposition split stream according to channel, program, pitch merge two streams convert key-press events to controller changes this way we can control the filter frequency of a resonant lowpass or we can control an external analogue synthesizer convert keypress intervals to a gate signal with according velocity this way we can generate an envelope for the resonance of a lowpass or we can control an external analogue synthesizer stateful map: only send an output event if there was an input event while maintaining a state add a bass tone to a chord hold a key or a chord until the next one is played play something on releasing the keys this way we could control Guitar strokes up and down cycle through a set of instruments for each note played This way we can play syllables of a word like To-ma-ten-sa-lat. pattern: use a separate clock at which events can be scheduled patterns can be implemented by applying a stateful map to a beat stream play tones of current chord upwards, downwards, ping-pong or randomly generate pattern consisting of the current tone and the tone one octave above it generate repeated keystrokes for the key that is constantly pressed play current chord repeatedly in randomly chosen inversions patterns like parity of ones in binary numbers (cf. my Flip song) record and replay events in a loop generate MIDI controller events according to a function of time generate MIDI controller events by a random pattern, this may be used to control the cutoff frequency of a resonant filter delay events echo: play a note multiple times with a certain delay and decreasing velocity use the last n played notes for a pattern with lazy access to a list, we can simulate a queue -}