module Sound.SC3.Lang.Control.Midi where
import qualified Control.Exception as E
import Control.Monad
import "mtl" Control.Monad.State
import Data.Bits
import qualified Data.ByteString.Lazy as B
import qualified Data.Map as M
import Sound.OSC.FD
data Midi_Message a = Chanel_Aftertouch a a
| Control_Change a a a
| Note_On a a a
| Note_Off a a a
| Polyphic_Key_Pressure a a a
| Program_Change a a
| Pitch_Bend a a
| Unknown [a]
deriving (Eq,Show)
data Control_Message a = All_Notes_Off a
| All_Sound_Off a
| Balance a a
| Bank_Select a a
| Breath_Controller a a
| Expression_Controller a a
| Foot_Controller a a
| Local_Control a a
| Modulation_Wheel a a
| Mono_Mode_On a a
| Omni_Mode_Off a
| Omni_Mode_On a
| Pan a a
| Poly_Mode_On a
| Portamento_On_Off a a
| Portamento_Time a a
| Reset_All_Controllers a a
| Soft_Pedal_On_Off a a
| Sostenuto_On_Off a a
| Sustain_On_Off a a
| Undefined
deriving (Eq,Show)
control_message :: (Eq a,Num a) => (a,a,a) -> Control_Message a
control_message (i,j,k) =
case j of
0 -> Bank_Select i k
1 -> Modulation_Wheel i k
2 -> Breath_Controller i k
4 -> Foot_Controller i k
5 -> Portamento_Time i k
8 -> Balance i k
10 -> Pan i k
11 -> Expression_Controller i k
64 -> Sustain_On_Off i k
65 -> Portamento_On_Off i k
66 -> Sostenuto_On_Off i k
67 -> Soft_Pedal_On_Off i k
120 -> All_Sound_Off i
121 -> Reset_All_Controllers i k
122 -> Local_Control i j
123 -> All_Notes_Off i
124 -> Omni_Mode_Off i
125 -> Omni_Mode_On i
126 -> Mono_Mode_On i j
127 -> Poly_Mode_On i
_ -> Undefined
b_join :: Bits a => a -> a -> a
b_join p q = p .|. shiftL q 7
b_sep :: (Num t,Bits t) => t -> (t, t)
b_sep n = (0x7f .&. n,0xff .&. shiftR n 7)
parse_b :: Integral n => Message -> [n]
parse_b m =
case m of
Message "/midi" [Int _,Blob b] -> map fromIntegral (B.unpack b)
_ -> []
parse_c :: Integral n => Message -> [n]
parse_c m =
case parse_b m of
st:dt -> let (l,h) = st `divMod` 16 in l:h:dt
_ -> []
parse_m :: (Bits n,Integral n) => Message -> Midi_Message n
parse_m m =
case parse_c m of
[0x8,i,j,k] -> Note_Off i j k
[0x9,i,j,0] -> Note_Off i j 0
[0x9,i,j,k] -> Note_On i j k
[0xa,i,j,k] -> Polyphic_Key_Pressure i j k
[0xb,i,j,k] -> Control_Change i j k
[0xc,i,j] -> Program_Change i j
[0xd,i,j] -> Chanel_Aftertouch i j
[0xe,i,j,k] -> Pitch_Bend i (b_join j k)
x -> Unknown x
type Node_Id = Int
data K a = K (M.Map (a,a) Node_Id) Node_Id
type KT = StateT (K Int) IO
k_init :: Node_Id -> K a
k_init = K M.empty
k_alloc :: (Int,Int) -> KT Node_Id
k_alloc n = do
(K m i) <- get
put (K (M.insert n i m) (i + 1))
return i
k_get :: (Int,Int) -> KT Node_Id
k_get n = do
(K m _) <- get
return (m M.! n)
type Midi_Receiver m n = Midi_Message n -> Int -> m ()
midi_act :: Midi_Receiver IO Int -> Message -> StateT (K Int) IO ()
midi_act f o = do
let m = parse_m o
n <- case m of
Note_Off ch k _ -> k_get (ch,k)
Note_On ch k _ -> k_alloc (ch,k)
_ -> return (1)
liftIO (f m n)
start_midi :: (UDP -> Midi_Receiver IO Int) -> IO ()
start_midi receiver = do
s_fd <- openUDP "127.0.0.1" 57110
m_fd <- openUDP "127.0.0.1" 57150
sendMessage m_fd (Message "/receive" [Int 0xffff])
let step = liftIO (recvMessages m_fd) >>=
midi_act (receiver s_fd) . head
ex e = print ("start_midi",show (e::E.AsyncException)) >>
close m_fd >>
close s_fd
runs = void (runStateT (forever step) (k_init 1000))
E.catch runs ex
return ()