diff --git a/src/Sound/SC3/MIDI/Keyboard.hs b/src/Sound/SC3/MIDI/Keyboard.hs --- a/src/Sound/SC3/MIDI/Keyboard.hs +++ b/src/Sound/SC3/MIDI/Keyboard.hs @@ -1,20 +1,23 @@ {- | -Play incoming MIDI messages from ALSA as sounds via SuperCollider -with one instrument. +Play incoming MIDI messages from ALSA as sounds via SuperCollider. -} -- module Sound.SC3.MIDI.Keyboard where module Main where --- import Sound.OpenSoundControl -import Sound.SC3 as SC3 hiding (pitch) +import Sound.SC3.MIDI.Utility (withEvents, startMessage, ) -import qualified Sound.OpenSoundControl.Transport.Monad as Trans +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.ALSA.Sequencer as AlsaMidi +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, ) @@ -29,10 +32,14 @@ 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.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 (mapMaybe, fromMaybe, ) +import Data.Maybe (fromMaybe, ) frequency :: UGen @@ -45,7 +52,7 @@ soundPing = sinOsc AR (2*frequency) 0 * xLine KR 1 0.1 1 PauseSynth * - 0.25 * 4 ** control KR "Velocity" 0 + 0.15 * 4 ** control KR "Velocity" 0 programPing :: ProgramSound programPing = ProgramSound "Ping" soundPing 2 @@ -59,7 +66,7 @@ soundString :: UGen soundString = let n = 5 - volume = 0.25 * 4 ** control KR "Velocity" 0 / sqrt (fromIntegral n) + volume = 0.2 * 4 ** control KR "Velocity" 0 / sqrt (fromIntegral n) detunes = normalizeLevel 1 $ take (2*n) $ randomRs (0,0.03) $ mkStdGen 912 @@ -112,7 +119,7 @@ StateT MIDIState IO () playNote chan velocity pitch = do sid <- AccState.getAndModify stateSID succ - AccState.set (stateNoteSID .> AccCntn.mapMaybe (chan, pitch)) (Just sid) + 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) @@ -129,17 +136,32 @@ VoiceMsg.Pitch -> StateT MIDIState IO () stopNote chan pitch = - do sid <- AccState.get (stateNoteSID .> AccCntn.mapMaybe (chan, pitch)) + do sid <- + AccState.getAndModify + (stateChannelNotes .> AccCntn.mapMaybe chan .>> AccCntn.mapMaybe pitch) + (const Nothing) lift $ maybe - (putStrLn $ "released key " ++ show (chan,pitch) ++ " which was not pressed") + (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, - stateNoteSID_ :: Map (ChannelMsg.Channel, VoiceMsg.Pitch) SCPlay.NodeId, + stateChannelNotes_ :: Map ChannelMsg.Channel (Map VoiceMsg.Pitch SCPlay.NodeId), stateChannelProgram_ :: Array ChannelMsg.Channel VoiceMsg.Program, stateChannelParameter_ :: Array ChannelMsg.Channel (Map String Double) } @@ -151,12 +173,49 @@ (\x r -> r{stateSID_ = x}) stateSID_ -stateNoteSID :: Accessor.T MIDIState (Map (ChannelMsg.Channel, VoiceMsg.Pitch) SCPlay.NodeId) -stateNoteSID = + +{- | +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 - (\x r -> r{stateNoteSID_ = x}) - stateNoteSID_ + (\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 = @@ -198,11 +257,12 @@ toneInitId = channelInitId + numberMIDIChannels numberMIDIChannels :: Int -numberMIDIChannels = 16 +numberMIDIChannels = + ChannelMsg.fromChannel maxBound - + ChannelMsg.fromChannel minBound + 1 boundMIDIChannels :: (ChannelMsg.Channel, ChannelMsg.Channel) -boundMIDIChannels = - (ChannelMsg.toChannel 0, ChannelMsg.toChannel (pred numberMIDIChannels)) +boundMIDIChannels = (minBound, maxBound) @@ -270,42 +330,54 @@ 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'" + putStr startMessage - AlsaMidi.withEvents "supercollider-midi" "supercollider-midi-listen" $ \ ll -> + withEvents "Haskell-SuperCollider" "in-0" $ \ evs -> 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)) + (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 () diff --git a/src/Sound/SC3/MIDI/Utility.hs b/src/Sound/SC3/MIDI/Utility.hs new file mode 100644 --- /dev/null +++ b/src/Sound/SC3/MIDI/Utility.hs @@ -0,0 +1,38 @@ +module Sound.SC3.MIDI.Utility where + +import qualified Sound.ALSA.Sequencer.Client as Client +import qualified Sound.ALSA.Sequencer.Port as Port +import qualified Sound.ALSA.Sequencer.Event as Event +import qualified Sound.ALSA.Sequencer as SndSeq + +import Control.Monad (liftM2, ) + +import System.IO.Unsafe (unsafeInterleaveIO, ) + + +withInPort :: + String -> String -> SndSeq.BlockMode -> + (SndSeq.T SndSeq.InputMode -> Port.T -> IO a) -> IO a +withInPort sequName portName blockMode act = + SndSeq.with SndSeq.defaultName blockMode $ \h -> + Client.setName h sequName >> + Port.withSimple h portName + (Port.caps [Port.capWrite, Port.capSubsWrite]) + Port.typeMidiGeneric + (act h) + +ioToLazyList :: IO a -> IO [a] +ioToLazyList m = + let go = unsafeInterleaveIO $ liftM2 (:) m go + in go + +withEvents :: String -> String -> ([Event.T] -> IO a) -> IO a +withEvents sequName portName act = + withInPort sequName portName SndSeq.Block $ \sequ _p -> + ioToLazyList (Event.input sequ) >>= act + + +startMessage :: String +startMessage = + "use 'aconnect -i' to find out the ports from where note messages can be received\n" ++ + "and connect the source with this program using 'aconnect' or 'patchage' or 'alsa-patch-bay'\n" diff --git a/src/Sound/SC3/MIDI/Wind.hs b/src/Sound/SC3/MIDI/Wind.hs --- a/src/Sound/SC3/MIDI/Wind.hs +++ b/src/Sound/SC3/MIDI/Wind.hs @@ -1,24 +1,30 @@ module Main where --- module SuperColliderMIDI where +-- module Sound.SC3.MIDI.Wind where -import Sound.OpenSoundControl +import Sound.SC3.MIDI.Utility (withEvents, startMessage, ) + import Sound.SC3 as SC3 import Sound.SC3.UGen.Noise.ID as Noise -import qualified Sound.ALSA.Sequencer as AlsaMidi -import qualified Sound.MIDI.Message.Channel as ChannelMsg +import qualified Sound.MIDI.ALSA as MALSA import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg -import Data.Maybe (mapMaybe, fromMaybe, ) +import qualified Sound.ALSA.Sequencer.Event as Event +import Data.Accessor.Basic ((^.), ) +import Data.Maybe (fromMaybe, ) + + sound :: UGen -sound = out 0 - (delayN (0.2 * rlpf - (Noise.whiteNoise (0::Int) AR * control KR "Volume" 1) - (control KR "Frequency" 400) - (control KR "Resonance" 0.005)) - 0 (MCE [0, control KR "Phase" 0])) +sound = + let noise = + delayN (0.1 * rlpf + (Noise.whiteNoise (0::Int) AR * control KR "Volume" 1) + (control KR "Frequency" 400) + (control KR "Resonance" 0.005)) + 0 (MCE [0, control KR "Phase" 0]) + in out 0 (noise + 0.5 * combN noise 0.5 0.5 2) controlChange :: String -> (Double -> Double) -> Int -> IO () controlChange ctrlName f value = @@ -34,24 +40,25 @@ audition sound putStrLn "turn the wheels ..." - AlsaMidi.withEvents "midinoise" "midinoise-listen" $ \ ll -> - putStrLn "use 'pmidi -l' to find out the ports from where controller values can be received" >> - putStrLn "and connect the source with this program using 'aconnect'" >> - mapM_ (\mev -> case mev of - ChannelMsg.Cons _chan (ChannelMsg.Voice ev) -> - case ev of - VoiceMsg.Control ctrl value -> + withEvents "Haskell-Wind" "in-0" $ \ evs -> do + putStr startMessage + flip mapM_ (map Event.body evs) $ \ev -> case ev of + Event.CtrlEv Event.Controller param -> + case param ^. MALSA.ctrlControllerMode of + MALSA.Controller ctrl value -> fromMaybe (return ()) $ lookup ctrl $ - (VoiceMsg.mainVolumeMSB, + (VoiceMsg.mainVolume, controlChange "Volume" id value) : - (VoiceMsg.footControlMSB, + (VoiceMsg.footControl, controlChange "Frequency" (\x -> 200 * 4 ** x) value) : - (VoiceMsg.breathControlMSB, + (VoiceMsg.breathControl, controlChange "Resonance" (\x -> 1 / 1000 ** x) value) : - (VoiceMsg.modulationMSB, + (VoiceMsg.modulation, controlChange "Phase" (0.002*) value) : [] _ -> return () - _ -> return ()) - (mapMaybe AlsaMidi.eventToChannelMsg ll) + Event.CtrlEv Event.PitchBend param -> + controlChange "Frequency" + (\x -> 400 * 2 ** (x / 64)) (param ^. MALSA.ctrlValue) + _ -> return () diff --git a/supercollider-midi.cabal b/supercollider-midi.cabal --- a/supercollider-midi.cabal +++ b/supercollider-midi.cabal @@ -1,5 +1,5 @@ Name: supercollider-midi -Version: 0.1.3 +Version: 0.2 License: GPL License-File: LICENSE Author: Henning Thielemann @@ -26,47 +26,54 @@ description: Choose the new smaller, split-up base package. Executable sc-keyboard - If flag(splitBase) - Build-Depends: - array >=0.1 && <0.4, - containers >=0.1 && <0.5, - random >=1.0 && <2.0, - base >=2 && <5 - Else - Build-Depends: - base >=1.0 && <2 - Build-Depends: supercollider-ht >=0.1 && <0.2, opensoundcontrol-ht >=0.1 && <0.2, hsc3 >=0.8 && <0.9, hosc >=0.8 && <0.9, - alsa-midi >=0.4 && <0.5, - midi >=0.1.3 && <0.2, + alsa-seq >=0.5 && <0.6, + data-accessor >=0.2.1 && <0.3, + midi-alsa >=0.1.1 && <0.2, + midi >=0.1.4 && <0.2, event-list >=0.0.6 && <0.2, non-negative >=0.0.1 && <0.2, data-accessor-transformers >=0.2 && <0.3, data-accessor >=0.2 && <0.3, - transformers >=0.2 && <0.3 + transformers >=0.2 && <0.3, + utility-ht >=0.0.5 && <0.1 + If flag(splitBase) + Build-Depends: + array >=0.1 && <0.4, + containers >=0.1 && <0.5, + random >=1.0 && <2.0, + base >=2 && <5 + Else + Build-Depends: + base >=1.0 && <2 + Hs-source-dirs: src GHC-Options: -Wall -threaded Main-Is: Sound/SC3/MIDI/Keyboard.hs + Other-Modules: Sound.SC3.MIDI.Utility Executable sc-wind - If flag(splitBase) - Build-Depends: base >=2 - Else - Build-Depends: base >=1.0 && <2 - Build-Depends: hsc3 >=0.8 && <0.9, hosc >=0.8 && <0.9, - alsa-midi >=0.4 && <0.5, - midi >=0.1.3 && <0.2, + alsa-seq >=0.5 && <0.6, + data-accessor >=0.2.1 && <0.3, + midi-alsa >=0.1.1 && <0.2, + midi >=0.1.4 && <0.2, event-list >=0.0.6 && <0.2, non-negative >=0.0.1 && <0.2 + If flag(splitBase) + Build-Depends: base >=2 + Else + Build-Depends: base >=1.0 && <2 + Hs-source-dirs: src GHC-Options: -Wall -threaded Main-Is: Sound/SC3/MIDI/Wind.hs + Other-Modules: Sound.SC3.MIDI.Utility