{- | Convert MIDI events of a MIDI controller to a control signal. -} module Synthesizer.Storable.ALSA.MIDI where import qualified Sound.Alsa as ALSASig import qualified Sound.Alsa.Sequencer as ALSA import qualified Sound.Sox.Play as Play import qualified Sound.Sox.Option.Format as SoxOpt import qualified Synthesizer.Basic.Binary as BinSmp -- import Data.Int (Int16) import qualified Synthesizer.Storable.Cut as CutSt import qualified Synthesizer.Storable.Signal as SigSt import qualified Data.StorableVector.Lazy.Pattern as SigStV import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector.Base as SV import qualified Data.EventList.Relative.TimeBody as EventList import qualified Data.EventList.Relative.TimeTime as EventListTT import qualified Data.EventList.Relative.MixedBody as EventListMB -- import qualified Data.EventList.Relative.BodyMixed as EventListBM import qualified Data.EventList.Relative.TimeMixed as EventListTM import qualified Data.EventList.Relative.MixedTime as EventListMT import qualified Data.EventList.Relative.BodyTime as EventListBT import qualified Data.EventList.Absolute.TimeBody as AbsEventList import qualified Foreign import Foreign.Storable (Storable) import System.IO.Unsafe (unsafeInterleaveIO, ) import Control.Concurrent (threadDelay) import System.Time (ClockTime(TOD), getClockTime, ) import Control.Exception (bracket, ) import Control.Monad.Trans.State (State, state, ) -- import qualified Numeric.NonNegative.Class as NonNeg import qualified Numeric.NonNegative.Wrapper as NonNegW import qualified Numeric.NonNegative.ChunkyPrivate as NonNegChunky import qualified Algebra.RealField as RealField import Data.Tuple.HT (mapPair, mapSnd, ) import Data.Maybe.HT (toMaybe, ) -- import Data.Maybe (mapMaybe, ) import Control.Monad (liftM, liftM2, guard, ) import NumericPrelude (round, ) import Prelude hiding (round, break, ) {- readMIDIController :: Storable a => Int -> Int -> Int -> IO (SigSt.T a) readMIDIController chunkSize sampleRate ctrl = withInPort ALSA.Block $ \ h _p -> do let loop = do putStrLn "waiting for an event:" e <- ALSA.event_input h print e loop loop return SigSt.empty -} getTimeSeconds :: Fractional time => IO time getTimeSeconds = fmap clockTimeToSeconds getClockTime clockTimeToSeconds :: Fractional time => ClockTime -> time clockTimeToSeconds (TOD secs picos) = fromInteger secs + fromInteger picos * 1e-12 type ALSAEvent = (Double, ALSA.Event) {- | only use it for non-blocking sequencers -} getStampedEvent :: ALSA.SndSeq -> IO ALSAEvent getStampedEvent h = liftM2 (,) getTimeSeconds (ALSA.event_input h) {- | only use it for non-blocking sequencers -} getWaitingEvents :: ALSA.SndSeq -> IO [ALSAEvent] getWaitingEvents h = let loop = ALSA.alsa_catch (liftM2 (:) (getStampedEvent h) loop) (const $ return []) in loop type StrictTime = NonNegW.Integer {- ghc -i:src -e 'withMIDIEventsNonblock 44100 print' src/Synthesizer/Storable/ALSA/MIDI.hs -} -- as a quick hack, we neglect the ALSA time stamp and use getTime or so withMIDIEventsNonblock :: Double -> (EventList.T StrictTime (Maybe ALSA.Event) -> IO a) -> IO a withMIDIEventsNonblock rate proc = withInPort ALSA.Nonblock $ \ h _p -> do l <- ioToLazyList $ threadDelay 10000 >> liftM2 (:) (liftM (\t->(t,Nothing)) getTimeSeconds) (liftM (map (mapSnd Just)) (getWaitingEvents h)) proc $ discretizeTime rate $ AbsEventList.fromPairList $ concat l withMIDIEventsNonblockSimple :: Double -> (EventList.T StrictTime ALSA.Event -> IO a) -> IO a withMIDIEventsNonblockSimple rate proc = withInPort ALSA.Nonblock $ \ h _p -> do l <- ioToLazyList $ threadDelay 10000 >> getWaitingEvents h proc $ discretizeTime rate $ AbsEventList.fromPairList $ concat l withMIDIEventsBlock :: Double -> (EventList.T StrictTime ALSA.Event -> IO a) -> IO a withMIDIEventsBlock rate proc = withInPort ALSA.Block $ \ h _p -> do l <- ioToLazyList $ getStampedEvent h proc $ discretizeTime rate $ AbsEventList.fromPairList l withInPort :: ALSA.BlockMode -> (ALSA.SndSeq -> ALSA.Port -> IO t) -> IO t withInPort blockMode act = bracket (ALSA.open ALSA.default_seq_name ALSA.open_input blockMode) (ALSA.close) $ \h -> ALSA.set_client_name h "Haskell-Synthesizer" >> (bracket (ALSA.create_simple_port h "listener" (ALSA.caps [ALSA.cap_write, ALSA.cap_subs_write]) ALSA.type_midi_generic) (ALSA.delete_port h) $ \p -> act h p) {- | We first discretize the absolute time values, then we compute differences, in order to avoid rounding errors in further computations. -} discretizeTime :: Double -> AbsEventList.T Double a -> EventList.T StrictTime a discretizeTime sampleRate = EventListMB.mapTimeHead (const 0) . -- clear first time since it is an absolute system time stamp EventList.fromAbsoluteEventList . AbsEventList.mapTime (NonNegW.fromNumberMsg "time conversion" . round . (sampleRate*)) type LazyTime = NonNegChunky.T NonNegW.Integer {- | We turn the strict time values into lazy ones according to the breaks by our beat. However for the laziness breaks we ignore the events that are filtered out. That is we loose laziness granularity but hopefully gain efficiency by larger blocks. -} getSlice :: (ALSA.Event -> Maybe a) -> State (EventList.T StrictTime (Maybe ALSA.Event)) (EventListTT.T LazyTime a) getSlice f = fmap (EventListTT.catMaybesR . flip EventListTM.snocTime 0 . EventList.mapTime NonNegChunky.fromNumber) $ state (partitionMaybeBeat f) -- state (partitionMaybe (maybe (Just Nothing) (fmap Just . f))) {- | Move all elements that are mapped to @Just@ into another list. -} partitionMaybe :: (a -> Maybe b) -> EventList.T StrictTime a -> (EventList.T StrictTime b, EventList.T StrictTime a) partitionMaybe f = mapPair (EventList.catMaybes, EventList.catMaybes) . EventList.foldrPair (\t a -> let (x,y) = case f a of Just b -> (Just b, Nothing) Nothing -> (Nothing, Just a) in mapPair (EventList.cons t x, EventList.cons t y)) (EventList.empty, EventList.empty) {- | Move all elements that are mapped to @Just@ into another list. @Nothing@ elements in the source list are maintained in both result lists as laziness breaks. -} partitionMaybeBeat :: (a -> Maybe b) -> EventList.T StrictTime (Maybe a) -> (EventList.T StrictTime (Maybe b), EventList.T StrictTime (Maybe a)) partitionMaybeBeat f = mapPair (EventList.catMaybes, EventList.catMaybes) . EventList.foldrPair (\t a0 -> let (x,y) = case a0 of Nothing -> (Just Nothing, Just Nothing) Just a1 -> case f a1 of Just b -> (Just $ Just b, Nothing) Nothing -> (Nothing, Just $ Just a1) in mapPair (EventList.cons t x, EventList.cons t y)) (EventList.empty, EventList.empty) maybeController :: Int -> Int -> ALSA.Event -> Maybe (Int, Int) maybeController chan ctrl e = let ALSA.TickTime n = ALSA.ev_timestamp e in case ALSA.ev_data e of ALSA.CtrlEv ALSA.Controller c -> toMaybe (fromIntegral (ALSA.ctrl_channel c) == chan && fromIntegral (ALSA.ctrl_param c) == ctrl) (fromIntegral n, fromIntegral $ ALSA.ctrl_value c) _ -> Nothing getControllerEvents :: Int -> Int -> State (EventList.T StrictTime (Maybe ALSA.Event)) (EventListTT.T LazyTime Int) getControllerEvents chan ctrl = getSlice (fmap snd . maybeController chan ctrl) controllerValuesToSignal :: Double -> EventListTT.T LazyTime Double -> SigSt.T Double controllerValuesToSignal initial = EventListBT.foldrPair (\y t -> SigSt.append (SigStV.replicate (chunkSizesFromLazyTime t) y)) SigSt.empty . EventListMT.consBody initial chunkSizesFromLazyTime :: LazyTime -> NonNegChunky.T SigSt.ChunkSize chunkSizesFromLazyTime = NonNegChunky.fromChunks . map (SVL.ChunkSize . fromInteger . NonNegW.toNumber) . NonNegChunky.toChunks . NonNegChunky.normalize controllerValueToSample :: (Double,Double) -> Int -> Double controllerValueToSample (lower,upper) n = let k = fromIntegral n / 127 in (1-k) * lower + k * upper getControllerSignal :: Int -> Int -> (Double,Double) -> Double -> State (EventList.T StrictTime (Maybe ALSA.Event)) (SigSt.T Double) getControllerSignal chan ctrl bnd initial = liftM (controllerValuesToSignal initial . EventListTT.mapBody (controllerValueToSample bnd)) $ getControllerEvents chan ctrl controllerValueToSampleExp :: (Double,Double) -> Int -> Double controllerValueToSampleExp (lower,upper) n = let k = fromIntegral n / 127 in lower**(1-k) * upper**k getControllerSignalExp :: Int -> Int -> (Double,Double) -> Double -> State (EventList.T StrictTime (Maybe ALSA.Event)) (SigSt.T Double) getControllerSignalExp chan ctrl bnd initial = liftM (controllerValuesToSignal initial . EventListTT.mapBody (controllerValueToSampleExp bnd)) $ getControllerEvents chan ctrl maybePitchBend :: Int -> ALSA.Event -> Maybe Int maybePitchBend chan e = case ALSA.ev_data e of ALSA.CtrlEv ALSA.PitchBend c -> toMaybe (fromIntegral (ALSA.ctrl_channel c) == chan) (fromIntegral $ ALSA.ctrl_value c) _ -> Nothing pitchBendValueToSample :: Double -> Double -> Int -> Double pitchBendValueToSample range center n = center * range ** (fromIntegral n / 8192) {- | @getPitchBendSignal channel range center@: emits frequencies on an exponential scale from @center/range@ to @center*range@. -} getPitchBendSignal :: Int -> Double -> Double -> State (EventList.T StrictTime (Maybe ALSA.Event)) (SigSt.T Double) getPitchBendSignal chan range center = liftM (controllerValuesToSignal center . EventListTT.mapBody (pitchBendValueToSample range center)) $ getSlice (maybePitchBend chan) -- getPitchBendEvents chan {- We could also provide a function which filters for specific programs/presets. -} getNoteEvents :: Int -> State (EventList.T StrictTime (Maybe ALSA.Event)) (EventListTT.T LazyTime (Int,Int,Bool)) getNoteEvents chan = getSlice $ \e -> case ALSA.ev_data e of ALSA.NoteEv notePart note -> do guard (fromIntegral (ALSA.note_channel note) == chan) (vel,press) <- case notePart of ALSA.NoteOn -> return $ let v = ALSA.note_velocity note in if v==0 then (64, False) else (fromIntegral v, True) ALSA.NoteOff -> return (fromIntegral $ ALSA.note_velocity note, False) _ -> Nothing return (fromIntegral $ ALSA.note_note note, vel, press) _ -> Nothing matchNoteEventsAlt :: EventListTT.T LazyTime (Int,Int,Bool) -> EventListTT.T LazyTime (Int,Int,LazyTime) matchNoteEventsAlt = EventListTT.catMaybesR . matchNoteEventsMaybe . EventListTT.mapBody Just matchNoteEventsMaybe :: EventListTT.T LazyTime (Maybe (Int,Int,Bool)) -> EventListTT.T LazyTime (Maybe (Int,Int,LazyTime)) matchNoteEventsMaybe = EventListMT.mapTimeTail $ \r0 -> flip (EventListMT.switchBodyL EventListBT.empty) r0 $ \ev r1 -> case ev of Nothing -> EventListMT.consBody Nothing $ matchNoteEventsMaybe r1 Just (pitchOn,velOn,pressOn) -> let (dur,r2) = if not pressOn then (0, r1) -- isolated NoteOff event else let (prefix,_noteOff,suffix) = break (maybe False (\(pitchOff,_velOff,pressOff) -> pitchOn == pitchOff && not pressOff)) r1 in (lazyDuration prefix, EventListTM.prependBodyEnd (EventListTM.snocBody prefix Nothing) suffix) in EventListMT.consBody (Just (pitchOn,velOn,dur)) $ matchNoteEventsMaybe r2 {- We need a version of 'append' which is specialised to the lazy time type. Otherwise @append (2 /. 'a' ./ 4 /. 'b' ./ 3 /. undefined) undefined@ does not return the @'b'@. This makes 'testKeyboard7' omitting the last defined note. In realtime performance this leads to the effect, that notes are only played after the key is released. -} matchNoteEvents :: EventListTT.T LazyTime (Int,Int,Bool) -> EventListTT.T LazyTime (Int,Int,LazyTime) matchNoteEvents = EventListMT.mapTimeTail $ \r0 -> flip (EventListMT.switchBodyL EventListBT.empty) r0 $ \(pitchOn,velOn,pressOn) r1 -> let (dur,r2) = if not pressOn then (0, r1) -- isolated NoteOff event else let (prefix,_noteOff,suffix) = break (\(pitchOff,_velOff,pressOff) -> pitchOn == pitchOff && not pressOff) r1 in (lazyDuration prefix, appendTTLazy prefix suffix) in EventListMT.consBody (pitchOn,velOn,dur) $ matchNoteEvents r2 {- | This is like 'EventListTT.append' but more lazy, because it uses the structure of the time value. -} appendTTLazy :: EventListTT.T LazyTime body -> EventListTT.T LazyTime body -> EventListTT.T LazyTime body appendTTLazy xs ys = EventListTT.foldr (\t zs -> let (d,ws) = either EventListMT.viewTimeL ((,) NonNegChunky.zero) zs in EventListMT.consTime (t + d) ws) (\b zs -> Right $ EventListMT.consBody b zs) (Left ys) xs lazyDuration :: EventListTT.T LazyTime body -> LazyTime lazyDuration = foldr (+) 0 . EventListTT.getTimes {- | Find the first matching body element. Event list must be infinite or it must contain a matching body element, otherwise 'body' and the end of the returned list will be undefined. -} break :: (body -> Bool) -> EventListTT.T LazyTime body -> (EventListTT.T LazyTime body, body, EventListTT.T LazyTime body) break p = EventListMT.switchTimeL $ \t xs -> let (prefix,suffix) = EventListBT.span (not . p) xs (b,r) = EventListMT.switchBodyL (error "no matching body element found", error "list ended before matching element found") (,) suffix in (EventListMT.consTime t prefix, b, r) {- | Remove the first matching body element. Event list must be infinite or it must contain a matching body element, otherwise 'body' and the end of the returned list will be undefined. -} remove :: (body -> Bool) -> EventListTT.T LazyTime body -> (body, EventListTT.T LazyTime body) remove p = EventListMT.switchTimeL $ \t xs -> let (prefix,suffix) = EventListBT.span p xs (b,r) = EventListMT.switchBodyL (error "no matching body element found", error "list ended before matching element found") (,) suffix in (b, EventListTT.append (EventListMT.consTime t prefix) r) type Instrument = LazyTime -> Double -> Double -> SigSt.T Double {- | Instrument parameters are: velocity from -1 to 1 (0 is the normal pressure, no pressure aka NoteOff is not supported), frequency is given in Hertz -} makeInstrumentSounds :: Instrument -> EventListTT.T time (Int,Int,LazyTime) -> EventListTT.T time (SigSt.T Double) makeInstrumentSounds instrument = EventListTT.mapBody (\(pitch, vel, dur) -> instrument dur (fromIntegral (vel-64)/63) -- (880 * 2 ** (fromIntegral (pitch + 3 - 6*12) / 12))) (440 * 2 ** (fromIntegral (pitch + 3 - 6*12) / 12))) {- | Turn an event list with lazy times to an event list with strict times. This is much like the version we started on. We could avoid this function with a more sophisticated version of 'arrange'. -} insertBreaks :: EventListTT.T LazyTime (SigSt.T Double) -> EventListTT.T StrictTime (SigSt.T Double) insertBreaks = EventListTT.foldr (\lt r -> case NonNegChunky.toChunksUnsafe (NonNegChunky.normalize lt) of [] -> EventListMT.consTime 0 r (t:ts) -> EventListMT.consTime t $ foldr (\dt -> EventListMT.consBody SigSt.empty . EventListMT.consTime dt) r ts) EventListMT.consBody EventListBT.empty getNoteSignal :: Int -> Instrument -> State (EventList.T StrictTime (Maybe ALSA.Event)) (SigSt.T Double) getNoteSignal chan instr = fmap (CutSt.arrangeEquidist defaultChunkSize . EventListTM.switchTimeR const . EventListTT.mapTime fromIntegral . insertBreaks . makeInstrumentSounds instr . matchNoteEvents) $ getNoteEvents chan ioToLazyList :: IO a -> IO [a] ioToLazyList m = unsafeInterleaveIO $ liftM2 (:) m (ioToLazyList m) dump :: IO () dump = do putStrLn "Starting." h <- ALSA.open ALSA.default_seq_name ALSA.open_input ALSA.Block ALSA.set_client_name h "Haskell-Synthesizer" putStrLn "Created sequencer." p <- ALSA.create_simple_port h "one" (ALSA.caps [ALSA.cap_write, ALSA.cap_subs_write]) ALSA.type_midi_generic let loop = do putStrLn "waiting for an event:" e <- ALSA.event_input h print e loop loop ALSA.delete_port h p putStrLn "Deleted ports." ALSA.close h putStrLn "Closed sequencer." {- | Latency is high using Sox - Can we achieve better results using ALSA's sound output? -} playMonoSox :: (Storable a, RealField.C a) => a -> SigSt.T a -> IO () playMonoSox rate = fmap (const ()) . Play.simple SigSt.hPut SoxOpt.none (round rate) . SigSt.map BinSmp.int16FromCanonical defaultSampleRate :: Num a => a defaultSampleRate = 48000 -- defaultSampleRate = 44100 bufferSize :: Int bufferSize = 256 defaultChunkSize :: SigSt.ChunkSize defaultChunkSize = SigSt.chunkSize bufferSize latency :: Int latency = 1000 {- alsaOpen: only few buffer overruns with let buffer_time = 200000 -- 0.20s period_time = 40000 -- 0.04s However the delay is still perceivable. -} playMono :: (Storable a, RealField.C a) => a -> SigSt.T a -> IO () playMono rate xs = let sink = ALSASig.alsaSoundSink "plughw:0,0" soundFormat ys = SigSt.map BinSmp.int16FromCanonical xs soundFormat :: ALSASig.SoundFmt soundFormat = ALSASig.SoundFmt { ALSASig.sampleFmt = ALSASig.SampleFmtLinear16BitSignedLE, ALSASig.sampleFreq = round rate, ALSASig.numChannels = 1 } in ALSASig.withSoundSink sink $ \to -> flip mapM_ (SVL.chunks (SigSt.append (SigSt.replicate defaultChunkSize latency 0) ys)) $ \c -> SV.withStartPtr c $ \ptr size -> ALSASig.soundSinkWrite sink to (Foreign.castPtr ptr) size