{-# LANGUAGE NoImplicitPrelude #-}moduleSynthesizer.EventList.ALSA.MIDIwhereimportqualifiedSound.ALSA.Sequencer.AddressasAddrimportqualifiedSound.ALSA.Sequencer.ClientasClientimportqualifiedSound.ALSA.Sequencer.PortasPortimportqualifiedSound.ALSA.Sequencer.EventasEventimportqualifiedSound.ALSA.Sequencer.QueueasQueueimportqualifiedSound.ALSA.Sequencer.RealTimeasRealTimeimportqualifiedSound.ALSA.SequencerasSndSeqimportqualifiedSound.ALSA.ExceptionasAlsaExcimportqualifiedData.EventList.Relative.TimeBodyasEventList-- import qualified Data.EventList.Relative.TimeTime as EventListTTimportqualifiedData.EventList.Relative.MixedBodyasEventListMB-- 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 EventListBTimportqualifiedData.EventList.Relative.BodyBodyasEventListBBimportqualifiedData.EventList.Absolute.TimeBodyasAbsEventListimportqualifiedSound.MIDI.Message.ChannelasChannelMsgimportqualifiedSound.MIDI.Message.Channel.ModeasModeimportqualifiedSound.MIDI.ALSAasMALSAimportqualifiedData.Accessor.BasicasAccimportData.Accessor.Basic((^.),)importSystem.IO.Unsafe(unsafeInterleaveIO,)importControl.Concurrent(threadDelay)importSystem.Time(ClockTime(TOD),getClockTime,)importControl.Monad.Trans.State(State,state,evalState,modify,get,gets,put,)importData.Traversable(traverse,)importqualifiedNumeric.NonNegative.ClassasNonNegimportqualifiedNumeric.NonNegative.WrapperasNonNegWimportqualifiedNumeric.NonNegative.ChunkyasNonNegChunky-- import Data.Monoid (Monoid, mconcat, mappend, )importqualifiedAlgebra.ToRationalasToRationalimportqualifiedAlgebra.RealFieldasRealFieldimportqualifiedAlgebra.FieldasField-- import qualified Algebra.Additive as AdditiveimportData.Array(Array,listArray,(!),bounds,inRange,)importqualifiedData.List.HTasListHTimportData.Tuple.HT(mapPair,mapFst,mapSnd,)importData.Maybe.HT(toMaybe,)importData.Maybe(catMaybes,isNothing,)importControl.Monad.HT((<=<),)importControl.Monad(liftM,liftM2,guard,)importqualifiedData.ListasListimportNumericPrelude.NumericimportNumericPrelude.BaseimportqualifiedPreludeasP-- import Debug.Trace (trace, ){- |
The @time@ type needs high precision,
so you will certainly have to instantiate it with 'Double'.
'Float' has definitely not enough bits.
-}getTimeSeconds::Field.Ctime=>IOtimegetTimeSeconds=fmapclockTimeToSecondsgetClockTimeclockTimeToSeconds::Field.Ctime=>ClockTime->timeclockTimeToSeconds(TODsecspicos)=fromIntegersecs+fromIntegerpicos*1e-12wait::RealField.Ctime=>time->IO()waitt1=dot0<-getTimeSecondsthreadDelay$floor$1e6*(t1-t0){-
We cannot easily turn this into a custom type,
since we need Maybe Event.T sometimes.
-}typeStampedEventtime=(time,Event.T){- |
only use it for non-blocking sequencers
We ignore ALSA time stamps and use the time of fetching the event,
because I don't know whether the ALSA time stamps are in sync with getClockTime.
-}getStampedEvent::(Field.Ctime,SndSeq.AllowInputmode)=>SndSeq.Tmode->IO(StampedEventtime)getStampedEventh=liftM2(,)getTimeSeconds(Event.inputh){- | only use it for non-blocking sequencers -}getWaitingStampedEvents::(Field.Ctime,SndSeq.AllowInputmode)=>SndSeq.Tmode->IO[StampedEventtime]getWaitingStampedEventsh=letloop=AlsaExc.catch(liftM2(:)(getStampedEventh)loop)(const$return[])inloop{- | only use it for blocking sequencers -}getEventsUntilEcho_::(Field.Ctime,SndSeq.AllowInputmode)=>SndSeq.Tmode->IO[StampedEventtime]getEventsUntilEcho_h=letloop=doev<-Event.inputhlett=caseEvent.timestampevofEvent.RealTimert->-- realToFrac $fromRational'$toRational$RealTime.toDoublert_->error"unsupported time stamp type"caseEvent.bodyevofEvent.CustomEvEvent.Echo_->return[]_->liftM((t,ev):)loopinloopgetEventsUntilEcho::(SndSeq.AllowInputmode)=>Client.T->SndSeq.Tmode->IO[Event.T]getEventsUntilEchoch=letloop=doev<-Event.inputhletabort=caseEvent.bodyevofEvent.CustomEvEvent.Echo_->c==Addr.client(Event.sourceev)_->Falseifabortthenreturn[]elseliftM(ev:)loopinloopgetWaitingEvents::(SndSeq.AllowInputmode)=>SndSeq.Tmode->IO[Event.T]getWaitingEventsh=letloop=AlsaExc.catch(liftM2(:)(Event.inputh)loop)(const$return[])inlooptypeStrictTime=NonNegW.Integer{- |
Returns a list of non-zero times.
-}{-# INLINE chopLongTime #-}chopLongTime::StrictTime->[StrictTime]chopLongTimen=letd=NonNegW.fromNumber$fromIntegral(maxBound::Int)(q,r)=P.divModndinList.genericReplicateqd++ifr/=NonNeg.zerothen[r]else[]{-
ghc -i:src -e 'withMIDIEvents 44100 print' src/Synthesizer/Storable/ALSA/MIDI.hs
-}{-
Maybe it is better to not use type variable for sample rate,
because ALSA supports only integers,
and if ALSA sample rate and sample rate do not match due to rounding errors,
then play and event fetching get out of sync over the time.
-}withMIDIEvents::(RealField.Ctime)=>time->time->(EventList.TStrictTime[Event.T]->IOa)->IOawithMIDIEvents=withMIDIEventsBlockEcho{-
as a quick hack, we neglect the ALSA time stamp and use getTime or so
-}withMIDIEventsNonblockWaitGrouped::(RealField.Ctime)=>time->time->(EventList.TStrictTime[Event.T]->IOa)->IOawithMIDIEventsNonblockWaitGroupedbeatrateproc=withInPortSndSeq.Nonblock$\h_p->dostart<-getTimeSecondsl<-lazySequence$flipmap(iterate(beat+)start)$\t->waitt>>liftM(\evs->(t,evs))(getWaitingEventsh){-
liftM2 (,)
getTimeSeconds
(getWaitingEvents h)
-}proc$discretizeTimerate$AbsEventList.fromPairListl{-
With this function latency becomes longer and longer if xruns occur,
but the latency is not just adapted,
but ones xruns occur, this implies more and more xruns.
-}withMIDIEventsNonblockWaitDefer::(RealField.Ctime)=>time->time->(EventList.TStrictTime(MaybeEvent.T)->IOa)->IOawithMIDIEventsNonblockWaitDeferbeatrateproc=withInPortSndSeq.Nonblock$\h_p->dostart<-getTimeSecondsl<-lazySequence$flipmap(iterate(beat+)start)$\t->waitt>>liftM(\es->(t,Nothing):map(mapSndJust)es)(getWaitingStampedEventsh)proc$discretizeTimerate${-
delay events that are in wrong order
disadvantage: we cannot guarantee a beat with a minimal period
-}flipevalStatestart$AbsEventList.mapTimeM(\t->modify(maxt)>>get)$AbsEventList.fromPairList$concatl{-
We risk and endless skipping when the beat is too short.
(Or debug output slows down processing.)
-}withMIDIEventsNonblockWaitSkip::(RealField.Ctime)=>time->time->(EventList.TStrictTime(MaybeEvent.T)->IOa)->IOawithMIDIEventsNonblockWaitSkipbeatrateproc=withInPortSndSeq.Nonblock$\h_p->dostart<-getTimeSecondsl<-lazySequence$flipmap(iterate(beat+)start)$\t->dowaittt0<-getTimeSeconds-- print (t-start,t0-start)es<-ift0>=t+beatthenreturn[]elsegetWaitingStampedEventshreturn$(t0,Nothing):map(mapSndJust)esproc$discretizeTimerate$AbsEventList.fromPairList$concatlwithMIDIEventsNonblockWaitMin::(RealField.Ctime)=>time->time->(EventList.TStrictTime(MaybeEvent.T)->IOa)->IOawithMIDIEventsNonblockWaitMinbeatrateproc=withInPortSndSeq.Nonblock$\h_p->dostart<-getTimeSecondsl<-lazySequence$flipmap(iterate(beat+)start)$\t->waitt>>liftM(\es->(minimum$t:mapfstes,Nothing):map(mapSndJust)es)(getWaitingStampedEventsh){-
mapM_ print $ EventList.toPairList $
discretizeTime rate $
AbsEventList.fromPairList $ concat l
proc undefined
-}proc$discretizeTimerate$AbsEventList.fromPairList$concatlwithMIDIEventsNonblockConstantPause::(RealField.Ctime)=>time->time->(EventList.TStrictTime(MaybeEvent.T)->IOa)->IOawithMIDIEventsNonblockConstantPausebeatrateproc=withInPortSndSeq.Nonblock$\h_p->dol<-ioToLazyList$threadDelay(round$flipasTypeOfrate$beat*1e6)>>liftM2(:)(liftM(\t->(t,Nothing))getTimeSeconds)(liftM(map(mapSndJust))(getWaitingStampedEventsh))proc$discretizeTimerate$AbsEventList.fromPairList$concatlwithMIDIEventsNonblockSimple::(RealField.Ctime)=>time->time->(EventList.TStrictTimeEvent.T->IOa)->IOawithMIDIEventsNonblockSimplebeatrateproc=withInPortSndSeq.Nonblock$\h_p->dol<-ioToLazyList$threadDelay(round$flipasTypeOfrate$beat*1e6)>>getWaitingStampedEventshproc$discretizeTimerate$AbsEventList.fromPairList$concatlwithMIDIEventsBlockEcho::(RealField.Ctime)=>time->time->(EventList.TStrictTime[Event.T]->IOa)->IOawithMIDIEventsBlockEchobeatrateproc=withInPortSndSeq.Block$\hp->Queue.withh$\q->do{-
info <- PortInfo.get h p
PortInfo.setTimestamping info True
PortInfo.setTimestampReal info True
PortInfo.setTimestampQueue info q
PortInfo.set h p info
-}Queue.controlhqEvent.QueueStart0NothingEvent.drainOutputhc<-Client.getIdhl<-lazySequence$flipmap(iterate(beat+)0)$\t->doEvent.outputh$makeEchocqp(t+beat)(Event.Custom000)Event.drainOutputhliftM(\evs->(t,evs))(getEventsUntilEchoch)proc$discretizeTimerate$AbsEventList.fromPairListlmakeEcho::RealField.Ctime=>Client.T->Queue.T->Port.T->time->Event.Custom->Event.TmakeEchocqptdat=Event.Cons{Event.highPriority=False,Event.tag=0,Event.queue=q,Event.timestamp=Event.RealTime$RealTime.fromInteger$floor(10^9*t),Event.source=Addr.Cons{Addr.client=c,Addr.port=Port.unknown},Event.dest=Addr.Cons{Addr.client=c,Addr.port=p},Event.body=Event.CustomEvEvent.Echodat}withMIDIEventsBlock::(RealField.Ctime)=>time->(EventList.TStrictTimeEvent.T->IOa)->IOawithMIDIEventsBlockrateproc=withInPortSndSeq.Block$\h_p->dol<-ioToLazyList$getStampedEventhproc$discretizeTimerate$AbsEventList.fromPairListlwithInPort::SndSeq.BlockMode->(SndSeq.TSndSeq.DuplexMode->Port.T->IOt)->IOtwithInPortblockModeact=SndSeq.withSndSeq.defaultNameblockMode$\h->Client.setNameh"Haskell-Synthesizer">>Port.withSimpleh"listener"(Port.caps[Port.capWrite,Port.capSubsWrite])Port.typeMidiGeneric(acth){- |
We first discretize the absolute time values,
then we compute differences,
in order to avoid rounding errors in further computations.
-}discretizeTime::(RealField.Ctime)=>time->AbsEventList.Ttimea->EventList.TStrictTimeadiscretizeTimesampleRate=EventListMB.mapTimeHead(const$NonNegW.fromNumberzero).-- clear first time since it is an absolute system time stampEventList.fromAbsoluteEventList.AbsEventList.mapTime(NonNegW.fromNumberMsg"time conversion".round.(sampleRate*))-- * event filterstypeFilter=State(EventList.TStrictTime[Event.T]){-
Maybe we could use StorableVector.Pattern.LazySize
or we could use synthesizer-core/ChunkySize.
What package should we rely on?
Which one is more portable?
We do not use this type for timing in event lists anymore.
It worked in principle but left us with a couple of memory leaks,
that I could never identify and eliminate completely.
-}typeLazyTime=NonNegChunky.TNonNegW.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::(Event.T->Maybea)->Filter(EventList.TStrictTime[a])getSlicef=state$EventList.unzip.fmap(ListHT.partitionMaybef)typeChannel=ChannelMsg.ChanneltypeController=ChannelMsg.ControllertypePitch=ChannelMsg.PitchtypeVelocity=ChannelMsg.VelocitytypeProgram=ChannelMsg.ProgrammaybeAnyController::Channel->Event.T->Maybe(Controller,Int)maybeAnyControllerchane=do-- let Event.TickTime n = Event.timestamp eEvent.CtrlEvEvent.Controllerc<-Just$Event.bodyeguard(c^.MALSA.ctrlChannel==chan)MALSA.Controllercncv<-Just$c^.MALSA.ctrlControllerModereturn(cn,cv)maybeController::Channel->Controller->Event.T->MaybeIntmaybeControllerchanctrle=do(c,n)<-maybeAnyControllerchaneguard(ctrl==c)returnngetControllerEvents::Channel->Controller->Filter(EventList.TStrictTime[Int])getControllerEventschanctrl=getSlice(maybeControllerchanctrl){-
getControllerEvents ::
Channel -> Controller ->
Filter (EventList.T StrictTime (Maybe Int))
getControllerEvents chan ctrl =
fmap (fmap (fmap snd . ListHT.viewR)) $
getSlice (maybeController chan ctrl)
-}maybePitchBend::Channel->Event.T->MaybeIntmaybePitchBendchane=caseEvent.bodyeofEvent.CtrlEvEvent.PitchBendc->toMaybe(c^.MALSA.ctrlChannel==chan)(c^.MALSA.ctrlValue)_->NothingmaybeChannelPressure::Channel->Event.T->MaybeIntmaybeChannelPressurechane=caseEvent.bodyeofEvent.CtrlEvEvent.ChanPressc->toMaybe(c^.MALSA.ctrlChannel==chan)(c^.MALSA.ctrlValue)_->NothingdataNoteBoundarya=NoteBoundaryPitchVelocitya|AllNotesOffderiving(Eq,Show)dataNote=NoteProgramPitchVelocityLazyTimederiving(Eq,Show){-
We could also provide a function which filters for specific programs/presets.
-}getNoteEvents::Channel->Filter(EventList.TStrictTime[EitherProgram(NoteBoundaryBool)])getNoteEventschan=getSlice$\e->caseEvent.bodyeofEvent.NoteEvnotePartnote->doguard(note^.MALSA.noteChannel==chan)let(part,vel)=MALSA.normalNoteFromEventnotePartnotepress<-casepartofEvent.NoteOn->JustTrueEvent.NoteOff->JustFalse_->Nothingreturn$Right$NoteBoundary(note^.MALSA.notePitch)velpressEvent.CtrlEvEvent.PgmChangectrl->doguard(ctrl^.MALSA.ctrlChannel==chan)return$Left$ctrl^.MALSA.ctrlProgram{-
We do not handle AllSoundOff here,
since this would also mean to clear reverb buffers
and this cannot be handled here.
-}Event.CtrlEvEvent.Controllerctrl->doguard(ctrl^.MALSA.ctrlControllerMode==MALSA.ModeMode.AllNotesOff)return$RightAllNotesOff_->NothingembedPrograms::Program->EventList.TStrictTime[EitherProgram(NoteBoundaryBool)]->EventList.TStrictTime[NoteBoundary(MaybeProgram)]embedProgramsinitPgm=fmapcatMaybes.flipevalStateinitPgm.traverse(traverse(-- evaluate program for every event in order to prevent a space leak(\n->state(\s->(seqsn,s)))<=<either(\pgm->putpgm>>returnNothing)(\bnd->gets(Just.casebndofAllNotesOff->constAllNotesOffNoteBoundarypvpress->NoteBoundarypv.toMaybepress))))matchNoteEvents::EventList.TStrictTime[NoteBoundary(MaybeProgram)]->EventList.TStrictTime[Note]matchNoteEvents=matchNoteEventsCore$\bndOn->casebndOnofAllNotesOff->NothingNoteBoundarypitchOnvelOnpressOn->flipfmappressOn$\pgm->(\bndOff->casebndOffofAllNotesOff->TrueNoteBoundarypitchOff_velOffpressOff->pitchOn==pitchOff&&isNothingpressOff,NotepgmpitchOnvelOn)matchNoteEventsCore::(noteBnd->Maybe(noteBnd->Bool,LazyTime->Note))->EventList.TStrictTime[noteBnd]->EventList.TStrictTime[Note]matchNoteEventsCoremethods=letrecourseEvents=EventListMB.switchBodyL$\evs0xs0->caseevs0of[]->([],xs0)ev:evs->casemethodsevofNothing->recourseEvents(EventListMB.consBodyevsxs0)Just(check,cons)->casedurationRemovecheck(EventListMB.consBodyevsxs0)of(dur,xs1)->mapFst(consdur:)(recourseEventsxs1)recourse=EventList.switchLEventList.empty$\(t,evs0)xs0->let(evs1,xs1)=recourseEvents(EventListMB.consBodyevs0xs0)inEventList.constevs1$recoursexs1inrecourse{-
durationRemove Char.isUpper ("a" ./ 3 /. "bf" ./ 5 /. "aCcd" ./ empty :: Data.EventList.Relative.BodyBody.T StrictTime [Char])
-}{- |
Search for specific event,
return its time stamp and remove it.
-}durationRemove::(NonNeg.Ctime)=>(body->Bool)->EventListBB.Ttime[body]->(NonNegChunky.Ttime,EventListBB.Ttime[body])durationRemovep=leterrorEndOfList=(error"no matching body element found",error"list ended before matching element found")recourse=EventListMB.switchBodyL$\evsxs0->let(prefix,suffix0)=breakpevs(suffix1,rest)=casesuffix0of[]->([],flip(EventListMB.switchTimeLerrorEndOfList)xs0$\txs1->mapPair(NonNegChunky.fromChunks.(t:).NonNegChunky.toChunks,EventListMB.consTimet)$recoursexs1)_:ys->(ys,(NonNeg.zero,xs0))inmapSnd(EventListMB.consBody(prefix++suffix1))restinrecoursedurationRemoveTB::(NonNeg.Ctime)=>(body->Bool)->EventList.Ttime[body]->(NonNegChunky.Ttime,EventList.Ttime[body])durationRemoveTBp=leterrorEndOfList=(error"no matching body element found",error"list ended before matching element found")recourse=EventList.switchLerrorEndOfList$\(t,evs)xs->let(prefix,suffix0)=breakpevs(suffix1,rest)=casesuffix0of[]->([],recoursexs)_:ys->(ys,(NonNeg.zero,xs))inmapPair(NonNegChunky.fromChunks.(t:).NonNegChunky.toChunks,EventList.const(prefix++suffix1))restinrecoursemakeInstrumentArray::[instr]->ArrayPrograminstrmakeInstrumentArrayinstrs=listArray(ChannelMsg.toProgram0,ChannelMsg.toProgram(lengthinstrs-1))instrsgetInstrumentFromArray::ArrayPrograminstr->Program->Program->instrgetInstrumentFromArraybankdefltPgmpgm=bank!ifinRange(boundsbank)pgmthenpgmelsedefltPgmioToLazyList::IOa->IO[a]ioToLazyListm=letgo=unsafeInterleaveIO$liftM2(:)mgoingolazySequence::[IOa]->IO[a]lazySequence[]=return[]lazySequence(m:ms)=unsafeInterleaveIO$liftM2(:)m$lazySequencems