{- | Play incoming MIDI messages from ALSA as sounds via SuperCollider. -} -- module Sound.SC3.MIDI.Keyboard where module Main where import Sound.SC3.MIDI.Utility (withEvents, startMessage, ) import Sound.SC3 as SC3 hiding (pitch, ) import qualified Sound.SC3.Server.PlayEasy as SCPlay import qualified Sound.OpenSoundControl.Transport.Monad as Trans import qualified Sound.MIDI.ALSA as MALSA import qualified Sound.MIDI.Message.Channel as ChannelMsg import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg import qualified Sound.MIDI.Message.Channel.Mode as ModeMsg import qualified Sound.ALSA.Sequencer.Event as Event 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 Control.Monad.HT ((<=<), ) import Control.Monad (MonadPlus, mplus, liftM, ) -- import Control.Applicative ((<$), ) import Data.Monoid (Monoid, mempty, ) import Data.List (genericLength, ) import Data.Maybe (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.15 * 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.2 * 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 (stateChannelNotes .> AccCntn.mapMaybe chan .>> AccCntn.mapMaybe 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.getAndModify (stateChannelNotes .> AccCntn.mapMaybe chan .>> AccCntn.mapMaybe pitch) (const Nothing) lift $ maybe (putStrLn $ "released key " ++ show (chan,pitch) ++ " that was not pressed") (\s -> SCPlay.withSC3 $ Trans.send $ n_free [s]) sid stopAllNotes :: ChannelMsg.Channel -> StateT MIDIState IO () stopAllNotes chan = do notes <- AccState.getAndModify (stateChannelNotes .> AccCntn.mapMaybe chan) (const Nothing) lift $ SCPlay.withSC3 $ mapM_ (\s -> Trans.send $ n_free [s]) (maybe [] Map.elems notes) data MIDIState = MIDIState { stateSID_ :: SCPlay.NodeId, stateChannelNotes_ :: Map ChannelMsg.Channel (Map 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_ {- | This combines two accessors in the case that a null value of type @m b@ can represented both by @mzero@ and @pure mempty@. Reasonable choices for @m@ are 'Maybe' and 'Either'. The type @b@ might be a 'Map'. Maybe move that function to data-accessor. Monoid is only needed for 'mempty'. Maybe it is not a good choice. -} (.>>) :: (Monoid b, MonadPlus m) => Accessor.T a (m b) -> Accessor.T b (m c) -> Accessor.T a (m c) (.>>) ab bc = Accessor.fromSetGet (\mc -> ab ^: (\mb -> liftM (bc ^= mc) $ mplus mb (liftM (const mempty) mc))) -- (mempty <$ mc) (Accessor.get bc <=< Accessor.get ab) composeMapAccessor :: Accessor.T a (Maybe (Map b c)) -> Accessor.T (Map b c) (Maybe c) -> Accessor.T a (Maybe c) composeMapAccessor ab bc = Accessor.fromSetGet (\mc -> ab ^: (\mb -> case (mb,mc) of (Nothing, Nothing) -> Nothing _ -> Just $ (bc ^= mc) (fromMaybe Map.empty mb))) (\a -> (a ^. ab) >>= \b -> b ^. bc) stateChannelNotes :: Accessor.T MIDIState (Map ChannelMsg.Channel (Map VoiceMsg.Pitch SCPlay.NodeId)) stateChannelNotes = Accessor.fromSetGet (\x r -> r{stateChannelNotes_ = x}) stateChannelNotes_ 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 = ChannelMsg.fromChannel maxBound - ChannelMsg.fromChannel minBound + 1 boundMIDIChannels :: (ChannelMsg.Channel, ChannelMsg.Channel) boundMIDIChannels = (minBound, maxBound) {- | 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 putStr startMessage withEvents "Haskell-SuperCollider" "in-0" $ \ evs -> flip evalStateT (MIDIState toneInitId Map.empty (listArray boundMIDIChannels (repeat (VoiceMsg.toProgram 0))) (listArray boundMIDIChannels (repeat Map.empty))) $ flip mapM_ (map Event.body evs) $ \ev -> case ev of Event.CtrlEv ctrlPart param -> let chan = param ^. MALSA.ctrlChannel ctrlMode = param ^. MALSA.ctrlControllerMode valueX = param ^. MALSA.ctrlValue program = param ^. MALSA.ctrlProgram in case ctrlPart of Event.Controller -> case ctrlMode of MALSA.Controller ctrl value -> fromMaybe (return ()) $ lookup ctrl $ (VoiceMsg.mainVolume, controlChange chan "Volume" id value) : (VoiceMsg.modulation, controlChange chan "Modulation" (*0.03) value) : [] MALSA.Mode ModeMsg.AllNotesOff -> stopAllNotes chan MALSA.Mode ModeMsg.AllSoundOff -> stopAllNotes chan {- this would clear all channels SCPlay.withSC3 (SCPlay.reset >> initEffect) -} _ -> return () Event.PitchBend -> controlChange chan "PitchBend" (/64) valueX Event.ChanPress -> controlChange chan "Aftertouch" (*0.03) valueX Event.PgmChange -> lift (print ev) >> if Array.inRange (Array.bounds programSounds) program then AccState.set (stateChannelProgram .> AccCntn.array chan) program else lift $ putStrLn "program unavailable" _ -> return () Event.NoteEv notePart note -> let chan = note ^. MALSA.noteChannel pitch = note ^. MALSA.notePitch in case MALSA.normalNoteFromEvent notePart note of (Event.NoteOn, velocity) -> playNote chan velocity pitch (Event.NoteOff, _velocity) -> stopNote chan pitch _ -> return () _ -> return ()