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
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]
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
midiclock stream = do
forkIO $ do clockedTick 1 $ onClockTick stream
onClockTick stream current ticks = do
time <- PM.time
mapM_ (makeMidiClockTick stream) (map ((+time).round.(/(24*(cps current))).(*1000)) [0..23])
return ()
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
(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
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)
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)
encodeChannel :: (Bits a, Num a) => a -> a -> a
encodeChannel ch cc = ((() ch 1) .|. cc)
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))
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
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,
0x3E,
0x13,
0x00,
0x20,
0x00,
shift (c .&. 0x3F80) (7),
(c .&. 0x7F),
n,
0xF7
]
msg = B.pack $ bytes
sendSysEx o t (BC.unpack msg)
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 ()
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
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