{- |
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 ()