{- | Play incoming MIDI messages from ALSA as sounds via SuperCollider with one instrument. -} -- module Sound.SC3.MIDI.Keyboard where module Main where -- import Sound.OpenSoundControl import Sound.SC3 as SC3 hiding (pitch) import qualified Sound.OpenSoundControl.Transport.Monad as Trans import qualified Sound.SC3.Server.PlayEasy as SCPlay import qualified Sound.ALSA.Sequencer as AlsaMidi import qualified Sound.MIDI.Message.Channel as ChannelMsg import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg import Data.Array (Array, array, listArray, (!), ) import Data.Map (Map, ) import qualified Data.Array as Array import qualified Data.Map as Map import Control.Monad.Trans.State (StateT, evalStateT, ) import Control.Monad.Trans.Class (lift, ) import System.Random (randomRs, mkStdGen, ) import qualified Data.Accessor.Monad.Trans.State as AccState import qualified Data.Accessor.Container as AccCntn import qualified Data.Accessor.Basic as Accessor import Data.Accessor.Basic ((.>)) import Data.List (genericLength, ) import Data.Maybe (mapMaybe, fromMaybe, ) frequency :: UGen frequency = 440 * 2 ** ((control KR "Pitch" 0 + control KR "PitchBend" 0 * 2 + 3 - 72) / 12) * (1 + (control KR "Modulation" 0 + control KR "Aftertouch" 0) * sinOsc KR 10 0) soundPing :: UGen soundPing = sinOsc AR (2*frequency) 0 * xLine KR 1 0.1 1 PauseSynth * 0.25 * 4 ** control KR "Velocity" 0 programPing :: ProgramSound programPing = ProgramSound "Ping" soundPing 2 -- | normalize a list of numbers, such that they have a specific average normalizeLevel :: Fractional a => a -> [a] -> [a] normalizeLevel newAvrg xs = let avrg = sum xs / genericLength xs in map ((newAvrg-avrg)+) xs soundString :: UGen soundString = let n = 5 volume = 0.25 * 4 ** control KR "Velocity" 0 / sqrt (fromIntegral n) detunes = normalizeLevel 1 $ take (2*n) $ randomRs (0,0.03) $ mkStdGen 912 phases = randomRs (0,2) $ mkStdGen 54 tones = zipWith (\detune phase -> lfSaw AR (frequency*detune) phase) detunes phases (tonesLeft,tonesRight) = splitAt n tones in volume * MCE [sum tonesLeft, sum tonesRight] programString :: ProgramSound programString = ProgramSound "String" soundString 4 data ProgramSound = ProgramSound { programName :: String, programUGen :: UGen, programBuffer :: Int } programSounds :: Array VoiceMsg.Program ProgramSound programSounds = let ps = zip [VoiceMsg.toProgram 0 .. ] $ programPing : programString : [] in array (fst $ head ps, fst $ last ps) ps controlChange :: ChannelMsg.Channel -> String -> (Double -> Double) -> Int -> StateT MIDIState IO () controlChange chan ctrlName f value = let cValue = f (fromIntegral value / 127) in do lift (print (ctrlName, cValue)) AccState.set (stateChannelParameter .> AccCntn.array chan .> AccCntn.mapDefault 0 ctrlName) cValue lift (SCPlay.withSC3 (Trans.send (n_set (channelNodeId chan) [(ctrlName, cValue)]))) playNote :: ChannelMsg.Channel -> VoiceMsg.Velocity -> VoiceMsg.Pitch -> StateT MIDIState IO () playNote chan velocity pitch = do sid <- AccState.getAndModify stateSID succ AccState.set (stateNoteSID .> AccCntn.mapMaybe (chan, pitch)) (Just sid) lift $ print (pitch, velocity) program <- AccState.get (stateChannelProgram .> AccCntn.array chan) params <- AccState.get (stateChannelParameter .> AccCntn.array chan) lift $ SCPlay.withSC3 $ Trans.send $ s_new (programName $ programSounds ! program) sid AddToTail (channelNodeId chan) $ ("Pitch", fromIntegral (VoiceMsg.fromPitch pitch)) : ("Velocity", fromIntegral (VoiceMsg.fromVelocity velocity - 64) / 64) : Map.toList params stopNote :: ChannelMsg.Channel -> VoiceMsg.Pitch -> StateT MIDIState IO () stopNote chan pitch = do sid <- AccState.get (stateNoteSID .> AccCntn.mapMaybe (chan, pitch)) lift $ maybe (putStrLn $ "released key " ++ show (chan,pitch) ++ " which was not pressed") (\s -> SCPlay.withSC3 $ Trans.send $ n_free [s]) sid data MIDIState = MIDIState { stateSID_ :: SCPlay.NodeId, stateNoteSID_ :: Map (ChannelMsg.Channel, VoiceMsg.Pitch) SCPlay.NodeId, stateChannelProgram_ :: Array ChannelMsg.Channel VoiceMsg.Program, stateChannelParameter_ :: Array ChannelMsg.Channel (Map String Double) } stateSID :: Accessor.T MIDIState SCPlay.NodeId stateSID = Accessor.fromSetGet (\x r -> r{stateSID_ = x}) stateSID_ stateNoteSID :: Accessor.T MIDIState (Map (ChannelMsg.Channel, VoiceMsg.Pitch) SCPlay.NodeId) stateNoteSID = Accessor.fromSetGet (\x r -> r{stateNoteSID_ = x}) stateNoteSID_ stateChannelProgram :: Accessor.T MIDIState (Array ChannelMsg.Channel VoiceMsg.Program) stateChannelProgram = Accessor.fromSetGet (\x r -> r{stateChannelProgram_ = x}) stateChannelProgram_ stateChannelParameter :: Accessor.T MIDIState (Array ChannelMsg.Channel (Map String Double)) stateChannelParameter = Accessor.fromSetGet (\x r -> r{stateChannelParameter_ = x}) stateChannelParameter_ {- Our SuperCollider node structure is: One group for every MIDI channel, starting at (succ SCPlay.homeId). UGens for the instruments are added to the groups of their MIDI channel. This way we can alter controller values on a per channel basis. The node ids are counted successively starting right after the highest group id. -} -- | node id for global effects effectNodeId :: SCPlay.NodeId effectNodeId = succ SCPlay.homeId -- | initial node id for channel groups channelInitId :: SCPlay.NodeId channelInitId = succ effectNodeId channelNodeId :: ChannelMsg.Channel -> SCPlay.NodeId channelNodeId chan = channelInitId + ChannelMsg.fromChannel chan -- | initial node id for tones toneInitId :: SCPlay.NodeId toneInitId = channelInitId + numberMIDIChannels numberMIDIChannels :: Int numberMIDIChannels = 16 boundMIDIChannels :: (ChannelMsg.Channel, ChannelMsg.Channel) boundMIDIChannels = (ChannelMsg.toChannel 0, ChannelMsg.toChannel (pred numberMIDIChannels)) {- | Initialize SuperCollider in a way that all sounds are written to output buffer 0 and are simply mixed. -} initSeparate :: Trans.C m => m () initSeparate = mapM_ (\p -> Trans.send (SCPlay.d_recv_synthdef (programName p) (out 0 (programUGen p)))) (Array.elems programSounds) >> (Trans.send $ g_new $ map (\chan -> (channelNodeId chan, AddToTail, SCPlay.homeId)) (uncurry enumFromTo boundMIDIChannels)) programBufferIn :: ProgramSound -> UGen programBufferIn p = in' 2 AR (Constant $ fromIntegral $ programBuffer p) effectUGen :: UGen effectUGen = let lfoSine = 1000 * exp (0.3 * sinOsc KR 0.1 (MCE [-pi/2, 0]) + 0.3 * sinOsc KR (sqrt 0.03) 0) reverb x = x + 0.5 * combN x 0.2 0.2 5 in -- sinOsc AR 440 0 + programBufferIn programPing + 0.2 * reverb (rlpf (programBufferIn programString) lfoSine 0.1) {- | Initialize SuperCollider in a way that all sounds are written to output buffers according to their MIDI program. You must provide a UGen which puts these buffers together. This can be simple mixing, but you can also apply effects to the partial sounds. -} initEffect :: Trans.C m => m () initEffect = do mapM_ (\p -> Trans.send (SCPlay.d_recv_synthdef (programName p) (out (Constant $ fromIntegral $ programBuffer p) (programUGen p)))) (Array.elems programSounds) Trans.send $ g_new $ map (\chan -> (channelNodeId chan, AddToTail, SCPlay.homeId)) (uncurry enumFromTo boundMIDIChannels) mapM_ (const (Trans.wait "/done" >> return ())) (Array.elems programSounds) SCPlay.simpleSync $ SCPlay.d_recv_synthdef "Effect" $ out 0 effectUGen Trans.send $ s_new "Effect" effectNodeId AddToTail SCPlay.homeId [] main :: IO () main = do SCPlay.withSC3 $ SCPlay.reset >> initEffect putStrLn "use 'aconnect -i' to find out the ports from where note messages can be received" putStrLn "and connect the source with this program using 'aconnect' or 'patchage' or 'alsa-patch-bay'" AlsaMidi.withEvents "supercollider-midi" "supercollider-midi-listen" $ \ ll -> flip evalStateT (MIDIState toneInitId Map.empty (listArray boundMIDIChannels (repeat (VoiceMsg.toProgram 0))) (listArray boundMIDIChannels (repeat Map.empty))) (mapM_ (\mev -> case mev of ChannelMsg.Cons chan (ChannelMsg.Voice ev) -> case ev of VoiceMsg.Control ctrl value -> fromMaybe (return ()) $ lookup ctrl $ (VoiceMsg.mainVolumeMSB, controlChange chan "Volume" id value) : (VoiceMsg.modulationMSB, controlChange chan "Modulation" (*0.03) value) : [] VoiceMsg.PitchBend value -> controlChange chan "PitchBend" (/64) value VoiceMsg.MonoAftertouch value -> controlChange chan "Aftertouch" (*0.03) value VoiceMsg.NoteOn pitch velocity -> {- NoteOn with velocity 0 is now handled by alsa-midi package when (VoiceMsg.fromVelocity velocity > 0) $ -} playNote chan velocity pitch VoiceMsg.NoteOff pitch _velocity -> stopNote chan pitch VoiceMsg.ProgramChange program -> lift (print ev) >> if Array.inRange (Array.bounds programSounds) program then AccState.set (stateChannelProgram .> AccCntn.array chan) program else lift $ putStrLn "program unavailable" _ -> return () _ -> return ()) (mapMaybe AlsaMidi.eventToChannelMsg ll))