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, )
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
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 :: [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
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
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)
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)
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
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
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 :: Real i => [i] -> i -> [i] -> (Bool, [i])
replaceProgram (n:ns) pgm pt =
let (p,ps) =
case pt of
[] -> (0,[])
(x:xs) -> (x,xs)
in if pgm<n
then (True, pgm:ps)
else mapSnd (p:) $
replaceProgram ns (pgmn) ps
replaceProgram [] _ ps = (False, ps)
programFromBanks :: Real i => [i] -> [i] -> i
programFromBanks ns ps =
foldr (\(n,p) s -> p+n*s) 0 $
zip ns ps
programsAsBanks ::
[Int] ->
Event.Data -> State.State [Int] Event.Data
programsAsBanks ns e =
case e of
Event.CtrlEv Event.PgmChange ctrl -> State.state $ \ps0 ->
let pgm = Event.ctrlValue ctrl
(valid, ps1) =
replaceProgram ns (fromIntegral $ Event.unValue pgm) ps0
in (Event.CtrlEv Event.PgmChange $
ctrl{Event.ctrlValue =
if valid
then Event.Value $ fromIntegral $ programFromBanks ns ps1
else pgm},
ps1)
_ -> return e
nextProgram :: Event.Note -> State.State [Program] (Maybe Event.Data)
nextProgram note =
State.state $ \pgms ->
case pgms of
pgm:rest ->
(Just $
Event.CtrlEv Event.PgmChange $
Event.Ctrl {
Event.ctrlChannel = Event.noteChannel note,
Event.ctrlParam = Event.Parameter 0,
Event.ctrlValue = MALSA.fromProgram pgm},
rest)
[] -> (Nothing, [])
seekProgram :: Int -> Program -> State.State [Program] (Maybe Event.Data)
seekProgram maxSeek pgm =
fmap (const Nothing) $
State.modify $
uncurry (++) .
mapFst (dropWhile (pgm/=)) .
splitAt maxSeek
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
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 (vel1)}
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]
_ -> []
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
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 (1k) minDur `Mn.mappend` Time.scale k maxDur
ctrlDurExponential ::
(Time.T, Time.T) -> Int -> Time.T
ctrlDurExponential (minDur, maxDur) val =
Time.scale (Time.div maxDur minDur ** (fromIntegral val / 127)) minDur
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)
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)