{- |
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 Sound.OpenSoundControl.Transport.Monad
(Transport, send, )
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.State (StateT, evalStateT, lift, )
import System.Random (randomRs, mkStdGen, )
import qualified Data.Accessor.Container as AccCntn
import qualified Data.Accessor.MonadState as AccState
import qualified Data.Accessor.Basic as Accessor
import Data.Accessor.Basic ((.>))
import Data.List (lookup, 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 :: Transport t => Trans.IO t ()
initSeparate =
mapM
(\p -> Trans.send (SCPlay.d_recv' (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 :: Transport t => Trans.IO t ()
initEffect =
do mapM
(\p -> Trans.send (SCPlay.d_recv' (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' "Effect" $ out 0 effectUGen
Trans.send $ s_new "Effect" effectNodeId AddToTail SCPlay.homeId []
main :: IO ()
main = do
withSC3 reset
SCPlay.withSC3 initEffect
putStrLn "use 'pmidi -l' to find out the ports from where note messages can be received"
putStrLn "and connect the source with this program using 'aconnect'"
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))