module Sound.SC3.Lang.Control.Midi where
import Control.Exception
import Data.Bits
import qualified Data.ByteString.Lazy as B
import qualified Data.Map as M
import Data.Maybe
import Sound.OSC.FD
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)
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
parse_b :: Integral n => Message -> [n]
parse_b m =
case m of
Message "/midi" [Int32 _,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 KY a = KY (M.Map a Node_Id) Node_Id
ky_init :: Node_Id -> KY a
ky_init = KY M.empty
ky_alloc :: Ord a => KY a -> a -> (KY a,Node_Id)
ky_alloc (KY m i) n = (KY (M.insert n i m) (i + 1),i)
ky_free :: Ord a => KY a -> a -> (KY a,Node_Id)
ky_free (KY m i) n =
let r = m M.! n
in (KY (M.delete n m) i,r)
ky_get :: Ord a => KY a -> a -> Node_Id
ky_get (KY m _) n = m M.! n
ky_all :: KY a -> [Node_Id]
ky_all (KY m _) = M.foldl (flip (:)) [] m
type Midi_Init_f st = (UDP -> IO st)
type Midi_Recv_f st = UDP -> st -> Midi_Message Int -> IO st
midi_act :: Midi_Recv_f st -> UDP -> st -> Message -> IO st
midi_act recv_f fd st o = do
let m = parse_m o
st' <- recv_f fd st m
return st'
run_midi :: Midi_Init_f st -> Midi_Recv_f st -> IO ()
run_midi init_f recv_f = do
m_fd <- openUDP "127.0.0.1" 57150
s_fd <- openUDP "127.0.0.1" 57110
sendMessage m_fd (Message "/receive" [Int32 0xffff])
init_st <- init_f s_fd
finally
(iterateM_ init_st (\st -> recvMessage m_fd >>=
midi_act recv_f s_fd st . fromJust))
(sendMessage m_fd (Message "/receive" [Int32 (1)]))
iterateM_ :: (Monad m) => st -> (st -> m st) -> m ()
iterateM_ st f = do
st' <- f st
iterateM_ st' f