{-# LANGUAGE ExistentialQuantification #-}moduleSound.MIDI.ALSA.Causal(T,lift,liftPoint,map,parallel,eitherIn,traverse,flatten,process,transpose,reverse,delayAdd,Pattern,patternMono,TempoControl,patternTempo,patternMonoTempo,patternPolyTempo,patternSerialTempo,sweep,partition,guide,guideWithMode,cyclePrograms,cycleProgramsDefer,latch,groupLatch,serialLatch,guitar,trainer,)whereimportSound.MIDI.ALSA.Common(Time,TimeAbs,normalVelocity,)importqualifiedSound.MIDI.ALSA.CommonasCommonimportqualifiedSound.MIDI.ALSA.GuitarasGuitarimportqualifiedSound.ALSA.Sequencer.AddressasAddrimportqualifiedSound.ALSA.Sequencer.EventasEventimportqualifiedSound.MIDI.ALSAasMALSAimportqualifiedSound.MIDI.Message.Channel.VoiceasVoiceMsgimportqualifiedSound.MIDI.Message.Channel.ModeasModeMsgimportSound.MIDI.ALSA(normalNoteFromEvent,)importSound.MIDI.Message.Channel(Channel,)importSound.MIDI.Message.Channel.Voice(Controller,Program,)importqualifiedData.EventList.Relative.TimeBodyasEventListimportqualifiedData.EventList.Absolute.TimeBodyasEventListAbsimportqualifiedData.Accessor.Monad.Trans.RWSasAccRWSimportqualifiedData.Accessor.Monad.Trans.StateasAccStateimportqualifiedData.Accessor.TupleasAccTupleimportData.Accessor.Basic((^.),(^=),)importData.Tuple.HT(fst3,)importData.Ord.HT(limit,comparing,)importData.Maybe(maybeToList,)importqualifiedData.List.MatchasMatchimportqualifiedData.ListasListimportqualifiedData.MapasMapimportqualifiedData.SetasSetimportqualifiedControl.CategoryasCatimportqualifiedControl.ApplicativeasAppimportqualifiedControl.Monad.Trans.StateasStateimportqualifiedControl.Monad.Trans.ReaderasReaderimportqualifiedControl.Monad.Trans.RWSasRWSimportqualifiedControl.Monad.Trans.ClassasTransimportqualifiedData.TraversableasTravimportControl.Category((.),id,)importControl.Monad.Trans.Reader(ReaderT,)importControl.Monad(guard,when,)importqualifiedData.MonoidasMnimportData.Word(Word8,)importPreludehiding(init,map,filter,reverse,(.),id,){- |
The list of scheduled triggers must be finite.
This process cannot drop an incoming event.
In order to do so, you must write something of type @T a (Maybe b)@.
For convenience you could wrap this in something like @Ext a b@.
-}dataTab=forallsc.Cons(Eitherca->RWS.RWSTimeAbs(Triggersc)sb)s(Triggersc)newtypeTriggersc=Triggers(EventList.TTimec)instanceFunctorTriggerswherefmapf(Triggersevs)=Triggers$fmapfevsinstanceMn.Monoid(Triggersc)wheremempty=Triggers$EventList.emptymappend(Triggersx)(Triggersy)=Triggers(Common.mergeStablexy){-
data T a b =
forall s c.
Cons (Time -> Either c a ->
State.State s (Maybe b, Maybe (Time,c)))
-}{-
This design allows to modify a trigger event until it fires.
However, when can we ship it?
We only know, if a later event comes in,
that the trigger would have been shipped already.
Alternatively we can always ship them via ALSA
and filter them out on arrival, when they were canceled in the meantime.
To this end we could attach a unique id to every Echo message
and on ALSA input we accept only the message with the most recent id.
data T a b =
forall s c.
Cons (Time -> Either c a ->
State.State (s, Maybe (Time,c)) (Maybe b))
-}{-
data T a b =
forall s trigger.
Trigger trigger =>
Cons (Time -> Maybe a ->
State.State (s, trigger) (Maybe b))
'trigger' is a nested structure of time-stamped objects,
where each leaf object corresponds to a process in the chain.
E.g. (Maybe (Time, x), Maybe (Time, y))
In order to reduce recomputation,
there might be a special type for pairs that stores the minimum time stamp.
-}{-
data T a b =
forall s c.
Cons (Time -> Maybe a ->
State.State (s, EventList.T Time c) (Maybe b))
-}-- * combinators{- |
Here we abuse the 'Applicative' constraint.
Actually we only need 'pure'.
-}lift::(App.Applicativet,Trav.Traversablet)=>Tab->T(ta)(tb)lift=liftPointApp.pure{- |
Typical instance for the traversable type 't' are '[]' and 'Maybe'.
-}liftPoint::(Trav.Traversablet)=>(b->tb){- should be replaced by Pointed constraint -}->Tab->T(ta)(tb)liftPointpure(Consfscs0)=Cons(\ea->caseeaofLeftc->fmappure$f$LeftcRightta->Trav.mapM(f.Right)ta)scs0map::(a->b)->Tabmapf=Cons{-
In case of a trigger, we use the trigger data for output.
Since there won't ever be a trigger,
we never have to create an output object.
-}(return.eitheridf)()Mn.memptymergeEither::Triggersa->Triggersb->Triggers(Eitherab)mergeEither(Triggerseva)(Triggersevb)=Triggers$Common.mergeEitherevaevbcompose::Tbc->Tab->Taccompose(Consgsgtg)(Consfsftf)=Cons(\ma->dob<-routeLeft$casemaofRighta->fmapRight$f(Righta)Left(Leftet)->fmapRight$f(Leftet)Left(Rightet)->return$LeftetrouteRight$gb)(sf,sg)(mergeEithertftg){- |
Run two stream processor in parallel.
We cannot use the @Arrow@ method @&&&@
since we cannot define the @first@ method of the @Arrow@ class.
Consider @first :: arrow a b -> arrow (c,a) (c,b)@
and a trigger where @arrow a b@ generates an event of type @b@.
How could we generate additionally an event of type @c@
without having an input event?
-}parallel::(Mn.Monoidb)=>Tab->Tab->Tabparallel(Consfsftf)(Consgsgtg)=Cons(\ea->caseeaofRighta->App.liftA2Mn.mappend(routeLeft$f$Righta)(routeRight$g$Righta)Left(Leftet)->routeLeft$f$LeftetLeft(Rightet)->routeRight$g$Leftet)(sf,sg)(mergeEithertftg)eitherIn::Tac->Tbc->T(Eitherab)ceitherIn(Consfsftf)(Consgsgtg)=Cons(\ea->caseeaofRight(Lefta)->routeLeft$f$RightaRight(Rightb)->routeRight$g$RightbLeft(Leftet)->routeLeft$f$LeftetLeft(Rightet)->routeRight$g$Leftet)(sf,sg)(mergeEithertftg)routeLeft::RWS.RWSr(Triggersw0)s0a->RWS.RWSr(Triggers(Eitherw0w1))(s0,s1)arouteLeft=mapWriter(fmapLeft).AccRWS.liftAccTuple.firstrouteRight::RWS.RWSr(Triggersw1)s1a->RWS.RWSr(Triggers(Eitherw0w1))(s0,s1)arouteRight=mapWriter(fmapRight).AccRWS.liftAccTuple.secondscheduleSingleTrigger::Time->c->RWS.RWSr(Triggersc)s()scheduleSingleTriggertc=RWS.tell$singleTriggertcsingleTrigger::Time->c->TriggerscsingleTriggertc=Triggers$EventList.singletontcinstanceCat.CategoryTwhereid=mapid(.)=composetraverse::s->(a->State.Statesb)->Tabtraversesf=Cons(rwsFromState.eitheridf)sMn.mempty-- | input is most oftenly of type 'Common.EventDataBundle'flatten::T(Common.Bundlea)(Maybea)flatten=Cons(\e->caseeofLeftev->return$JustevRightevs->doRWS.tell$Triggers$EventList.fromAbsoluteEventList$EventListAbs.fromPairList$List.sortBy(comparingfst)evsreturnNothing)()Mn.memptypartition::(a->Bool)->Ta(Maybea,Maybea)partitionp=map(\a->ifpathen(Justa,Nothing)else(Nothing,Justa))_guideMonoid::(Mn.Monoidb)=>(a->Bool)->Tab->Tab->Tab_guideMonoidpfg=map(maybeMn.memptyid).parallel(liftf.mapfst)(liftg.mapsnd).partitionpguide::(a->Bool)->Tab->Tab->Tabguidepfg=eitherInfg.map(\x->ifpxthenLeftxelseRightx){-
In some cases where we would like to use 'guide',
channel mode messages like 'ModeMsg.AllNotesOff'
must be directed to both branches,
because they may end up in different MIDI channels.
-}guideWithMode::(Mn.Monoidb)=>(Event.Data->Bool)->TEvent.Datab->TEvent.Datab->TEvent.DatabguideWithModepfg=mapMn.mconcat.parallel(mapmaybeToList.liftf.mapfst)(mapmaybeToList.liftg.mapsnd).map(\e->ifCommon.checkMode(constTrue)ethen(Juste,Juste)elseifpethen(Juste,Nothing)else(Nothing,Juste))-- * driver{- |
TODO:
We should allow the process to access and modify the ALSA port number.
-}process::TEvent.DataCommon.EventDataBundle->ReaderTCommon.HandleIO()process(Consfs(TriggersinitTriggers))=doCommon.startQueueReader.ReaderT$\h->{-
Triggers maintains a priority queue parallelly to the queue of ALSA.
We need this in order to associate Haskell values
with the incoming trigger events.
-}letoutputTriggerstriggers=EventListAbs.mapM_(\t->Event.output(Common.sequh)(Common.makeEchoh(Common.deconsTimet)(Event.Custom000))>>return())(const$return())(EventList.toAbsoluteEventList0triggers)gos0(lastTime,triggers0)=do{-
print (realToFrac lastTime :: Double,
List.map
((realToFrac :: TimeAbs -> Double) . Common.deconsTime) $
EventList.getTimes triggers0)
-}ev<-Event.input(Common.sequh)lettime=Common.deconsTime$Common.timeFromStamp(Event.timestampev)triggers1=EventList.decreaseStart(Common.consTime"Causal.process.decreaseStart"(time-lastTime))triggers0(restTriggers1,(dats,s1,TriggersnewTriggers))=caseEvent.bodyevofEvent.CustomEvEvent.Echo_->case(Event.sourceev==Addr.Cons(Common.clienth)(Common.portPrivateh),EventList.viewLtriggers1)of(True,Just((_,c),restTriggers0))->(restTriggers0,RWS.runRWS(f(Leftc))times0)_->(EventList.empty,([],s0,Mn.mempty))dat->(triggers1,RWS.runRWS(f(Rightdat))times0)flipmapM_dats$\(dt,dat)->Event.output(Common.sequh)(Common.makeEventh(Common.incTimedttime)dat)outputTriggers(EventList.delay(Common.consTime"Causal.process.delay"time)$newTriggers)_<-Event.drainOutput(Common.sequh)gos1(time,Common.mergeStablerestTriggers1newTriggers)inoutputTriggersinitTriggers>>Event.drainOutput(Common.sequh)>>gos(0,initTriggers)-- * musical examplestranspose::Int->TEvent.Data(MaybeEvent.Data)transposed=map(Common.transposed){- |
Swap order of keys.
This is a funny effect and a new challenge to playing a keyboard.
-}reverse::TEvent.Data(MaybeEvent.Data)reverse=mapCommon.reversedelayAdd::Word8->Time->TEvent.DataCommon.EventDataBundledelayAdddecayd=map(Common.delayAdddecayd)patternMono::Common.PatternMonoi->Time->TEvent.DataCommon.EventDataBundlepatternMono(Common.PatternMonoselectixs)dur=Cons(\ee->caseeeofLeft(n:ns)->dokeys<-RWS.getscheduleSingleTriggerdurnsreturn$selectndur$Map.toAscListkeysLeft[]->return[]Righte->caseeofEvent.NoteEvnotePartnote->doRWS.modify(Common.updateChordnotePartnote)return[]_->return$Common.singletonBundlee)Map.empty(singleTrigger0ixs)updateChordDur::(Channel,Controller)->(Time,Time)->Event.Data->State.State(Time,Common.KeySet)(Common.EventDataBundle)updateChordDurchanCtrlminMaxDure=caseeofEvent.NoteEvnotePartnote->doAccState.modifyAccTuple.second(Common.updateChordnotePartnote)return[]Event.CtrlEvEvent.Controllerparam|uncurryCommon.controllerMatchchanCtrlparam->doAccState.setAccTuple.first(Common.updateDurparamminMaxDur)return[]_->return$Common.singletonBundleetypeTempoControl=((Channel,Controller),(Time,Time,Time))patternMonoTempo::Common.PatternMonoi->TempoControl->TEvent.DataCommon.EventDataBundlepatternMonoTempo(Common.PatternMonoselectixs)((chan,ctrl),(minDur,defltDur,maxDur))=Cons(\ee->caseeeofLeft(n:ns)->do(dur,keys)<-RWS.getscheduleSingleTriggerdurnsreturn$selectndur$Map.toAscListkeysLeft[]->return[]Righte->rwsFromState$updateChordDur(chan,ctrl)(minDur,maxDur)e)(defltDur,Map.empty)(singleTrigger0ixs)patternPolyTempo::Common.PatternPolyi->TempoControl->TEvent.DataCommon.EventDataBundlepatternPolyTempo(Common.PatternPolyselectixs)((chan,ctrl),(minDur,defltDur,maxDur))=letnextdurrest=EventList.switchLEventList.empty(\(t,_)_->EventList.singleton(fromIntegralt*dur)rest)restinCons(\ee->caseeeofLeftnt->EventList.switchL(return[])(\(_,is)rest->do(dur,keys)<-RWS.getRWS.tell$Triggers$nextdurrestreturn$doCommon.IndexNotedi<-isselecti(fromIntegrald*dur)$Map.toAscListkeys)ntRighte->rwsFromState$updateChordDur(chan,ctrl)(minDur,maxDur)e)(defltDur,Map.empty)(Triggers$nextdefltDurixs)classPatternpatwherepatternTempo::pat->TempoControl->TEvent.DataCommon.EventDataBundleinstancePattern(Common.PatternMonoi)wherepatternTempo=patternMonoTempoinstancePattern(Common.PatternPolyi)wherepatternTempo=patternPolyTempo{-
TODO:
This should not prepend a new key to the queue,
but we should maintain an array of maxNum elements,
where the n-th key is put into the @mod n maxNum@ array element.
-}updateSerialChord::Int->Event.NoteEv->Event.Note->Common.KeyQueue->Common.KeyQueueupdateSerialChordmaxNumnotePartnotechord=letkey=(note^.MALSA.notePitch,note^.MALSA.noteChannel)incasenormalNoteFromEventnotePartnoteof(Event.NoteOn,vel)->takemaxNum$(key,vel):chord_->chordupdateSerialChordDur::Int->(Channel,Controller)->(Time,Time)->Event.Data->State.State(Time,Common.KeyQueue)(Common.EventDataBundle)updateSerialChordDurmaxNumchanCtrlminMaxDure=caseeofEvent.NoteEvnotePartnote->doAccState.modifyAccTuple.second(updateSerialChordmaxNumnotePartnote)return[]Event.CtrlEvEvent.Controllerparam|uncurryCommon.controllerMatchchanCtrlparam->doAccState.setAccTuple.first(Common.updateDurparamminMaxDur)return[]_->return$Common.singletonBundlee{-
TODO:
It should react on 'ModeMsg.AllNotesOff' and 'ModeMsg.AllSoundOff'.
Is there a way to merge it with 'serialLatch'?
-}patternSerialTempo::Int->Common.PatternMonoi->TempoControl->TEvent.DataCommon.EventDataBundlepatternSerialTempomaxNum(Common.PatternMonoselectixs)((chan,ctrl),(minDur,defltDur,maxDur))=Cons(\ee->caseeeofLeft(n:ns)->do(dur,keys)<-RWS.getscheduleSingleTriggerdurnsreturn$selectndurkeysLeft[]->return[]Righte->rwsFromState$updateSerialChordDurmaxNum(chan,ctrl)(minDur,maxDur)e)(defltDur,[])(singleTrigger0ixs)sweep::Channel->Time->(Controller,(Time,Time))->Controller->Controller->(Double->Double)->TEvent.Data[Event.Data]sweepchandur(speedCtrl,(minSpeed,maxSpeed))depthCtrlcenterCtrlwave=Cons(\ee->caseeeofLeft()->doev<-RWS.gets$\s->Event.CtrlEvEvent.Controller$MALSA.controllerEventchancenterCtrl$round$limit(0,127)$Common.sweepCenters+Common.sweepDepths*wave(Common.sweepPhases)RWS.modify$\s->s{Common.sweepPhase=Common.fraction(Common.sweepPhases+Common.sweepSpeeds)}scheduleSingleTriggerdur()return[ev]Righte->maybe(return[e])(\f->RWS.modifyf>>return[])$doEvent.CtrlEvEvent.Controllerparam<-Justeletc=param^.MALSA.ctrlChannelctrl=param^.MALSA.ctrlControllerx::Numa=>ax=fromIntegral(Event.ctrlValueparam)guard(c==chan)lookupctrl$(speedCtrl,\s->s{Common.sweepSpeed=realToFrac$Common.deconsTime$(dur*)$minSpeed+(maxSpeed-minSpeed)*x/127}):(depthCtrl,\s->s{Common.sweepDepth=x}):(centerCtrl,\s->s{Common.sweepCenter=x}):[])(Common.SweepState{Common.sweepSpeed=realToFrac$Common.deconsTime$dur*(minSpeed+maxSpeed)/2,Common.sweepDepth=64,Common.sweepCenter=64,Common.sweepPhase=0})(singleTrigger0())cyclePrograms::[Program]->TEvent.Data[Event.Data]cycleProgramspgms=traverse(cyclepgms)(Common.traverseProgramsSeek(lengthpgms)){- |
> cycleProgramsDefer t
After a note that triggers a program change,
we won't change the program in the next 't' seconds.
This is in order to allow chords being played
and in order to skip accidentally played notes.
-}{-
In the future we might also add a time-out:
After a certain time, where no key is pressed,
the program would be reset to the initial program.
-}cycleProgramsDefer::Time->[Program]->TEvent.Data[Event.Data]cycleProgramsDeferdeferpgms=Cons(either(\()->doAccRWS.setAccTuple.secondFalsereturn[])(\e->do-- FIXME: traverseProgramsSeek is not called, if a program change is receivedblock<-RWS.getssndcase(block,e)of(False,Event.NoteEvnotePartnote)->casefst$normalNoteFromEventnotePartnoteofEvent.NoteOn->doAccRWS.setAccTuple.secondTruescheduleSingleTriggerdefer()AccRWS.liftAccTuple.first$rwsFromState$Common.traverseProgramsSeek(lengthpgms)e_->return[e]_->return[e]))(cyclepgms,False)Mn.memptylatch::TEvent.Data(MaybeEvent.Data)latch=traverseSet.empty(\e->caseeofEvent.NoteEvnotePartnote->casenormalNoteFromEventnotePartnoteof(Event.NoteOn,vel)->doletkey=(note^.MALSA.notePitch,note^.MALSA.noteChannel)newNote=(MALSA.noteVelocity^=vel)notepressed<-State.gets(Set.memberkey)ifpressedthenState.modify(Set.deletekey)>>return(Just(Event.NoteEvEvent.NoteOffnewNote))elseState.modify(Set.insertkey)>>return(Just(Event.NoteEvEvent.NoteOnnewNote))(Event.NoteOff,_vel)->returnNothing_->return(Juste)_->return(Juste))releaseKey::VoiceMsg.Velocity->(VoiceMsg.Pitch,Channel)->Event.DatareleaseKeyvel(p,c)=Event.NoteEvEvent.NoteOff$Common.simpleNotecpvelreleasePlayedKeys::VoiceMsg.Velocity->State.State(a,Set.Set(VoiceMsg.Pitch,Channel))[Event.Data]releasePlayedKeysvel=fmap(fmap(releaseKeyvel).Set.toList)$AccState.getAndModifyAccTuple.second(constSet.empty)isAllNotesOff::Event.Data->BoolisAllNotesOff=Common.checkMode$\mode->mode==ModeMsg.AllSoundOff||mode==ModeMsg.AllNotesOff{- |
All pressed keys are latched until a key is pressed after a pause
(i.e. all keys released).
For aborting the pattern you have to send
a 'ModeMsg.AllNotesOff' or 'ModeMsg.AllSoundOff' message.
-}groupLatch::TEvent.Data[Event.Data]groupLatch=traverse(Set.empty{- pressed keys (input) -},Set.empty{- played keys (output) -})(\e->caseeofEvent.NoteEvnotePartnote->letkey=(note^.MALSA.notePitch,note^.MALSA.noteChannel)incasenormalNoteFromEventnotePartnoteof(Event.NoteOn,vel)->dopressed<-AccState.getAccTuple.firstnoteOffs<-ifSet.nullpressedthenreleasePlayedKeysvelelsereturn[]AccState.modifyAccTuple.first(Set.insertkey)played<-AccState.getAccTuple.secondnoteOn<-ifSet.memberkeyplayedthenreturn[]elsedoAccState.modifyAccTuple.second(Set.insertkey)return[Event.NoteEvEvent.NoteOnnote]return$noteOffs++noteOn(Event.NoteOff,_vel)->AccState.modifyAccTuple.first(Set.deletekey)>>return[]_->return[e]_->ifisAllNotesOffethenreleasePlayedKeysnormalVelocityelsereturn[e]){- |
A key is hold until @n@ times further keys are pressed.
The @n@-th pressed key replaces the current one.
-}serialLatch::Int->TEvent.Data[Event.Data]serialLatchn=traverse(0,Map.empty)(\e->caseeofEvent.NoteEvnotePartnote->letkey=(note^.MALSA.notePitch,note^.MALSA.noteChannel)incasenormalNoteFromEventnotePartnoteof(Event.NoteOn,vel)->dok<-AccState.getAndModifyAccTuple.first(flipmodn.(1+))oldKey<-fmap(Map.lookupk)$AccState.getAccTuple.secondAccState.modifyAccTuple.second(Map.insertkkey)return$maybeToList(fmap(releaseKeyvel)oldKey)++[e](Event.NoteOff,_vel)->return[]_->return[e]_->ifisAllNotesOffethenfmap(fmap(releaseKeynormalVelocity).Map.elems)$AccState.getAndModifyAccTuple.second(constMap.empty)elsereturn[e])newtypePitchChannel=PitchChannel((VoiceMsg.Pitch,Channel),VoiceMsg.Velocity)deriving(Show)instanceEqPitchChannelwhere(PitchChannel((p0,_),_))==(PitchChannel((p1,_),_))=p0==p1instanceOrdPitchChannelwherecompare(PitchChannel((p0,_),_))(PitchChannel((p1,_),_))=comparep0p1instanceGuitar.TransposePitchChannelwheregetPitch(PitchChannel((p,_),_))=VoiceMsg.fromPitchptransposed(PitchChannel((p,c),v))=dop'<-Common.increasePitchdpreturn$PitchChannel((p',c),v)noteSequence::(Numa)=>a->Event.NoteEv->[Event.Note]->[(a,Event.Data)]noteSequencestepTimeonOffnotes=zip(iterate(stepTime+)0)$fmap(Event.NoteEvonOff)notes{- |
Try for instance @guitar 0.05 0.03@.
This process simulates playing chords on a guitar.
If you press some keys like C, E, G on the keyboard,
then this process figures out what tones would be played on a guitar
and plays them one after another with short delays.
If you release the keys then the chord is played in reverse order.
This simulates the hand going up and down on the guitar strings.
Unfortunatley it is not possible to go up twice or go down twice this way.
The octaves of the pressed keys are ignored.
In detail calling @guitar collectTime stepTime@ means:
If a key is pressed,
then collect all key-press events for the next @collectTime@ seconds.
After this period, send out a guitar-like chord pattern for the pressed keys
with a delay of @stepTime@ between the notes.
Now wait until all keys are released.
Note that in the meantime keys could have been pressed or released.
They are registered, but not played.
If all keys are released then send out the reverse chord.
On an AllSoundOff message, release all played tones.
I don't know whether emitted key-events are always consistent.
-}guitar::Time->Time->TEvent.DataCommon.EventDataBundleguitarcollectTimestepTime=Cons(\ee->caseeeofLeft()->dopressed<-AccRWS.getAccTuple.first3played<-AccRWS.getAccTuple.second3letchord=fmap(\(PitchChannel((p,c),v))->MALSA.noteEventcpvv0)$Guitar.mapChordToStringGuitar.stringPitches$fmapPitchChannel$Map.toAscListpressedAccRWS.setAccTuple.second3chordreturn$(noteSequencestepTimeEvent.NoteOff$List.reverseplayed)++noteSequencestepTimeEvent.NoteOnchordRighte->caseeofEvent.NoteEvnotePartnote->doletkey=(note^.MALSA.notePitch,note^.MALSA.noteChannel)normalNote=normalNoteFromEventnotePartnotecasenormalNoteof(Event.NoteOn,vel)->AccRWS.modifyAccTuple.first3(Map.insertkeyvel)(Event.NoteOff,_vel)->AccRWS.modifyAccTuple.first3(Map.deletekey)_->return()down<-AccRWS.getAccTuple.third3ifdownthendoallKeysReleased<-RWS.gets(Map.null.fst3)ifallKeysReleasedthendoAccRWS.setAccTuple.third3Falseplayed<-AccRWS.getAccTuple.second3return$noteSequencestepTimeEvent.NoteOffplayed++(noteSequencestepTimeEvent.NoteOn$List.reverseplayed)elsereturn[]elsefmap(const[])$casefstnormalNoteofEvent.NoteOn->doscheduleSingleTriggercollectTime()AccRWS.setAccTuple.third3True_->return()_->ifisAllNotesOffethendoplayer<-AccRWS.getAndModifyAccTuple.second3(const[])return$Common.immediateBundle$fmap(Event.NoteEvEvent.NoteOff)playerelsereturn$Common.singletonBundlee)(Map.empty{- pressed keys (input) -},[]{- played tones (output) -},False)Mn.mempty{- |
Audio perception trainer
Play sets of notes and
let the human player answer to them according to a given scheme.
Repeat playing the notes sets until the trainee answers correctly.
Then continue with other sequences, maybe more complicated ones.
possible tasks:
- replay a sequence of pitches on the keyboard:
single notes for training abolute pitches,
intervals all with the same base notes,
intervals with different base notes
- transpose a set of pitches:
tranpose to a certain base note,
transpose by a certain interval
- play a set of pitches in a different order:
reversed order,
in increasing pitch
- replay a set of simultaneously pressed keys
The difficulty can be increased by not connecting
the keyboard directly with the sound generator.
This way, the trainee cannot verify,
how the pressed keys differ from the target keys.
Sometimes it seems that you are catched in an infinite loop.
This happens if there were too many keys pressed.
The trainer collects all key press events,
not only the ones that occur after the target set is played.
This way you can correct yourself immediately,
before the target is repeatedly played.
The downside is, that there may be key press events hanging around.
You can get rid of them by pressing a key again and again,
but slowly, until the target is played, again.
Then the queue of registered keys should be empty
and you can proceed training.
-}trainer::Channel->Time->Time->[([VoiceMsg.Pitch],[VoiceMsg.Pitch])]->TEvent.DataCommon.EventDataBundletrainerchanpausedurationsets0=Cons(\ee->caseeeofLeft()->dosets<-AccRWS.getAccTuple.firstreturn$casesetsof(target,_):_->concat$zipWith(\tp->[(t,Event.NoteEvEvent.NoteOn$Common.simpleNotechanpnormalVelocity),(t+duration,Event.NoteEvEvent.NoteOff$Common.simpleNotechanpnormalVelocity)])(iterate(duration+)0)target[]->[]Right(Event.NoteEvnotePartnote)->casefst$normalNoteFromEventnotePartnoteofEvent.NoteOn->dopressed<-AccRWS.getAccTuple.secondletnewPressed=(note^.MALSA.notePitch):pressedAccRWS.setAccTuple.secondnewPressedsets<-AccRWS.getAccTuple.firstcasesetsof(_,target):rest->when(Match.lessOrEqualLengthtargetnewPressed)$doAccRWS.setAccTuple.second[]when(newPressed==List.reversetarget)$AccRWS.setAccTuple.firstrestscheduleSingleTriggerpause()_->return()return[]_->return[]_->return[])(sets0,[])(singleTrigger0())-- * auxiliary functions for monad transformersrwsFromState::(Mn.Monoidw,Monadm)=>State.StateTsma->RWS.RWSTrwsmarwsFromStateact=dos0<-RWS.get(a,s1)<-Trans.lift$State.runStateTacts0RWS.puts1returnamapWriter::(Mn.Monoidw0,Mn.Monoidw1,Monadm)=>(w0->w1)->RWS.RWSTrw0sma->RWS.RWSTrw1smamapWriterfact=RWS.RWST$\rs0->do(a,s1,w)<-RWS.runRWSTactrs0return(a,s1,fw)