module Sound.Tidal.MIDI.Stream (midiStream, midiBackend, midiState, midiSetters, midiDevices,send) where
import Control.Monad.Trans.Maybe
import qualified Data.Map as Map
import Data.List (sortBy)
import Data.Maybe
import Data.Ord (comparing)
import Data.Time (getCurrentTime, UTCTime, diffUTCTime)
import Data.Time.Clock.POSIX
import Control.Concurrent
import Control.Concurrent.MVar
import Data.Bits
import Foreign.C
import Control.Applicative
import Numeric
import Sound.Tidal.Tempo (Tempo, cps, clockedTick)
import Sound.Tidal.Stream as S
import Sound.Tidal.Utils
import Sound.Tidal.Time
import Sound.Tidal.Transition (transition)
import Sound.Tidal.MIDI.Device
import Sound.Tidal.MIDI.Control
import qualified Sound.PortMidi as PM
type ConnectionCount = Int
type TickedConnectionCount = Int
type OutputOnline = Bool
type OutputState = (TickedConnectionCount, ConnectionCount, OutputOnline)
type MIDITime = (Tempo, Int, Double, Double)
type MIDIEncoder = CULong -> PM.PMEvent
type MIDIEvent = (MIDITime, MIDIEncoder)
data Output = Output {
conn :: PM.PMStream,
buffer :: MVar [MIDIEvent],
bufferstate :: MVar OutputState
}
type MidiMap = Map.Map S.Param (Maybe Int)
type MidiDeviceMap = Map.Map String Output
toMidiEvent :: ControllerShape -> S.Param -> Value -> Maybe Int
toMidiEvent s p (VF x) = ($) <$> mscale <*> mrange <*> pure x
where
mrange = fmap range mcc
mscale = fmap scalef mcc
mcc = paramN s p
toMidiEvent s p (VI x) = Just x
toMidiEvent s p (VS x) = Nothing
toMidiMap :: ControllerShape -> S.ParamMap -> MidiMap
toMidiMap s m = Map.mapWithKey (toMidiEvent s) (Map.mapMaybe (id) m)
send s ch cshape shape change tick o ctrls (tdur:tnote:trest) = midi
where
midi = sendmidi s cshape ch' (note, vel, dur) (change, tick, o, offset) ctrls
note = fromIntegral $ ivalue $ snd tnote
dur = realToFrac $ fvalue $ snd tdur
(vel, nudge) = case length trest of
2 -> (mkMidi $ trest !! 1, fvalue $ snd $ trest !! 0)
1 -> (mkMidi $ trest !! 0, 0)
ch' = fromIntegral ch
mkMidi = fromIntegral . floor . (*127) . fvalue . snd
offset = ((Sound.Tidal.MIDI.Control.latency cshape) + nudge)
mkSend cshape channel s = return $ (\ shape change tick (o,m) -> do
let defaulted = (S.applyShape' shape m)
mpartition = fmap (Map.partitionWithKey (\k _ -> (name k) `elem` ["dur", "n", "velocity", "nudge"])) defaulted
props = fmap fst mpartition
ctrls = fmap snd mpartition
props' = fmap (Map.toAscList) $ fmap (Map.mapMaybe (id)) props
ctrls' = fmap (Map.filterWithKey (\k v -> v /= (defaultValue k))) ctrls
ctrls'' = fmap (toMidiMap cshape) ctrls'
send' = fmap (send s channel cshape shape change tick o) ctrls''
($) <$> send' <*> props'
)
connected cshape channel name s = do
putStrLn ("Successfully initialized Device '" ++ name ++ "'")
changeState goOnline s
mkSend cshape channel s
failed di err = do
error (show err ++ ": " ++ show di)
notfound name = do
putStrLn "List of Available Device Names"
putStrLn =<< displayOutputDevices
error ("Device '" ++ show name ++ "' not found")
readState f o = do
s <- readMVar $ bufferstate o
let fs = f s
(ticked, conns, online) = s
return fs
isCycling (0, conns, True) = True
isCycling _ = False
displayState (ticked, conns, online) = show ticked ++ "/" ++ show conns ++ "[" ++ show online ++ "]"
changeState f o = do
bs <- takeMVar stateM
let fs = f bs
(ticked, conns, online) = fs
putMVar stateM $ fs
where
stateM = bufferstate o
goOnline (ticked, conns, online) = (ticked, conns, True)
addConnection (ticked, conns, online) = (ticked, conns + 1, online)
tickConnections (ticked, conns, online) = ((ticked + 1) `mod` conns, conns, online)
useOutput outsM name lat = do
outs <- readMVar outsM
let outM = Map.lookup name outs
case outM of
Just o -> do
putStrLn "Cached Device Output"
changeState addConnection o
return $ Just o
Nothing -> do
devidM <- (>>= maybe (failed name "Failed opening MIDI Output Device ID") return) (getIDForDeviceName name)
econn <- outputDevice devidM lat
case econn of
Left o -> do
changeState addConnection o
swapMVar outsM $ Map.insert name o outs
return $ Just o
Right _ -> return Nothing
makeConnection :: MVar (MidiDeviceMap) -> String -> Int -> ControllerShape -> IO ((S.ToMessageFunc), Output)
makeConnection devicesM deviceName channel cshape = do
moutput <- useOutput devicesM deviceName 1
case moutput of
Just o -> do
s <- connected cshape channel deviceName o
return (s, o)
Nothing ->
error "Failed"
showLate :: (CULong, Double, PM.PMEvent, CULong, UTCTime) -> String
showLate (o, t, e, m, n) =
unwords ["late",
(show $ (\x -> [PM.status x, PM.data1 x, PM.data2 x]) $ PM.decodeMsg $ PM.message e),
"midi now ", show m, " midi onset: ", show o,
"onset (relative): ", show $ showFFloat (Just 3) (t (realToFrac $ utcTimeToPOSIXSeconds n)) "",
", sched: ", show $ PM.timestamp e]
flushBackend :: Output -> S.Shape -> Tempo -> Int -> IO ()
flushBackend o shape change ticks = do
changeState tickConnections o
cycling <- readState isCycling o
case cycling of
True -> do
late <- sendevents o shape change ticks
let len = length late
case len of
0 ->
return ()
_ -> do
putStrLn $ showLate $ head late
putStrLn $ "and " ++ show (len 1) ++ " more"
False -> do
s <- readState displayState o
return ()
midiDevices :: IO (MVar (MidiDeviceMap))
midiDevices = do
newMVar $ Map.fromList []
midiBackend d n c cs = do
(s, o) <- makeConnection d n c cs
return $ Backend s (flushBackend o)
midiStream d n c s = do
backend <- midiBackend d n c s
stream backend (toShape s)
midiState d n c s = do
backend <- midiBackend d n c s
S.state backend (toShape s)
midiSetters :: MVar (MidiDeviceMap) -> String -> Int -> ControllerShape -> IO Time -> IO (ParamPattern -> IO (), (Time -> [ParamPattern] -> ParamPattern) -> ParamPattern -> IO ())
midiSetters d n c s getNow = do
ds <- midiState d n c s
return (setter ds, transition getNow ds)
toDescriptor midiTime now (o,m,t,e) = (o,t,e, midiTime, now)
calcOnsets (a@(tempo, tick, onset, offset), e) = (a, logicalOnset' tempo tick onset offset, e)
showEvent :: PM.PMEvent -> String
showEvent e = show t ++ " " ++ show msg
where msg = PM.decodeMsg $ PM.message e
t = PM.timestamp e
showRawEvent :: (CULong, MIDITime, Double, PM.PMEvent) -> String
showRawEvent (midionset, (tempo,tick,onset,offset), logicalOnset, e) = show onset ++ " " ++ " / " ++ show logicalOnset ++ " " ++ showEvent e
sendevents :: Output -> S.Shape -> Tempo -> Int -> IO ([(CULong, Double, PM.PMEvent, CULong, UTCTime)])
sendevents stream shape change ticks = do
let buf = buffer stream
output = conn stream
buf' <- tryTakeMVar buf
case buf' of
Nothing -> do
return []
Just [] -> do
putMVar buf []
return []
(Just evts@(x:xs)) -> do
midiTime <- PM.time
now <- getCurrentTime
let offset = S.latency shape
nextTick = logicalOnset' change (ticks+1) 0 offset
onsets = map calcOnsets evts
(evts', later) = span ((< nextTick).(\(_,o,_) -> o)) $ sortBy (comparing (\(_,o,_) -> o)) onsets
evts'' = map (\(t, o, e) -> let midionset = scheduleTime midiTime now o
in (midionset, t, o, e midionset)) evts'
later' = map (\(t,o,e) -> (t,e)) later
evts''' = map (\(_,_,_,e) -> e) evts''
late = map (toDescriptor midiTime now) $ filter (\(_,_,t,_) -> t < (realToFrac $ utcTimeToPOSIXSeconds now)) $ evts''
err <- PM.writeEvents output evts'''
putMVar buf later'
case err of
PM.NoError -> do
return late
e -> do
putStrLn "sending failed"
return []
sendctrls :: Output -> ControllerShape -> CLong -> MIDITime -> MidiMap -> IO ()
sendctrls stream shape ch t ctrls = do
let ctrls' = filter ((>=0) . snd) $ Map.toList $ Map.mapMaybe (id) ctrls
sequence_ $ map (\(param, ctrl) -> makeCtrl stream ch (fromJust $ paramN shape param) (fromIntegral ctrl) t) ctrls'
return ()
sendnote :: Output -> t -> CLong -> (CLong, CLong, Double) -> MIDITime -> IO ()
sendnote stream shape ch (note,vel, dur) (tempo,tick,onset,offset) =
do
noteOn stream ch midinote vel (tempo,tick,onset,offset)
noteOff stream ch midinote (tempo, tick, onset, offset + dur)
return ()
where midinote = note + 60
scheduleTime :: CULong -> UTCTime -> Double -> CULong
scheduleTime mnow' now' logicalOnset = t
where
now = realToFrac $ utcTimeToPOSIXSeconds $ now'
mnow = fromIntegral mnow'
t = floor $ mnow + (1000 * (logicalOnset now))
sendmidi :: Output -> ControllerShape -> CLong -> (CLong, CLong, Double) -> MIDITime -> MidiMap -> IO ()
sendmidi stream shape ch n t ctrls = do
sendmidi' stream shape ch n t ctrls
return ()
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 ()
encodeChannel :: (Bits a, Num a) => a -> a -> a
encodeChannel ch cc = ((() ch 1) .|. cc)
noteOn :: Output -> CLong -> CLong -> CLong -> MIDITime -> IO (Maybe a)
noteOn o ch val vel t = do
let evt = (t, \t' -> makeEvent 0x90 val ch vel t')
sendEvent o evt
noteOff :: Output -> CLong -> CLong -> MIDITime -> IO (Maybe a)
noteOff o ch val t = do
let evt = (t, \t' -> makeEvent 0x80 val ch 60 t')
sendEvent o evt
makeCtrl :: Output -> CLong -> ControlChange -> CLong -> MIDITime -> IO (Maybe a)
makeCtrl o ch (CC {midi=midi, range=range}) n t = makeCC o ch (fromIntegral midi) n t
makeCtrl o ch (NRPN {midi=midi, range=range}) n t = makeNRPN o ch (fromIntegral midi) n t
makeCC :: Output -> CLong -> CLong -> CLong -> MIDITime -> IO (Maybe a)
makeCC o ch c n t = do
let evt = (t, \t' -> makeEvent 0xB0 c ch n t')
sendEvent o evt
makeNRPN :: Output -> CLong -> CLong -> CLong -> MIDITime -> IO (Maybe a)
makeNRPN o ch c n t = do
let nrpn = makeEvent 0xB0
evts = [(t, (\t' -> nrpn 0x63 ch (shift (c .&. 0x3F80) (7)) t')),
(t, (\t' -> nrpn 0x62 ch (c .&. 0x7F) t')),
(t, (\t' -> nrpn 0x06 ch (shift (n .&. 0x3F80) (7)) t')),
(t, (\t' -> nrpn 0x26 ch (n .&. 0x7F) t'))
]
mapM (sendEvent o) evts
return Nothing
outputDevice :: PM.DeviceID -> Int -> IO (Either Output PM.PMError)
outputDevice deviceID latency = do
PM.initialize
now <- getCurrentTime
result <- PM.openOutput deviceID latency
bs <- newMVar (0, 0, False)
case result of
Left dev ->
do
info <- PM.getDeviceInfo deviceID
putStrLn ("Opened: " ++ show (PM.interface info) ++ ": " ++ show (PM.name info))
buffer <- newMVar []
return (Left Output { conn=dev, buffer=buffer, bufferstate=bs })
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.encodeMsg $ PM.PMMsg (encodeChannel ch st) (n) (v)
sendEvent :: Output -> (MIDITime, (CULong -> PM.PMEvent)) -> IO (Maybe a)
sendEvent o evt = do
let buf = buffer o
cbuf <- takeMVar buf
putMVar buf (cbuf ++ [evt])
return Nothing