diff --git a/src/Synthesizer/MIDI/CausalIO/Process.hs b/src/Synthesizer/MIDI/CausalIO/Process.hs --- a/src/Synthesizer/MIDI/CausalIO/Process.hs +++ b/src/Synthesizer/MIDI/CausalIO/Process.hs @@ -23,6 +23,7 @@ sequenceCore, sequenceModulated, sequenceModulatedMultiProgram, + sequenceModulatedMultiProgramVelocityPitch, sequenceStorable, -- auxiliary function @@ -102,7 +103,7 @@ (y -> c) -> c -> PIO.T - (EventListTT.T StrictTime [y]) + (Events y) (EventListBT.T PC.ShortStrictTime c) initWith f initial = PIO.traverse initial $ @@ -231,9 +232,8 @@ (Check.C event, Arrow arrow) => MIDIEv.Channel -> arrow - (EventListTT.T StrictTime [event]) - (EventListTT.T StrictTime - [Either MIDIEv.Program (MIDIEv.NoteBoundary Bool)]) + (Events event) + (Events (Either MIDIEv.Program (MIDIEv.NoteBoundary Bool))) noteEvents chan = mapMaybe $ MIDIEv.checkNoteEvent chan @@ -241,10 +241,8 @@ embedPrograms :: MIDIEv.Program -> PIO.T - (EventListTT.T StrictTime - [Either MIDIEv.Program (MIDIEv.NoteBoundary Bool)]) - (EventListTT.T StrictTime - [MIDIEv.NoteBoundary (Maybe MIDIEv.Program)]) + (Events (Either MIDIEv.Program (MIDIEv.NoteBoundary Bool))) + (Events (MIDIEv.NoteBoundary (Maybe MIDIEv.Program))) embedPrograms initPgm = catMaybes . traverse initPgm MIDIEv.embedProgramState @@ -278,7 +276,7 @@ newtype NoteOffList = NoteOffList { - unwrapNoteOffList :: EventListTT.T StrictTime [NoteBoundary NoteId] + unwrapNoteOffList :: Events (NoteBoundary NoteId) } @@ -331,8 +329,7 @@ findEvent :: (a -> Bool) -> - EventListTT.T StrictTime [a] -> - (EventListTT.T StrictTime [a], Maybe a) + Events a -> (Events a, Maybe a) findEvent p = EventListTT.foldr (\t -> mapFst (EventListMT.consTime t)) @@ -365,8 +362,7 @@ case end of NoteBoundary _ endVel _ -> endVel {- - AllNotesOff -> - VoiceMsg.toVelocity VoiceMsg.normalVelocity -} ) + AllNotesOff -> VoiceMsg.normalVelocity -} ) data NoteBoundary a = @@ -405,8 +401,7 @@ concatMap (\(pitch, range) -> map (\noteId -> - NoteBoundary pitch - (VoiceMsg.toVelocity VoiceMsg.normalVelocity) + NoteBoundary pitch VoiceMsg.normalVelocity (noteId, Nothing)) (flattenNoteIdRange range)) $ Map.toList notes @@ -434,16 +429,24 @@ MS.modify (Map.insert pitch (nextNoteOffId, succNoteId nextNoteOnId)) return [nextNoteOnId]) +{-# INLINE velFreqBank #-} +velFreqBank :: + (Trans.C y) => + (MIDIEv.Program -> y -> y -> process) -> + (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch -> process) +velFreqBank bank pgm vel pitch = + bank pgm (MV.velocity vel) (MV.frequencyFromPitch pitch) + applyInstrumentCore :: - (Arrow arrow, Trans.C y) => + (Arrow arrow) => ((MIDIEv.Pitch, NoteId) -> noteOffListCtrl -> gateCtrl) -> - (MIDIEv.Program -> y -> y -> PIO.T gateCtrl chunk) -> + (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch -> + PIO.T gateCtrl chunk) -> arrow - (EventListTT.T StrictTime - [NoteBoundary (NoteId, Maybe MIDIEv.Program)]) + (Events (NoteBoundary (NoteId, Maybe MIDIEv.Program))) (Zip.T NoteOffList - (EventListTT.T StrictTime [PIO.T noteOffListCtrl chunk])) + (Events (PIO.T noteOffListCtrl chunk))) applyInstrumentCore makeGate bank = arr $ uncurry Zip.Cons . mapFst NoteOffList . @@ -456,21 +459,21 @@ Nothing -> Left $ NoteBoundary pitch vel noteId Just pgm -> Right $ - bank pgm (MV.velocity vel) - (MV.frequencyFromPitch pitch) + bank pgm vel pitch <<^ makeGate (pitch, noteId))) applyInstrument :: - (Arrow arrow, Trans.C y) => - Bank y chunk -> + (Arrow arrow) => + (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch -> + PIO.T GateChunk chunk) -> arrow - (EventListTT.T StrictTime - [NoteBoundary (NoteId, Maybe MIDIEv.Program)]) + (Events (NoteBoundary (NoteId, Maybe MIDIEv.Program))) (Zip.T NoteOffList - (EventListTT.T StrictTime [PIO.T NoteOffList chunk])) -applyInstrument = applyInstrumentCore gateFromNoteOffs + (Events (PIO.T NoteOffList chunk))) +applyInstrument bank = + applyInstrumentCore gateFromNoteOffs bank type ModulatedBank y ctrl chunk = @@ -478,17 +481,16 @@ PIO.T (Zip.T GateChunk ctrl) chunk applyModulatedInstrument :: - (Arrow arrow, Trans.C y, CutG.Read ctrl) => - ModulatedBank y ctrl chunk -> + (Arrow arrow, CutG.Read ctrl) => + (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch -> + PIO.T (Zip.T GateChunk ctrl) chunk) -> arrow (Zip.T - (EventListTT.T StrictTime - [NoteBoundary (NoteId, Maybe MIDIEv.Program)]) + (Events (NoteBoundary (NoteId, Maybe MIDIEv.Program))) ctrl) (Zip.T (Zip.T NoteOffList ctrl) - (EventListTT.T StrictTime - [PIO.T (Zip.T NoteOffList ctrl) chunk])) + (Events (PIO.T (Zip.T NoteOffList ctrl) chunk))) applyModulatedInstrument bank = (\(Zip.Cons (Zip.Cons noteOffs events) ctrl) -> Zip.Cons (Zip.Cons noteOffs ctrl) events) @@ -628,7 +630,7 @@ . flattenControlSchedule . - applyInstrument bank + applyInstrument (velFreqBank bank) . assignNoteIds . @@ -648,7 +650,7 @@ . flattenControlSchedule . - applyModulatedInstrument bank + applyModulatedInstrument (velFreqBank bank) . Zip.arrowFirst (assignNoteIds @@ -666,6 +668,30 @@ ModulatedBank y ctrl chunk -> PIO.T (Zip.T (Events event) ctrl) (EventListTT.T StrictTime chunk) sequenceModulatedMultiProgram channel initPgm bank = + applyModulation + . + flattenControlSchedule + . + applyModulatedInstrument (velFreqBank bank) + . + Zip.arrowFirst + (assignNoteIds + . + embedPrograms initPgm + . + noteEvents channel) + + +-- | may replace the other functions +sequenceModulatedMultiProgramVelocityPitch :: + (Check.C event, Monoid chunk, CutG.Read chunk, + CutG.Transform ctrl, CutG.NormalForm ctrl) => + MIDIEv.Channel -> + MIDIEv.Program -> + (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch -> + PIO.T (Zip.T GateChunk ctrl) chunk) -> + PIO.T (Zip.T (Events event) ctrl) (EventListTT.T StrictTime chunk) +sequenceModulatedMultiProgramVelocityPitch channel initPgm bank = applyModulation . flattenControlSchedule diff --git a/src/Synthesizer/MIDI/Dimensional.hs b/src/Synthesizer/MIDI/Dimensional.hs --- a/src/Synthesizer/MIDI/Dimensional.hs +++ b/src/Synthesizer/MIDI/Dimensional.hs @@ -37,7 +37,6 @@ import qualified Synthesizer.ChunkySize as ChunkySize import qualified Synthesizer.Generic.Cut as CutG -import qualified Synthesizer.Generic.Signal2 as SigG2 import qualified Synthesizer.Generic.Signal as SigG import qualified Synthesizer.Storable.Cut as CutSt import qualified Synthesizer.Storable.Signal as SigSt @@ -185,7 +184,7 @@ {-# INLINE bendWheelPressure #-} bendWheelPressure :: (Check.C event, - SigG.Write sig q, SigG2.Transform sig q q, + SigG.Write sig q, SigG.Transform sig q, RealField.C q, Trans.C q, Module.C q q, Dim.C u) => Channel -> Int -> DN.T (Dim.Recip u) q -> q -> q -> diff --git a/src/Synthesizer/MIDI/EventList.hs b/src/Synthesizer/MIDI/EventList.hs --- a/src/Synthesizer/MIDI/EventList.hs +++ b/src/Synthesizer/MIDI/EventList.hs @@ -120,7 +120,7 @@ Channel -> event -> Maybe (Either Program (NoteBoundary Bool)) checkNoteEvent chan e = msum $ - case_ (Check.note chan e) (\(velocity, pitch, press) -> + case_ (Check.noteExplicitOff chan e) (\(velocity, pitch, press) -> Right $ NoteBoundary pitch velocity press) : case_ (Check.program chan e) Left : {- diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -139,7 +139,7 @@ (ChannelMsg.toChannel 0) (ChannelMsg.Voice $ note (VoiceMsg.toPitch pitch) - (VoiceMsg.toVelocity VoiceMsg.normalVelocity)) + VoiceMsg.normalVelocity) makeNoteOn, makeNoteOff :: Int -> ChannelMsg.T makeNoteOn = makeNote VoiceMsg.NoteOn diff --git a/synthesizer-midi.cabal b/synthesizer-midi.cabal --- a/synthesizer-midi.cabal +++ b/synthesizer-midi.cabal @@ -1,5 +1,5 @@ Name: synthesizer-midi -Version: 0.5 +Version: 0.6 License: GPL License-File: LICENSE Author: Henning Thielemann @@ -15,11 +15,11 @@ Stability: Experimental Tested-With: GHC==6.12.3 Tested-With: GHC==7.2.1 -Cabal-Version: >=1.6 +Cabal-Version: >=1.14 Build-Type: Simple Source-Repository this - Tag: 0.4 + Tag: 0.6 Type: darcs Location: http://code.haskell.org/synthesizer/midi/ @@ -40,21 +40,21 @@ Library Build-Depends: - synthesizer-dimensional >=0.6 && <0.7, - synthesizer-core >=0.5 && <0.6, + synthesizer-dimensional >=0.7 && <0.8, + synthesizer-core >=0.6 && <0.7, sox >=0.2.1 && <0.3, - midi >=0.1.7 && <0.2, + midi >=0.2.1 && <0.3, storable-record >=0.0.2 && <0.1, storablevector >=0.2.5 && <0.3, - deepseq >=1.1 && <1.2, - numeric-prelude >=0.3 && <0.4, + deepseq >=1.1 && <1.4, + numeric-prelude >=0.3 && <0.5, non-negative >=0.1 && <0.2, event-list >=0.1 && <0.2, data-accessor-transformers >=0.2.1 && <0.3, data-accessor >=0.2.1 && <0.3, - containers >=0.1 && <0.5, + containers >=0.1 && <0.6, array >=0.1 && <0.5, - transformers >=0.2 && <0.3, + transformers >=0.2 && <0.4, utility-ht >=0.0.1 && <0.1 If flag(splitBase) @@ -67,8 +67,9 @@ If impl(ghc>=7.0) GHC-Options: -fwarn-unused-do-bind CPP-Options: -DNoImplicitPrelude=RebindableSyntax - Extensions: CPP + Default-Extensions: CPP + Default-Language: Haskell2010 GHC-Options: -Wall Hs-source-dirs: src Exposed-modules: @@ -92,23 +93,45 @@ Synthesizer.MIDI.Dimensional.ValuePlain Executable render-midi - If !flag(buildExamples) + If flag(buildExamples) + Build-Depends: + synthesizer-midi, + synthesizer-core, + sox, + storablevector, + numeric-prelude, + midi, + event-list, + non-negative, + transformers, + base + Else Buildable: False + Default-Language: Haskell2010 GHC-Options: -Wall If impl(ghc>=7.0) GHC-Options: -fwarn-unused-do-bind CPP-Options: -DNoImplicitPrelude=RebindableSyntax - Extensions: CPP - Hs-Source-Dirs: src - Main-Is: Render.hs + Default-Extensions: CPP + Main-Is: src/Render.hs Executable test - If !flag(buildTests) + If flag(buildTests) + Build-Depends: + synthesizer-midi, + synthesizer-core, + storablevector, + numeric-prelude, + midi, + event-list, + transformers, + base + Else Buildable: False + Default-Language: Haskell2010 GHC-Options: -Wall If impl(ghc>=7.0) GHC-Options: -fwarn-unused-do-bind CPP-Options: -DNoImplicitPrelude=RebindableSyntax - Extensions: CPP - Hs-Source-Dirs: src - Main-Is: Test.hs + Default-Extensions: CPP + Main-Is: src/Test.hs