tidal-midi-0.1: Sound/Tidal/MIDI/Output.hs
module Sound.Tidal.MIDI.Output (midiproxy) where
import qualified Sound.PortMidi as PM
import Sound.Tidal.MIDI.Device
import Data.Time (getCurrentTime, UTCTime, diffUTCTime)
import Data.Time.Clock.POSIX
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import Sound.OSC.FD
import Control.Monad
import Control.Concurrent.MVar
import Data.Bits
import Data.Char
import Data.List (sortBy)
import Data.Maybe
import Data.Ord (comparing)
import Data.Word (Word8)
import Control.Concurrent
import Foreign.C
import qualified Sound.Tidal.MIDI.Control as C
import Sound.Tidal.Pattern
import Sound.Tidal.Tempo
import qualified Sound.Tidal.Stream as S (stream, name, params, OscPattern, OscShape)
import System.IO.Error
data Output = Output {
conn :: PM.PMStream,
lock :: MVar (),
offset :: (Int, Int),
buffer :: MVar [PM.PMEvent]
}
midiproxy :: Int -> String-> [(C.ControllerShape, Int)] -> IO [IO (S.OscPattern -> IO ())]
midiproxy latency deviceName targets = do
let keyStreams = map (\(shape, channel) -> makeStream (C.toOscShape shape) (channel + 7303)) targets
deviceID <- getIDForDeviceName deviceName
case deviceID of
Nothing -> do putStrLn "List of Available Device Names"
putStrLn =<< displayOutputDevices
error ("Device '" ++ show deviceName ++ "' not found")
Just id -> do econn <- outputDevice id latency
case econn of
Right err -> error ("Failed opening MIDI Output on Device ID: " ++ show deviceID ++ " - " ++ show err)
Left conn -> do
sendevents conn
--midiclock conn
mapM_ (\(shape,channel) -> messageLoop conn shape (fromIntegral channel) (channel + 7303)) targets
return keyStreams
messageLoop :: Output -> C.ControllerShape -> CLong -> Int -> IO ThreadId
messageLoop stream shape ch port = do
putStrLn ("Starting message loop on port " ++ show port ++ " for MIDI channel " ++ show ch)
x <- udpServer "127.0.0.1" port
forkIO $ loop stream x ch
where loop stream x ch = do m <- recvMessage x
act stream m ch
loop stream x ch
act stream (Just (Message "/note" (sec:usec:note:dur:vel:ctrls))) ch =
do
let diff = timeDiff (sec, usec) (offset stream)
note' = (fromJust $ d_get note) :: Int
vel' = (fromJust $ d_get vel) :: Float
dur' = (fromJust $ d_get dur) :: Float
ctrls' = (map (fromJust . d_get) ctrls) :: [Float]
-- mTime <- PM.time
-- putStrLn ("MIDI in: " ++ (show (diff - mTime)))
sendmidi stream shape ch (fromIntegral note', fromIntegral $ C.mapRange (0, 127) (realToFrac vel'), realToFrac dur') (diff) ctrls'
return()
makeStream :: S.OscShape -> Int -> IO (S.OscPattern -> IO ())
makeStream shape port = S.stream "127.0.0.1" port shape
-- EXPERIMENTAL
midiclock stream = do
forkIO $ do clockedTick 1 $ onClockTick stream
onClockTick stream current ticks = do
-- schedule MIDI Clock Ticks ahead of time to avoid jumps in timing
-- e.g. if one tick per cycle
-- schedule 24 ticks ahead of time starting now with PM.time and incrementing each timestamp by ((1/cycle per seconds)/24)*1000 for ms for each tick
time <- PM.time
mapM_ (makeMidiClockTick stream) (map ((+time).round.(/(24*(cps current))).(*1000)) [0..23])
return ()
-- END EXPERIMENTAL
sendevents :: Output -> IO ThreadId
sendevents stream = do
forkIO $ do loop stream
where loop stream = do act stream
delay
loop stream
act stream = do
let buf = buffer stream
o = conn stream
buf' <- tryTakeMVar buf
case buf' of
Nothing -> do
return Nothing
Just [] -> do
putMVar buf []
return Nothing
(Just evts@(x:xs)) -> do
midiTime <- PM.time
let evts' = sortBy (comparing PM.timestamp) evts
nextTick = fromIntegral $ midiTime + 1 -- advance on millisecond, i.e. the next call of this loop
(evts'',later) = span (\x -> (((PM.timestamp x) < midiTime)) || ((PM.timestamp x) < nextTick)) evts'
putMVar buf later
err <- PM.writeEvents o evts''
case err of
PM.NoError -> return Nothing
e -> return $ Just (userError ("Error '" ++ show e ++ "' sending Events: " ++ show evts))
delay = threadDelay 1000 -- in microseconds, i.e. one millisecond
sendctrls :: Output -> C.ControllerShape -> CLong -> CULong -> [Float] -> IO ()
sendctrls stream shape ch t ctrls = do
let ctrls' = filter ((>=0) . snd) (zip (C.toKeynames shape) ctrls)
sequence_ $ map (\(name, ctrl) -> makeCtrl stream ch (C.paramN shape name) ctrl t) ctrls'
return ()
sendnote :: RealFrac s => Output -> t -> CLong -> (CLong, CLong, s) -> CULong -> IO ThreadId
sendnote stream shape ch (note,vel, dur) t =
do forkIO $ do noteOn stream ch note vel t
noteOff stream ch note (t + (floor $ 1000 * dur))
return ()
sendmidi :: RealFrac s => Output -> C.ControllerShape -> CLong -> (CLong, CLong, s) -> CULong -> [Float] -> IO ()
sendmidi stream shape ch (128,vel,dur) t ctrls = do
sendctrls stream shape ch t ctrls
return ()
sendmidi stream shape ch (note,vel,dur) t ctrls = do
sendnote stream shape ch (note,vel,dur) t
sendctrls stream shape ch t ctrls
return ()
timeDiff :: (Integral b, Integral a1, Integral a) => (Datum, Datum) -> (a, a1) -> b
timeDiff (ds, du) (s, u) = diff d i
where diff a b = floor ((a - b) * 1000) -- as millis
d = asFrac jds jdu
i = asFrac s u
jds = (fromJust $ d_get ds) :: Int
jdu = (fromJust $ d_get du) :: Int
asFrac a b = (fromIntegral a) + ((fromIntegral b) * 0.000001)
-- MIDI Utils
encodeChannel :: (Bits a, Num a) => a -> a -> a
encodeChannel ch cc = (((-) ch 1) .|. cc)
-- MIDI Messages
noteOn :: Output -> CLong -> CLong -> CLong -> CULong -> IO (Maybe a)
noteOn o ch val vel t = do
let evt = makeEvent 0x90 val ch vel t
sendEvent o evt
noteOff :: Output -> CLong -> CLong -> CULong -> IO (Maybe a)
noteOff o ch val t = do
let evt = makeEvent 0x80 val ch 60 t
sendEvent o evt
makeCtrl :: Output -> CLong -> C.Param -> Float -> CULong -> IO (Maybe a)
makeCtrl o ch (C.CC {C.midi=midi, C.range=range, C.scalef=f}) n t = makeCC o ch (fromIntegral midi) scaledN t
where scaledN = fromIntegral (f range (n))
makeCtrl o ch (C.NRPN {C.midi=midi, C.range=range, C.scalef=f}) n t = makeNRPN o ch (fromIntegral midi) scaledN t
where scaledN = fromIntegral $ (f range (n))
makeCtrl o ch (C.SysEx {C.midi=midi, C.range=range, C.scalef=f}) n t = makeSysEx o ch (fromIntegral midi) scaledN t
where scaledN = fromIntegral $ (f range (n))
-- This is sending CC
makeCC :: Output -> CLong -> CLong -> CLong -> CULong -> IO (Maybe a)
makeCC o ch c n t = do
let evt = makeEvent 0xB0 c ch n t
sendEvent o evt
-- This is sending NRPN
makeNRPN :: Output -> CLong -> CLong -> CLong -> CULong -> IO (Maybe a)
makeNRPN o ch c n t = do
let nrpn = makeEvent 0xB0
evts = [nrpn 0x63 ch (shift (c .&. 0x3F80) (-7)) t,
nrpn 0x62 ch (c .&. 0x7F) t,
nrpn 0x06 ch (shift (n .&. 0x3F80) (-7)) t,
nrpn 0x26 ch (n .&. 0x7F) t
]
mapM (sendEvent o) evts
return Nothing
makeMidiClockTick o t = do
sendEvent o $ PM.PMEvent (PM.PMMsg 0xF8 0x00 0x00) t
makeSysEx :: Output -> t -> Word8 -> Word8 -> CULong -> IO (Maybe a)
makeSysEx o ch c n t = do
let bytes = [0xF0, -- SysEx Start
0x3E, -- Vendor ID
0x13, -- Equipment ID
0x00, -- Device No.
0x20, -- Message ID
0x00, -- Location
shift (c .&. 0x3F80) (-7), -- Parameter Index high byte
(c .&. 0x7F), -- Parameter Index low byte
n, -- Parameter Value
0xF7 -- End of SysEx
]
msg = B.pack $ bytes
sendSysEx o t (BC.unpack msg)
-- PortMIDI Wrapper
outputDevice :: PM.DeviceID -> Int -> IO (Either Output PM.PMError)
outputDevice deviceID latency = do
PM.initialize
now <- getCurrentTime
result <- PM.openOutput deviceID latency
case result of
Left dev ->
do
info <- PM.getDeviceInfo deviceID
putStrLn ("Opened: " ++ show (PM.interface info) ++ ": " ++ show (PM.name info))
sem <- newEmptyMVar
putMVar sem () -- initially fill MVar to be taken by the first user of this output
buffer <- newMVar []
midiOffset <- PM.time
let posixNow = realToFrac $ utcTimeToPOSIXSeconds now
syncedNow = posixNow - ((0.001*) $ fromIntegral midiOffset)
sec = floor syncedNow
usec = floor $ 1000000 * (syncedNow - (realToFrac sec))
return (Left Output { conn=dev, lock=sem, offset=(sec, usec), buffer=buffer })
Right err -> return (Right err)
makeEvent :: CLong -> CLong -> CLong -> CLong -> CULong -> PM.PMEvent
makeEvent st n ch v t = PM.PMEvent msg (t)
where msg = PM.PMMsg (encodeChannel ch st) (n) (v)
sendSysEx :: Output -> CULong -> String -> IO (Maybe a)
sendSysEx o t msg = do
let sem = lock o
takeMVar sem
err <- PM.writeSysEx (conn o) t msg
putMVar sem ()
return Nothing
-- now with a semaphore since PortMIDI is NOT thread safe
sendEvent :: Output -> PM.PMEvent -> IO (Maybe a)
sendEvent o evt = do
let sem = lock o
buf = buffer o
cbuf <- takeMVar buf
putMVar buf (cbuf ++ [evt])
return Nothing