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.InfoMonad as PortInfo import qualified Sound.ALSA.Sequencer.Queue as Queue import qualified Sound.ALSA.Sequencer.Event as Event 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 import qualified Sound.MIDI.Message.Channel.Mode as Mode import Sound.MIDI.ALSA (normalNoteFromEvent, ) 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 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, ) -- * 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 Client.setName h "Haskell-Filter" c <- Client.getId h ppublic <- Port.createSimple h "inout" (Port.caps [Port.capRead, Port.capSubsRead, Port.capWrite, Port.capSubsWrite]) Port.typeMidiGeneric pprivate <- Port.createSimple h "private" (Port.caps [Port.capRead, Port.capWrite]) Port.typeMidiGeneric q <- Queue.alloc h let hnd = Handle h c ppublic pprivate q Reader.runReaderT setTimeStamping hnd return hnd exit :: Handle -> IO () exit h = do _ <- Event.outputPending (sequ h) Queue.free (sequ h) (queue h) Port.delete (sequ h) (portPublic h) Port.delete (sequ h) (portPrivate h) SndSeq.close (sequ h) with :: ReaderT Handle IO a -> IO a with f = SndSeq.with SndSeq.defaultName SndSeq.Block $ \h -> do Client.setName h "Haskell-Filter" c <- Client.getId h Port.withSimple h "inout" (Port.caps [Port.capRead, Port.capSubsRead, Port.capWrite, Port.capSubsWrite]) Port.typeMidiGeneric $ \ppublic -> do Port.withSimple h "private" (Port.caps [Port.capRead, Port.capWrite]) Port.typeMidiGeneric $ \pprivate -> do Queue.with h $ \q -> flip Reader.runReaderT (Handle h c ppublic pprivate q) $ setTimeStamping >> f -- | make ALSA set the time stamps in incoming events setTimeStamping :: ReaderT Handle IO () 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 Nothing _ <- Event.drainOutput (sequ h) return () {- | 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 inputs [timidity] connectLLVM :: ReaderT Handle IO () connectLLVM = connect inputs [haskellSynth] 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.T -> 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) outputEvent t (Event.NoteEv Event.NoteOff note) sendKey :: Channel -> Bool -> Velocity -> Pitch -> ReaderT Handle IO () sendKey chan noteOn vel pit = outputEvent 0 $ 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 $ Event.CtrlEv Event.Controller $ MALSA.controllerEvent chan ctrl (fromIntegral val) sendProgram :: Channel -> Program -> ReaderT Handle IO () sendProgram chan pgm = outputEvent 0 $ Event.CtrlEv Event.PgmChange $ MALSA.programChangeEvent chan pgm sendMode :: Channel -> Mode.T -> ReaderT Handle IO () sendMode chan mode = outputEvent 0 $ 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 {- | This class unifies several ways of handling multiple events at once. -} class Events ev where flattenEvents :: ev -> [Future Event.Data] instance Events Event.Data where 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 (Mn.mappend t dt) e) $ flattenEvents ev instance Events ev => Events (Maybe ev) where flattenEvents ev = maybe [] flattenEvents ev instance Events ev => Events [ev] where flattenEvents = concatMap flattenEvents instance (Events ev0, Events ev1) => Events (ev0,ev1) where flattenEvents (ev0,ev1) = flattenEvents ev0 ++ flattenEvents ev1 instance (Events ev0, Events ev1, Events ev2) => Events (ev0,ev1,ev2) where flattenEvents (ev0,ev1,ev2) = flattenEvents ev0 ++ flattenEvents ev1 ++ flattenEvents ev2 makeEvent :: Handle -> Time.Abs -> 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 } 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 :: 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) >> return () simpleNote :: Channel -> Pitch -> Velocity -> Event.Note simpleNote c p v = Event.simpleNote (MALSA.fromChannel c) (MALSA.fromPitch p) (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 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 = case e of Event.NoteEv notePart note -> Event.NoteEv notePart $ (MALSA.noteChannel ^= chan) note Event.CtrlEv ctrlPart ctrl -> Event.CtrlEv ctrlPart $ (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 [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 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 delayAdd decay d e = singletonBundle e ++ case e of Event.NoteEv notePart note -> [Future d $ Event.NoteEv notePart $ reduceNoteVelocity decay note] _ -> [] {- | 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 :: Channel -> Controller -> Event.Ctrl -> Bool controllerMatch chan ctrl param = Event.ctrlChannel param == MALSA.fromChannel chan && Event.ctrlParam param == MALSA.fromController ctrl checkChannel :: (Channel -> Bool) -> (Event.Data -> Bool) checkChannel p e = case e of Event.NoteEv _notePart note -> p (note ^. MALSA.noteChannel) Event.CtrlEv Event.Controller ctrl -> p (ctrl ^. MALSA.ctrlChannel) _ -> False checkPitch :: (Pitch -> Bool) -> (Event.Data -> Bool) checkPitch p e = case e of Event.NoteEv _notePart note -> p (note ^. MALSA.notePitch) _ -> False checkController :: (Controller -> Bool) -> (Event.Data -> Bool) checkController p e = case e of Event.CtrlEv Event.Controller ctrlMode -> case ctrlMode ^. MALSA.ctrlControllerMode of MALSA.Controller ctrl _ -> p ctrl _ -> False _ -> False checkMode :: (Mode.T -> Bool) -> (Event.Data -> Bool) checkMode p e = case e of Event.CtrlEv Event.Controller ctrlMode -> case ctrlMode ^. MALSA.ctrlControllerMode of MALSA.Mode mode -> p mode _ -> False _ -> False checkProgram :: (Program -> Bool) -> (Event.Data -> Bool) checkProgram p e = case e of Event.CtrlEv Event.PgmChange ctrl -> p (ctrl ^. MALSA.ctrlProgram) _ -> False isAllNotesOff :: Event.Data -> Bool isAllNotesOff = 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)