packages feed

synthesizer-alsa 0.3 → 0.4

raw patch · 27 files changed

+2087/−612 lines, 27 filesdep +data-accessor-transformersdep +storable-recorddep ~alsa-seqdep ~basedep ~containers

Dependencies added: data-accessor-transformers, storable-record

Dependency ranges changed: alsa-seq, base, containers, midi-alsa, numeric-prelude, sox, synthesizer-core, synthesizer-dimensional

Files

+ src/Synthesizer/CausalIO/ALSA/MIDIControllerSelection.hs view
@@ -0,0 +1,112 @@+module Synthesizer.CausalIO.ALSA.MIDIControllerSelection (+   fromChannel,+   filter,+   T(Cons),++   controllerLinear,+   controllerExponential,+   pitchBend,+   channelPressure,+   ) where++import qualified Synthesizer.CausalIO.Process as PIO+import qualified Synthesizer.CausalIO.ALSA.Process as PAlsa++import qualified Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet as PCS+import qualified Synthesizer.EventList.ALSA.MIDI as MIDIEv+import qualified Synthesizer.MIDIValue as MV++import qualified Sound.ALSA.Sequencer.Event as Event++-- import qualified Data.EventList.Relative.TimeBody  as EventList+import qualified Data.EventList.Relative.TimeTime  as EventListTT++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Field          as Field++import qualified Data.Map as Map+import qualified Data.Maybe as Maybe+import Data.Tuple.HT (mapSnd, )++import Control.Arrow (Arrow, )++import NumericPrelude.Numeric+import NumericPrelude.Base hiding ((.), filter, )+import Prelude ()++++fromChannel ::+   (Arrow arrow) =>+   MIDIEv.Channel ->+   arrow+      (EventListTT.T MIDIEv.StrictTime [Event.T])+      (EventListTT.T MIDIEv.StrictTime [(PCS.Controller, Int)])+fromChannel chan =+   PAlsa.mapMaybe $ PCS.maybeController chan+++-- see PCS.mapInsertMany+mapInsertMany ::+   (Ord key) =>+   [(key,a)] -> Map.Map key a -> Map.Map key a+mapInsertMany assignments inits =+   foldl (flip (uncurry Map.insert)) inits assignments++++data T a =+   Cons PCS.Controller (Int -> a) a++filter ::+   [T a] ->+   PIO.T+      (EventListTT.T MIDIEv.StrictTime [(PCS.Controller, Int)])+      (PCS.T Int a)+filter mapping =+   let dict =+          Map.fromList $+          zipWith (\n (Cons cc f _init) -> (cc, (n, f)))+             [0 ..] mapping+   in  PIO.mapAccum+          (\evs curMap ->+             let ctrlEvs =+                    fmap (Maybe.mapMaybe (\(cc, val) ->+                       fmap (mapSnd ($val)) $ Map.lookup cc dict)) evs+             in  (PCS.Cons curMap ctrlEvs,+                  mapInsertMany+                     (concat $ EventListTT.getBodies ctrlEvs)+                     curMap))+          (Map.fromList $ zip [0..] $+           map (\(Cons _cc _f initVal) -> initVal) mapping)+++controllerLinear ::+   (Field.C y) =>+   MIDIEv.Controller ->+   (y,y) -> y ->+   T y+controllerLinear ctrl bnd initial =+   Cons (PCS.Controller ctrl) (MV.controllerLinear bnd) initial++controllerExponential ::+   (Trans.C y) =>+   MIDIEv.Controller ->+   (y,y) -> y ->+   T y+controllerExponential ctrl bnd initial =+   Cons (PCS.Controller ctrl) (MV.controllerExponential bnd) initial++pitchBend ::+   (Trans.C y) =>+   y -> y ->+   T y+pitchBend range center =+   Cons PCS.PitchBend (MV.pitchBend range center) center++channelPressure ::+   (Trans.C y) =>+   y -> y ->+   T y+channelPressure maxVal initial =+   Cons PCS.Pressure (MV.controllerLinear (zero,maxVal)) initial
+ src/Synthesizer/CausalIO/ALSA/MIDIControllerSet.hs view
@@ -0,0 +1,156 @@+module Synthesizer.CausalIO.ALSA.MIDIControllerSet (+   T,+   fromChannel,+   slice, PCS.Controller(..),++   controllerLinear,+   controllerExponential,+   pitchBend,+   channelPressure,+   bendWheelPressure,+   ) where++import qualified Synthesizer.CausalIO.Process as PIO+import qualified Synthesizer.CausalIO.ALSA.Process as PAlsa++import qualified Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet as PCS+import qualified Synthesizer.PiecewiseConstant.Signal as PC+import qualified Synthesizer.EventList.ALSA.MIDI as MIDIEv+import qualified Synthesizer.MIDIValue.BendModulation as BM+import qualified Synthesizer.MIDIValue.BendWheelPressure as BWP+import qualified Synthesizer.MIDIValue as MV++import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+import qualified Sound.ALSA.Sequencer.Event as Event++-- import qualified Data.EventList.Relative.TimeBody  as EventList+import qualified Data.EventList.Relative.TimeTime  as EventListTT+import qualified Data.EventList.Relative.BodyTime  as EventListBT+import qualified Data.EventList.Relative.MixedTime as EventListMT++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Field          as Field+import qualified Algebra.RealRing       as RealRing++import qualified Control.Monad.Trans.State as MS++import qualified Data.Accessor.Basic as Acc++import qualified Data.Map as Map++import Data.Traversable (Traversable, traverse, )+import Data.Foldable (traverse_, )++import Control.Arrow (Arrow, arr, )+import Control.Category ((.), )++import qualified Data.Maybe as Maybe+import Data.Maybe.HT (toMaybe, )++import NumericPrelude.Numeric+import NumericPrelude.Base hiding ((.), )+import Prelude ()++++-- see PCS.mapInsertMany+mapInsertMany ::+   (Ord key) =>+   [(key,a)] -> Map.Map key a -> Map.Map key a+mapInsertMany assignments inits =+   foldl (flip (uncurry Map.insert)) inits assignments+++fromChannel ::+   MIDIEv.Channel ->+   PIO.T+      (EventListTT.T MIDIEv.StrictTime [Event.T])+      (PCS.T PCS.Controller Int)+fromChannel chan =+   (PIO.traverse Map.empty $ \evs0 -> do+      initial <- MS.get+      fmap (PCS.Cons initial) $+         traverse (\ys -> MS.modify (mapInsertMany ys) >> return ys) evs0)+   .+   PAlsa.mapMaybe (PCS.maybeController chan)+++type T arrow y =+   arrow+      (PCS.T PCS.Controller Int)+      (EventListBT.T PC.ShortStrictTime y)+++slice ::+   (Arrow arrow) =>+   PCS.Controller ->+   (Int -> y) {- ^ This might be a function from "Synthesizer.MIDIValue"+                   or "Synthesizer.Dimensional.MIDIValue" -} ->+   y ->+   T arrow y+slice c f deflt =+   arr $ \(PCS.Cons initial stream) ->+      let yin = maybe deflt f $ Map.lookup c initial+      in  PC.subdivideLongStrict $+          EventListMT.consBody yin $+          flip MS.evalState yin $+          traverse+             (\ys -> traverse_ (MS.put . f) ys >> MS.get) $+          fmap+             (Maybe.mapMaybe+                (\(ci,a) -> toMaybe (c==ci) a))+             stream+++controllerLinear ::+   (Field.C y, Arrow arrow) =>+   MIDIEv.Controller ->+   (y,y) -> y ->+   T arrow y+controllerLinear ctrl bnd initial =+   slice (PCS.Controller ctrl) (MV.controllerLinear bnd) initial++controllerExponential ::+   (Trans.C y, Arrow arrow) =>+   MIDIEv.Controller ->+   (y,y) -> y ->+   T arrow y+controllerExponential ctrl bnd initial =+   slice (PCS.Controller ctrl) (MV.controllerExponential bnd) initial++pitchBend ::+   (Trans.C y, Arrow arrow) =>+   y -> y ->+   T arrow y+pitchBend range center =+   slice PCS.PitchBend (MV.pitchBend range center) center++channelPressure ::+   (Trans.C y, Arrow arrow) =>+   y -> y ->+   T arrow y+channelPressure maxVal initial =+   slice PCS.Pressure (MV.controllerLinear (zero,maxVal)) initial++bendWheelPressure ::+   (RealRing.C y, Trans.C y, Arrow arrow) =>+   Int -> y -> y ->+   T arrow (BM.T y)+bendWheelPressure pitchRange wheelDepth pressDepth =+   arr $ \(PCS.Cons initial stream) ->+      let set key field =+             maybe id (Acc.set field) $+             Map.lookup key initial+          yin =+             set PCS.PitchBend BWP.bend $+             set (PCS.Controller VoiceMsg.modulation) BWP.wheel $+             set PCS.Pressure BWP.pressure $+             BWP.deflt+      in  PC.subdivideLongStrict $+          fmap (BM.fromBendWheelPressure pitchRange wheelDepth pressDepth) $+          EventListMT.consBody yin $+          flip MS.evalState yin $+          traverse (\ys0 -> traverse_ MS.put ys0 >> MS.get) $+          fmap Maybe.catMaybes $+          flip MS.evalState BWP.deflt $+          traverse (traverse PCS.checkBendWheelPressure) stream
+ src/Synthesizer/CausalIO/ALSA/Process.hs view
@@ -0,0 +1,728 @@+{-# LANGUAGE ExistentialQuantification #-}+module Synthesizer.CausalIO.ALSA.Process (+   Events,+   playFromEvents,++   slice,+   controllerLinear,+   controllerExponential,+   pitchBend,+   channelPressure,+   bendWheelPressure,+   constant,++   Instrument,+   Bank,+   GateChunk,+   noteEvents,+   embedPrograms,+   applyInstrument,+   applyModulatedInstrument,+   flattenControlSchedule,+   applyModulation,+   arrangeStorable,+   sequenceCore,+   sequenceModulated,+   sequenceModulatedMultiProgram,+   sequenceStorable,++   -- auxiliary function+   initWith,+   mapMaybe,+   ) where++import qualified Synthesizer.CausalIO.Gate as Gate+import qualified Synthesizer.CausalIO.Process as PIO++import qualified Synthesizer.PiecewiseConstant.Signal as PC+import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as AlsaPC+import qualified Synthesizer.EventList.ALSA.MIDI as MIDIEv+import qualified Synthesizer.Storable.ALSA.Play as Play+import qualified Synthesizer.Storable.Cut as CutSt+import qualified Synthesizer.Generic.Cut as CutG+import qualified Synthesizer.Zip as Zip+import Synthesizer.EventList.ALSA.MIDI (StrictTime, )++import qualified Synthesizer.MIDIValue.BendModulation as BM+import qualified Synthesizer.MIDIValue.BendWheelPressure as BWP+import qualified Synthesizer.MIDIValue as MV++import qualified Sound.ALSA.PCM as PCM+import qualified Sound.ALSA.Sequencer.Event as Event++import qualified Sound.MIDI.ALSA.Check as Check+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg++import Control.DeepSeq (NFData, rnf, )++import qualified Data.EventList.Relative.TimeBody  as EventList+import qualified Data.EventList.Relative.BodyTime  as EventListBT+import qualified Data.EventList.Relative.TimeTime  as EventListTT+import qualified Data.EventList.Relative.TimeMixed as EventListTM+import qualified Data.EventList.Relative.MixedTime as EventListMT+import qualified Data.EventList.Absolute.TimeBody  as AbsEventList++import qualified Numeric.NonNegative.Wrapper as NonNegW+import qualified Numeric.NonNegative.Class as NonNeg++import qualified Algebra.Transcendental as Trans+import qualified Algebra.RealField      as RealField+import qualified Algebra.RealRing       as RealRing+import qualified Algebra.Field          as Field+import qualified Algebra.Additive       as Additive+import qualified Algebra.ToInteger      as ToInteger++import qualified Data.StorableVector as SV+import qualified Data.StorableVector.ST.Strict as SVST+import Foreign.Storable (Storable, )++import Control.Exception (bracket, )++import qualified Control.Monad.Trans.Writer as MW+import qualified Control.Monad.Trans.State as MS+import qualified Control.Monad.Trans.Class as MT+import Control.Monad.IO.Class (liftIO, )++import qualified Data.Traversable as Trav+import Data.Traversable (Traversable, )+import Data.Foldable (traverse_, )++import Control.Arrow (Arrow, arr, (^<<), (<<^), )+import Control.Category ((.), )++import qualified Data.Map as Map++import qualified Data.List.HT as ListHT+import qualified Data.Maybe as Maybe+import Data.Monoid (Monoid, mempty, mappend, )+import Data.Maybe (maybeToList, )+import Data.Tuple.HT (mapFst, mapPair, )++import NumericPrelude.Numeric+import NumericPrelude.Base hiding ((.), sequence, )+import Prelude ()+++type Events = EventListTT.T StrictTime [Event.T]++playFromEvents ::+   (RealField.C time, PCM.SampleFmt a, Additive.C a) =>+   Play.Device -> MIDIEv.ClientName -> time -> time -> PCM.SampleFreq ->+   PIO.T Events (SV.Vector a) ->+   IO ()+playFromEvents device name latency beat rate+      (PIO.Cons next create delete) =+   let sink = Play.makeSink device beat rate+       rateFloat = fromIntegral rate+   in  MIDIEv.withMIDIEventsChunked name beat rateFloat $ \getEventsList ->+       PCM.withSoundSink sink $ \to ->+{-+       Play.writeLazy sink to+          (SVL.replicate+              (SVL.chunkSize $ round (beat * rateFloat))+              (round (latency * rateFloat))+              (zero::Float))+-}+       Play.write sink to+          (SV.replicate (round (latency * rateFloat)) zero) >>+       (bracket create delete $ \state ->+        let loop getEvs0 s0 =+               case getEvs0 of+                  [] -> return ()+                  getEvents : getEvs1 -> do+                     evs <- getEvents+                     (pcm, s1) <- next evs s0+                     Play.write sink to pcm+                     loop getEvs1 s1+        in  loop getEventsList state)+++initWith ::+   (y -> c) ->+   c ->+   PIO.T+      (EventListTT.T StrictTime [y])+      (EventListBT.T PC.ShortStrictTime c)+initWith f initial =+   PIO.traverse initial $+      \evs0 -> do+         y0 <- MS.get+         fmap (PC.subdivideLongStrict . EventListMT.consBody y0) $+            Trav.traverse (\ys -> traverse_ (MS.put . f) ys >> MS.get) evs0++slice ::+   (Event.T -> Maybe Int) ->+   (Int -> y) -> y ->+   PIO.T+      Events+      (EventListBT.T PC.ShortStrictTime y)+slice select f initial =+   initWith f initial . mapMaybe select++++mapMaybe ::+   (Arrow arrow, Functor f) =>+   (a -> Maybe b) ->+   arrow (f [a]) (f [b])+mapMaybe f =+   arr $ fmap $ Maybe.mapMaybe f++catMaybes ::+   (Arrow arrow, Functor f) =>+   arrow (f [Maybe a]) (f [a])+catMaybes =+   arr $ fmap Maybe.catMaybes++traverse ::+   (Traversable f) =>+   s -> (a -> MS.State s b) ->+   PIO.T (f [a]) (f [b])+traverse initial f =+   PIO.traverse initial (Trav.traverse (Trav.traverse f))+++controllerLinear ::+   (Field.C y) =>+   MIDIEv.Channel ->+   MIDIEv.Controller ->+   (y,y) -> y ->+   PIO.T+      Events+      (EventListBT.T PC.ShortStrictTime y)+controllerLinear chan ctrl bnd initial =+   slice (Check.controller chan ctrl)+      (MV.controllerLinear bnd) initial++controllerExponential ::+   (Trans.C y) =>+   MIDIEv.Channel ->+   MIDIEv.Controller ->+   (y,y) -> y ->+   PIO.T+      Events+      (EventListBT.T PC.ShortStrictTime y)+controllerExponential chan ctrl bnd initial =+   slice (Check.controller chan ctrl)+      (MV.controllerExponential bnd) initial++pitchBend ::+   (Trans.C y) =>+   MIDIEv.Channel ->+   y -> y ->+   PIO.T+      Events+      (EventListBT.T PC.ShortStrictTime y)+pitchBend chan range center =+   slice (Check.pitchBend chan)+      (MV.pitchBend range center) center++channelPressure ::+   (Trans.C y) =>+   MIDIEv.Channel ->+   y -> y ->+   PIO.T+      Events+      (EventListBT.T PC.ShortStrictTime y)+channelPressure chan maxVal initial =+   slice (Check.channelPressure chan)+      (MV.controllerLinear (zero,maxVal)) initial++bendWheelPressure ::+   (RealRing.C y, Trans.C y) =>+   MIDIEv.Channel ->+   Int -> y -> y ->+   PIO.T+      Events+      (EventListBT.T PC.ShortStrictTime (BM.T y))+bendWheelPressure chan+      pitchRange wheelDepth pressDepth =+   let toBM = BM.fromBendWheelPressure pitchRange wheelDepth pressDepth+   in  initWith toBM (toBM BWP.deflt)+       .+       catMaybes+       .+       traverse BWP.deflt (AlsaPC.checkBendWheelPressure chan)+++-- might be moved to synthesizer-core+constant ::+   (Arrow arrow) =>+   y -> arrow Events (EventListBT.T PC.ShortStrictTime y)+constant y = arr $+   EventListBT.singleton y .+   NonNegW.fromNumberMsg "CausalIO.ALSA.constant" .+   fromIntegral .+   EventListTT.duration++_constant ::+   (Arrow arrow, CutG.Read input) =>+   y -> arrow input (EventListBT.T PC.ShortStrictTime y)+_constant y = arr $+   EventListBT.singleton y .+   NonNegW.fromNumberMsg "CausalIO.ALSA.constant" .+   CutG.length++++noteEvents ::+   (Arrow arrow) =>+   MIDIEv.Channel ->+   arrow+      (EventListTT.T StrictTime [Event.T])+      (EventListTT.T StrictTime+         [Either MIDIEv.Program (MIDIEv.NoteBoundary Bool)])+noteEvents chan =+   mapMaybe $ MIDIEv.checkNoteEvent chan+++embedPrograms ::+   MIDIEv.Program ->+   PIO.T+      (EventListTT.T StrictTime+         [Either MIDIEv.Program (MIDIEv.NoteBoundary Bool)])+      (EventListTT.T StrictTime+         [MIDIEv.NoteBoundary (Maybe MIDIEv.Program)])+embedPrograms initPgm =+   catMaybes .+   traverse initPgm MIDIEv.embedProgramState+++type GateChunk = Gate.Chunk MIDIEv.Velocity+type Instrument y chunk = y -> y -> PIO.T GateChunk chunk+type Bank y chunk = MIDIEv.Program -> Instrument y chunk++++{-+for distinction of notes with the same pitch++We must use Integer instead of Int, in order to avoid an overflow+that would invalidate the check for unmatched NoteOffs+that is based on comparison of the NoteIds.+We cannot re-use NoteIds easily,+since the events at one time point are handled out of order.+-}+newtype NoteId = NoteId Integer+   deriving (Show, Eq, Ord)++succNoteId :: NoteId -> NoteId+succNoteId (NoteId n) = NoteId (n+1)++flattenNoteIdRange :: (NoteId,NoteId) -> [NoteId]+flattenNoteIdRange (start,afterEnd) =+   takeWhile (<afterEnd) $ iterate succNoteId start+++newtype NoteOffList =+   NoteOffList {+      unwrapNoteOffList :: EventListTT.T StrictTime [NoteBoundary NoteId]+   }+++instance CutG.Read NoteOffList where+   null (NoteOffList evs) =+      EventListTT.isPause evs && EventListTT.duration evs == 0+   length = fromIntegral . EventListTT.duration . unwrapNoteOffList++instance CutG.NormalForm NoteOffList where+   evaluateHead =+      EventListMT.switchTimeL (\t _ -> rnf (NonNegW.toNumber t)) .+      unwrapNoteOffList++instance Monoid NoteOffList where+   mempty = NoteOffList (EventListTT.pause mempty)+   mappend (NoteOffList xs) (NoteOffList ys) =+      NoteOffList (mappend xs ys)++{- |+The function defined here are based on the interpretation+of event lists as piecewise constant signals.+They do not fit to the interpretation of atomic events.+Because e.g. it makes no sense to split an atomic event into two instances by splitAt,+and it is also not clear, whether dropping the first chunk+shall leave a chunk of length zero+or remove that chunk completely.+-}+instance CutG.Transform NoteOffList where+   take n (NoteOffList xs) =+      NoteOffList $+      EventListTT.takeTime+         (NonNegW.fromNumberMsg "NoteOffList.take" $ fromIntegral n) xs+   drop n (NoteOffList xs) =+      NoteOffList $+      EventListTT.dropTime+         (NonNegW.fromNumberMsg "NoteOffList.drop" $ fromIntegral n) xs+   splitAt n (NoteOffList xs) =+      mapPair (NoteOffList, NoteOffList) $+      EventListTT.splitAtTime+         (NonNegW.fromNumberMsg "NoteOffList.splitAtTime" $ fromIntegral n) xs++   -- cf. ChunkySize.dropMarginRem+   dropMarginRem =+      CutG.dropMarginRemChunky+         (fmap fromIntegral . EventListTT.getTimes . unwrapNoteOffList)++   reverse (NoteOffList xs) =+      NoteOffList . EventListTT.reverse $ xs+++findEvent ::+   (a -> Bool) ->+   EventListTT.T StrictTime [a] ->+   (EventListTT.T StrictTime [a], Maybe a)+findEvent p =+   EventListTT.foldr+      (\t -> mapFst (EventListMT.consTime t))+      (\evs rest ->+         case ListHT.break p evs of+            (prefix, suffix) ->+               mapFst (EventListMT.consBody prefix) $+               case suffix of+                  [] -> rest+                  ev:_ -> (EventListTT.pause mempty, Just ev))+      (EventListBT.empty, Nothing)++gateFromNoteOffs ::+   (MIDIEv.Pitch, NoteId) ->+   NoteOffList ->+   GateChunk+gateFromNoteOffs pitchNoteId (NoteOffList noteOffs) =+   let dur = EventListTT.duration noteOffs+       (sustain, mEnd) =+          findEvent+             (\bnd ->+                case bnd of+                   -- AllNotesOff -> True+                   NoteBoundary endPitch _ noteId ->+                      pitchNoteId == (endPitch, noteId))+          noteOffs+   in  Gate.chunk dur $+       flip fmap mEnd $ \end ->+       (EventListTT.duration sustain,+        case end of+           NoteBoundary _ endVel _ -> endVel+           {-+           AllNotesOff ->+              VoiceMsg.toVelocity VoiceMsg.normalVelocity -} )+++data NoteBoundary a =+     NoteBoundary VoiceMsg.Pitch VoiceMsg.Velocity a+--   | AllSoundOff+   deriving (Eq, Show)++{- |+We count NoteIds per pitch,+such that the pair (pitch,noteId) identifies a note.+We treat nested notes in a first-in-first-out order (FIFO).+E.g.++> On, On, On, Off, Off, Off++is interpreted as++> On 0, On 1, On 2, Off 0, Off 1, Off 2++NoteOffs without previous NoteOns are thrown away.+-}+assignNoteIds ::+   (Traversable f) =>+   PIO.T+      (f [MIDIEv.NoteBoundary (Maybe MIDIEv.Program)])+      (f [NoteBoundary (NoteId, Maybe MIDIEv.Program)])+assignNoteIds =+   fmap concat+   ^<<+   traverse Map.empty (\bnd ->+      case bnd of+         MIDIEv.AllNotesOff -> do+            notes <- MS.get+            MS.put Map.empty+            return $+               concatMap (\(pitch, range) ->+                  map+                     (\noteId ->+                        NoteBoundary pitch+                           (VoiceMsg.toVelocity VoiceMsg.normalVelocity)+                           (noteId, Nothing))+                     (flattenNoteIdRange range)) $+               Map.toList notes+         MIDIEv.NoteBoundary pitch vel mpgm ->+            fmap (fmap (\noteId ->+               NoteBoundary pitch vel (noteId,mpgm))) $+            case mpgm of+               Nothing -> do+                  mNoteId <- MS.gets (Map.lookup pitch)+                  case mNoteId of+                     Nothing -> return []+                     Just (nextNoteOffId, nextNoteOnId) ->+                        if nextNoteOffId >= nextNoteOnId+                          then return []+                          else do+                             MS.modify (Map.insert pitch (succNoteId nextNoteOffId, nextNoteOnId))+                             return [nextNoteOffId]+               Just _ -> do+                  mNoteId <- MS.gets (Map.lookup pitch)+                  let (nextNoteOffId, nextNoteOnId) =+                         case mNoteId of+                            Nothing -> (NoteId 0, NoteId 0)+                            Just ids -> ids++                  MS.modify (Map.insert pitch (nextNoteOffId, succNoteId nextNoteOnId))+                  return [nextNoteOnId])++applyInstrumentCore ::+   (Arrow arrow, Trans.C y) =>+   ((MIDIEv.Pitch, NoteId) -> noteOffListCtrl -> gateCtrl) ->+   (MIDIEv.Program -> y -> y -> PIO.T gateCtrl chunk) ->+   arrow+      (EventListTT.T StrictTime+         [NoteBoundary (NoteId, Maybe MIDIEv.Program)])+      (Zip.T+         NoteOffList+         (EventListTT.T StrictTime [PIO.T noteOffListCtrl chunk]))+applyInstrumentCore makeGate bank = arr $+   uncurry Zip.Cons .+   mapFst NoteOffList .+   EventListTT.unzip .+   fmap (ListHT.unzipEithers . fmap (\ev ->+      case ev of+--         MIDIEv.AllNotesOff -> Left MIDIEv.AllNotesOff+         NoteBoundary pitch vel (noteId, mpgm) ->+            case mpgm of+               Nothing -> Left $ NoteBoundary pitch vel noteId+               Just pgm ->+                  Right $+                     bank pgm (MV.velocity vel)+                        (MV.frequencyFromPitch pitch)+                     <<^+                     makeGate (pitch, noteId)))++applyInstrument ::+   (Arrow arrow, Trans.C y) =>+   Bank y chunk ->+   arrow+      (EventListTT.T StrictTime+         [NoteBoundary (NoteId, Maybe MIDIEv.Program)])+      (Zip.T+         NoteOffList+         (EventListTT.T StrictTime [PIO.T NoteOffList chunk]))+applyInstrument = applyInstrumentCore gateFromNoteOffs+++type ModulatedBank y ctrl chunk =+        MIDIEv.Program -> y -> y ->+        PIO.T (Zip.T GateChunk ctrl) chunk++applyModulatedInstrument ::+   (Arrow arrow, Trans.C y, CutG.Read ctrl) =>+   ModulatedBank y ctrl chunk ->+   arrow+      (Zip.T+         (EventListTT.T StrictTime+            [NoteBoundary (NoteId, Maybe MIDIEv.Program)])+         ctrl)+      (Zip.T+         (Zip.T NoteOffList ctrl)+         (EventListTT.T StrictTime+            [PIO.T (Zip.T NoteOffList ctrl) chunk]))+applyModulatedInstrument bank =+   (\(Zip.Cons (Zip.Cons noteOffs events) ctrl) ->+      Zip.Cons (Zip.Cons noteOffs ctrl) events)+   ^<<+   Zip.arrowFirst+      (applyInstrumentCore+         (Zip.arrowFirst . gateFromNoteOffs) bank)+++{- |+Turn an event list with bundles of elements+into an event list with single events.+ToDo: Move to event-list package?+-}+flatten ::+   (NonNeg.C time) =>+   a ->+   EventListTT.T time [a] ->+   EventListTT.T time a+flatten empty =+   EventListTT.foldr+      EventListMT.consTime+      (\bt xs ->+         uncurry EventListMT.consBody $+         case bt of+            [] -> (empty, xs)+            b:bs -> (b, foldr (\c rest -> EventListTT.cons NonNeg.zero c rest) xs bs))+      EventListBT.empty+++flattenControlSchedule ::+   (Monoid chunk, Arrow arrow) =>+   arrow+      (Zip.T ctrl+         (EventListTT.T StrictTime [PIO.T ctrl chunk]))+      (Zip.T ctrl+         (EventListTT.T StrictTime (PIO.T ctrl chunk)))+flattenControlSchedule = arr $+   \(Zip.Cons ctrl evs) ->+      -- Zip.consChecked "flattenControlSchedule" ctrl $+      Zip.Cons ctrl $+      flatten (arr (const mempty)) evs++++data CausalState a b =+   forall state.+   CausalState+      (a -> state -> IO (b, state))+      (state -> IO ())+      state++_applyChunkSimple :: CausalState a b -> a -> IO (b, CausalState a b)+_applyChunkSimple (CausalState next delete state0) input = do+   (output, state1) <- next input state0+   return (output, CausalState next delete state1)++applyChunk ::+   (CutG.Read a, CutG.Read b) =>+   CausalState a b -> a -> IO (b, Maybe (CausalState a b))+applyChunk (CausalState next delete state0) input = do+   (output, state1) <- next input state0+   cs <-+      if CutG.length output < CutG.length input+        then do+           delete state1+           return Nothing+        else return $ Just $ CausalState next delete state1+   return (output, cs)++-- could be moved to synthesizer-core+applyModulation ::+   (CutG.Transform ctrl, CutG.NormalForm ctrl,+    CutG.Read chunk,+    Monoid time, ToInteger.C time) =>+   PIO.T+      (Zip.T ctrl (EventListTT.T time (PIO.T ctrl chunk)))+      (EventListTT.T time chunk)+applyModulation = PIO.Cons+   (\(Zip.Cons ctrl evs) acc0 -> do+      acc1 <- mapM (flip applyChunk ctrl) acc0+      let (accChunks, acc2) = unzip acc1++      (newChunks, newAcc) <-+         MW.runWriterT $+         flip MS.evalStateT ctrl $+         EventListTT.mapM+            (\time -> do+               ctrl_ <- MS.gets (CutG.drop (fromIntegral time))+               MS.put ctrl_+               return (case CutG.evaluateHead ctrl_ of () -> time))+            (\(PIO.Cons next create delete) -> do+               state0 <- liftIO create+               (chunk, state1) <-+                  liftIO . applyChunk (CausalState next delete state0)+                  =<< MS.get+               MT.lift $ MW.tell $ maybeToList state1+               return chunk)+            evs++      return+         (EventListTM.prependBodyEnd+             (EventList.fromPairList $+              map ((,) mempty) accChunks)+             newChunks,+          Maybe.catMaybes acc2 ++ newAcc))++   (return [])+   (mapM_ (\(CausalState _ close state) -> close state))++arrangeStorable ::+   (Arrow arrow, Storable a, Additive.C a) =>+   arrow+      (EventListTT.T StrictTime (SV.Vector a))+      (SV.Vector a)+arrangeStorable =+   arr $ \evs ->+   SVST.runSTVector (do+      v <- SVST.new (fromIntegral $ EventListTT.duration evs) zero+      mapM_ (uncurry $ CutSt.addChunkToBuffer v) $+         AbsEventList.toPairList $+         AbsEventList.mapTime fromIntegral $+         EventList.toAbsoluteEventList 0 $+         EventListTM.switchTimeR const evs+      return v)++++sequenceCore ::+   (Monoid chunk, CutG.Read chunk, Trans.C y) =>+   MIDIEv.Channel ->+   Bank y chunk ->+   PIO.T Events (EventListTT.T StrictTime chunk)+sequenceCore channel bank =+   applyModulation+   .+   flattenControlSchedule+   .+   applyInstrument bank+   .+   assignNoteIds+   .+   embedPrograms (VoiceMsg.toProgram 0)+   .+   noteEvents channel+++sequenceModulated ::+   (Monoid chunk, CutG.Read chunk,+    CutG.Transform ctrl, CutG.NormalForm ctrl, Trans.C y) =>+   MIDIEv.Channel ->+   ModulatedBank y ctrl chunk ->+   PIO.T (Zip.T Events ctrl) (EventListTT.T StrictTime chunk)+sequenceModulated channel bank =+   applyModulation+   .+   flattenControlSchedule+   .+   applyModulatedInstrument bank+   .+   Zip.arrowFirst+      (assignNoteIds+       .+       embedPrograms (VoiceMsg.toProgram 0)+       .+       noteEvents channel)+++sequenceModulatedMultiProgram ::+   (Monoid chunk, CutG.Read chunk,+    CutG.Transform ctrl, CutG.NormalForm ctrl, Trans.C y) =>+   MIDIEv.Channel ->+   MIDIEv.Program ->+   ModulatedBank y ctrl chunk ->+   PIO.T (Zip.T Events ctrl) (EventListTT.T StrictTime chunk)+sequenceModulatedMultiProgram channel initPgm bank =+   applyModulation+   .+   flattenControlSchedule+   .+   applyModulatedInstrument bank+   .+   Zip.arrowFirst+      (assignNoteIds+       .+       embedPrograms initPgm+       .+       noteEvents channel)+++sequenceStorable ::+   (Storable a, Additive.C a, Trans.C y) =>+   MIDIEv.Channel ->+   Bank y (SV.Vector a) ->+   PIO.T Events (SV.Vector a)+sequenceStorable channel bank =+   arrangeStorable+   .+   sequenceCore channel bank
src/Synthesizer/Dimensional/ALSA/MIDI.hs view
@@ -15,6 +15,7 @@  import qualified Synthesizer.Dimensional.MIDIValue as DMV import qualified Synthesizer.MIDIValue as MV+import qualified Sound.MIDI.ALSA.Check as Check  import qualified Synthesizer.Dimensional.Causal.Process    as Causal import qualified Synthesizer.Dimensional.Causal.Filter     as Filt@@ -34,6 +35,7 @@ import Synthesizer.Dimensional.Causal.Process ((<<<), ) import Synthesizer.Dimensional.Process (($:), ) +import qualified Synthesizer.PiecewiseConstant.Signal as PC import qualified Synthesizer.ChunkySize as ChunkySize  import qualified Synthesizer.Generic.Cut          as CutG@@ -69,7 +71,7 @@ import qualified Algebra.Module         as Module import qualified Algebra.RealField      as RealField import qualified Algebra.Field          as Field-import qualified Algebra.Additive       as Additive+-- import qualified Algebra.Additive       as Additive  import Control.Category (Category, (.), ) import Control.Applicative (Applicative, pure, (<*>), liftA2, )@@ -169,7 +171,7 @@        in  return . SigA.fromBody amp .            AlsaPC.initWith               (DMV.pitchBend amp range center) (DN.divToScalar center amp)) $-   AlsaEL.getSlice (AlsaEL.maybePitchBend chan)+   AlsaEL.getSlice (Check.pitchBend chan) --   AlsaEL.getPitchBendEvents chan  @@ -186,7 +188,7 @@        AlsaPC.initWith           (DMV.controllerLinear maxVal (zero,maxVal))           (DN.divToScalar initVal maxVal)) $-   AlsaEL.getSlice (AlsaEL.maybeChannelPressure chan)+   AlsaEL.getSlice (Check.channelPressure chan) --   AlsaEL.getPitchBendEvents chan  @@ -240,8 +242,8 @@ chunkySizeFromLazyTime :: AlsaEL.LazyTime -> ChunkySize.T chunkySizeFromLazyTime =    Chunky.fromChunks .-   map (SigG.LazySize . fromIntegral . NonNegW.toNumber) .-   concatMap AlsaEL.chopLongTime .+   map (SigG.LazySize . NonNegW.toNumber) .+   concatMap PC.chopLongTime .    Chunky98.toChunks .    Chunky98.normalize
src/Synthesizer/Dimensional/ALSA/Play.hs view
@@ -31,6 +31,8 @@ import NumericPrelude.Base  +type Device = String+ type RenderedStorableSignal u t v y yv =    SigA.T (Rate.Dimensional u t) (Amp.Dimensional v y) (SigSt.T yv) @@ -38,72 +40,84 @@    SigA.T (Rate.Phantom s) (Amp.Dimensional v y) (SigSt.T yv)  +makeSink ::+   (ALSA.SampleFmt y, RealRing.C t) =>+   Device {- ^ ALSA output device -} ->+   DN.Time t {- ^ period (buffer) size expressed in seconds -} ->+   DN.Frequency t {- ^ sample rate -} ->+   ALSA.SoundSink y ALSA.Pcm+makeSink device periodTime rate =+   Play.makeSink device+      (DN.toNumberWithDimension Dim.time periodTime)+      (RealRing.round (DN.toNumberWithDimension Dim.frequency rate))++ {-# INLINE timeVoltageStorable #-} timeVoltageStorable ::    (Module.C y yv, ALSA.SampleFmt yv, RealRing.C t) =>+   Device ->    DN.Time t->    RenderedStorableSignal Dim.Time t Dim.Voltage y yv ->    IO ()-timeVoltageStorable period sig =-   let rate = DN.toNumberWithDimension Dim.frequency (SigA.actualSampleRate sig)-       per  = DN.toNumberWithDimension Dim.time period-   in  Play.auto per (RealRing.round rate)-          (SigA.vectorSamples (DN.toNumberWithDimension Dim.voltage) sig)+timeVoltageStorable device period sig =+   Play.auto (makeSink device period (SigA.actualSampleRate sig))+      (SigA.vectorSamples (DN.toNumberWithDimension Dim.voltage) sig)  {-# INLINE timeVoltageMonoStorableToInt16 #-} timeVoltageMonoStorableToInt16 ::    (Storable y, RealRing.C y, RealRing.C t) =>+   Device ->    DN.Time t->    RenderedStorableSignal Dim.Time t Dim.Voltage y y ->    IO ()-timeVoltageMonoStorableToInt16 period sig =-   let rate = DN.toNumberWithDimension Dim.frequency (SigA.actualSampleRate sig)-       per  = DN.toNumberWithDimension Dim.time period-   in  Play.monoToInt16 per (RealRing.round rate)-          (SigA.scalarSamples (DN.toNumberWithDimension Dim.voltage) sig)+timeVoltageMonoStorableToInt16 device period sig =+   Play.monoToInt16 (makeSink device period (SigA.actualSampleRate sig))+      (SigA.scalarSamples (DN.toNumberWithDimension Dim.voltage) sig)  {-# INLINE timeVoltageStereoStorableToInt16 #-} timeVoltageStereoStorableToInt16 ::    (Storable y, Module.C y y, RealRing.C y, RealRing.C t) =>+   Device ->    DN.Time t->    RenderedStorableSignal Dim.Time t Dim.Voltage y (Stereo.T y) ->    IO ()-timeVoltageStereoStorableToInt16 period sig =-   let rate = DN.toNumberWithDimension Dim.frequency (SigA.actualSampleRate sig)-       per  = DN.toNumberWithDimension Dim.time period-   in  Play.stereoToInt16 per (RealRing.round rate)-          (SigA.vectorSamples (DN.toNumberWithDimension Dim.voltage) sig)+timeVoltageStereoStorableToInt16 device period sig =+   Play.stereoToInt16 (makeSink device period (SigA.actualSampleRate sig))+      (SigA.vectorSamples (DN.toNumberWithDimension Dim.voltage) sig)   {-# INLINE renderTimeVoltageStorable #-} renderTimeVoltageStorable ::    (Module.C y yv, ALSA.SampleFmt yv, RealRing.C t) =>+   Device ->    DN.Time t->    DN.T Dim.Frequency t ->    (forall s. Proc.T s Dim.Time t       (StorableSignal s Dim.Voltage y yv)) ->    IO ()-renderTimeVoltageStorable period rate sig =-   timeVoltageStorable period (SigA.render rate sig)+renderTimeVoltageStorable device period rate sig =+   timeVoltageStorable device period (SigA.render rate sig)  {-# INLINE renderTimeVoltageMonoStorableToInt16 #-} renderTimeVoltageMonoStorableToInt16 ::    (Storable y, RealRing.C y, RealRing.C t) =>+   Device ->    DN.Time t->    DN.T Dim.Frequency t ->    (forall s. Proc.T s Dim.Time t       (StorableSignal s Dim.Voltage y y)) ->    IO ()-renderTimeVoltageMonoStorableToInt16 period rate sig =-   timeVoltageMonoStorableToInt16 period (SigA.render rate sig)+renderTimeVoltageMonoStorableToInt16 device period rate sig =+   timeVoltageMonoStorableToInt16 device period (SigA.render rate sig)  {-# INLINE renderTimeVoltageStereoStorableToInt16 #-} renderTimeVoltageStereoStorableToInt16 ::    (Storable y, Module.C y y, RealRing.C y, RealRing.C t) =>+   Device ->    DN.Time t->    DN.T Dim.Frequency t ->    (forall s. Proc.T s Dim.Time t       (StorableSignal s Dim.Voltage y (Stereo.T y))) ->    IO ()-renderTimeVoltageStereoStorableToInt16 period rate sig =-   timeVoltageStereoStorableToInt16 period (SigA.render rate sig)+renderTimeVoltageStereoStorableToInt16 device period rate sig =+   timeVoltageStereoStorableToInt16 device period (SigA.render rate sig)
src/Synthesizer/Dimensional/ALSA/Server/Common.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RankNTypes #-} module Synthesizer.Dimensional.ALSA.Server.Common where  import qualified Synthesizer.Dimensional.ALSA.Play as Play@@ -61,20 +61,32 @@    let (SVL.ChunkSize size) = PlaySt.defaultChunkSize    in  DN.scale (fromIntegral size) $ DN.unrecip sampleRate +device :: Play.Device+device = PlaySt.defaultDevice +clientName :: MIDIEv.ClientName+clientName = MIDIEv.ClientName "Haskell-Synthesizer"++ type Real = Double   {-# INLINE withMIDIEvents #-} withMIDIEvents ::    Field.C t =>-   (DN.Time t -> DN.Frequency t -> a -> IO b) ->-   (EventList.T MIDIEv.StrictTime [Event.T] -> a) -> IO b+   (DN.Time t -> DN.Frequency t ->+    (forall s. Proc.T s Dim.Time t+        (Play.StorableSignal s Dim.Voltage y yv)) ->+    IO b) ->+   (EventList.T MIDIEv.StrictTime [Event.T] ->+    forall s. Proc.T s Dim.Time t+       (Play.StorableSignal s Dim.Voltage y yv)) ->+   IO b withMIDIEvents action proc =-   MIDIEv.withMIDIEvents+   MIDIEv.withMIDIEvents clientName       (DN.toNumberWithDimension Dim.time periodTime :: Double)       (DN.toNumberWithDimension Dim.frequency sampleRate :: Double) $-   action periodTime sampleRate . proc+   \ sig -> action periodTime sampleRate (proc sig)  {-# INLINE play #-} play ::@@ -85,5 +97,5 @@       (Play.StorableSignal s Dim.Voltage y yv)) ->    IO () play period rate sig =-   Play.renderTimeVoltageStorable period rate+   Play.renderTimeVoltageStorable device period rate    (FiltR.delay latency $: sig)
src/Synthesizer/Dimensional/ALSA/Server/Instrument.hs view
@@ -25,7 +25,6 @@ import qualified Synthesizer.Dimensional.ChunkySize.Signal as SigC import qualified Synthesizer.Dimensional.Signal.Private as SigA import qualified Synthesizer.Dimensional.Process as Proc-import qualified Synthesizer.Dimensional.Wave as WaveD  import Synthesizer.Dimensional.Causal.Process ((<<<), ) import Synthesizer.Dimensional.Wave ((&*~), )@@ -37,9 +36,6 @@ import qualified Synthesizer.Frame.Stereo        as Stereo  import qualified Synthesizer.Storable.Signal      as SigSt--import qualified Algebra.Field          as Field-import qualified Algebra.Ring           as Ring  import qualified Algebra.DimensionTerm as Dim import qualified Number.DimensionTerm  as DN
src/Synthesizer/Dimensional/ALSA/Server/Run.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE Rank2Types #-} module Synthesizer.Dimensional.ALSA.Server.Run where  import Synthesizer.Dimensional.ALSA.Server.Common@@ -12,6 +11,7 @@ import qualified Synthesizer.Dimensional.Causal.Process    as Causal import qualified Synthesizer.Dimensional.Causal.Oscillator as Osci import qualified Synthesizer.Dimensional.Causal.Filter     as Filt+import qualified Synthesizer.Dimensional.Causal.FilterParameter   as FiltP import qualified Synthesizer.Dimensional.Causal.ControlledProcess as CProc  import qualified Synthesizer.Dimensional.Rate.Oscillator as OsciR@@ -19,7 +19,6 @@ import qualified Synthesizer.Dimensional.Amplitude.Displacement as DispA import qualified Synthesizer.Dimensional.Amplitude.Filter as FiltA import qualified Synthesizer.Dimensional.Signal.Private as SigA-import qualified Synthesizer.Dimensional.Process as Proc import qualified Synthesizer.Dimensional.Wave as WaveD  import Synthesizer.Dimensional.Causal.Process ((<<<), )@@ -31,8 +30,6 @@  import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg -import qualified Algebra.Ring           as Ring- import qualified Number.DimensionTerm  as DN  import NumericPrelude.Numeric@@ -168,7 +165,7 @@    \evs ->         liftA3            (\osci filt (music,speed,depth) ->-              (Filt.lowpassFromUniversal <<<+              (FiltP.lowpassFromUniversal <<<                filt (CtrlA.constant 10)                  (DispA.mapExponential 4 (DN.frequency 1000) $                   FiltA.envelope (SigA.restore depth) $@@ -176,7 +173,7 @@               `Causal.apply`               FiltA.amplify 0.2 music)            (OsciR.freqMod (WaveD.flat Wave.sine) zero)-           (CProc.runSynchronous2 Filt.universal)+           (CProc.runSynchronous2 FiltP.universal) --           FiltR.universal            (MIDI.runFilter evs               (liftA3 (,,)
src/Synthesizer/Dimensional/ALSA/Server/Test.hs view
@@ -19,8 +19,6 @@  import qualified Data.EventList.Relative.TimeBody  as EventList -import qualified Algebra.Ring           as Ring- import qualified Algebra.DimensionTerm as Dim import qualified Number.DimensionTerm  as DN
src/Synthesizer/Dimensional/MIDIValue.hs view
@@ -3,16 +3,21 @@ Functions for converting MIDI controller and key values to something meaningful for signal processing. -}-module Synthesizer.Dimensional.MIDIValue where+module Synthesizer.Dimensional.MIDIValue (+   controllerLinear,+   controllerExponential,+   pitchBend,+   MV.frequencyFromPitch,+   ) where -import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+import qualified Synthesizer.Dimensional.MIDIValuePlain as MV  import qualified Algebra.DimensionTerm as Dim import qualified Number.DimensionTerm as DN  import qualified Algebra.Transcendental as Trans import qualified Algebra.Field          as Field-import qualified Algebra.Additive       as Additive+-- import qualified Algebra.Additive       as Additive  import NumericPrelude.Numeric -- import NumericPrelude.Base@@ -22,35 +27,19 @@ controllerLinear ::    (Field.C y, Dim.C v) =>    DN.T v y -> (DN.T v y, DN.T v y) -> Int -> y-controllerLinear amp (lower,upper) n =-   let k = fromIntegral n / 127-   in  DN.divToScalar (DN.scale (1-k) lower + DN.scale k upper) amp+controllerLinear amp bnd n =+   DN.divToScalar (MV.controllerLinear bnd n) amp  {-# INLINE controllerExponential #-} controllerExponential ::    (Trans.C y, Dim.C v) =>    DN.T v y -> (DN.T v y, DN.T v y) -> Int -> y-controllerExponential amp (lower,upper) n =-   let k = fromIntegral n / 127-   in  DN.divToScalar lower amp ** (1-k) *-       DN.divToScalar upper amp ** k+controllerExponential amp bnd n =+   DN.divToScalar (MV.controllerExponential bnd n) amp  {-# INLINE pitchBend #-} pitchBend ::    (Trans.C y, Dim.C v) =>    DN.T v y -> y -> DN.T v y -> Int -> y pitchBend amp range center n =-   DN.divToScalar center amp * range ** (fromIntegral n / 8192)--{- |-Convert pitch to frequency according to the default tuning-in MIDI 1.0 Detailed Specification.--}-{-# INLINE frequencyFromPitch #-}-frequencyFromPitch ::-   (Trans.C y) =>-   VoiceMsg.Pitch -> DN.Frequency y-frequencyFromPitch pitch =-   DN.scale-      (2 ^? (fromIntegral (VoiceMsg.fromPitch pitch + 3 - 6*12) / 12))-      (DN.frequency 440)+   DN.divToScalar (MV.pitchBend range center n) amp
+ src/Synthesizer/Dimensional/MIDIValuePlain.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Functions for converting MIDI controller and key values+to something meaningful for signal processing.+-}+module Synthesizer.Dimensional.MIDIValuePlain (+   controllerLinear,+   controllerExponential,+   pitchBend,+   frequencyFromPitch,+   ) where++import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg++import qualified Algebra.DimensionTerm as Dim+import qualified Number.DimensionTerm as DN++import qualified Algebra.Transcendental as Trans+import qualified Algebra.Field          as Field+-- import qualified Algebra.Additive       as Additive++import NumericPrelude.Numeric+import NumericPrelude.Base+++{-# INLINE controllerLinear #-}+controllerLinear ::+   (Field.C y, Dim.C v) =>+   (DN.T v y, DN.T v y) -> Int -> DN.T v y+controllerLinear (lower,upper) n =+   let k = fromIntegral n / 127+   in  DN.scale (1-k) lower + DN.scale k upper++{-# INLINE controllerExponential #-}+controllerExponential ::+   (Trans.C y, Dim.C v) =>+   (DN.T v y, DN.T v y) -> Int -> DN.T v y+controllerExponential (lower,upper) n =+   let k = fromIntegral n / 127+   in  case error "MIDIValue.controllerExponential dimension" of+          d ->+             DN.fromNumberWithDimension d $+             DN.toNumberWithDimension d lower ** (1-k) *+             DN.toNumberWithDimension d upper ** k++{-# INLINE pitchBend #-}+pitchBend ::+   (Trans.C y, Dim.C v) =>+   y -> DN.T v y -> Int -> DN.T v y+pitchBend range center n =+   DN.scale (range ** (fromIntegral n / 8192)) center++{- |+Convert pitch to frequency according to the default tuning+in MIDI 1.0 Detailed Specification.+-}+{-# INLINE frequencyFromPitch #-}+frequencyFromPitch ::+   (Trans.C y) =>+   VoiceMsg.Pitch -> DN.Frequency y+frequencyFromPitch pitch =+   DN.scale+      (2 ^? (fromIntegral (VoiceMsg.fromPitch pitch + 3 - 6*12) / 12))+      (DN.frequency 440)
src/Synthesizer/EventList/ALSA/MIDI.hs view
@@ -4,6 +4,7 @@ import qualified Sound.ALSA.Sequencer.Address as Addr import qualified Sound.ALSA.Sequencer.Client as Client import qualified Sound.ALSA.Sequencer.Port as Port+import qualified Sound.ALSA.Sequencer.Port.Info as PortInfo import qualified Sound.ALSA.Sequencer.Event as Event import qualified Sound.ALSA.Sequencer.Queue as Queue import qualified Sound.ALSA.Sequencer.RealTime as RealTime@@ -11,10 +12,10 @@ import qualified Sound.ALSA.Exception as AlsaExc  import qualified Data.EventList.Relative.TimeBody  as EventList--- import qualified Data.EventList.Relative.TimeTime  as EventListTT+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.TimeMixed as EventListTM -- import qualified Data.EventList.Relative.MixedTime as EventListMT -- import qualified Data.EventList.Relative.BodyTime  as EventListBT import qualified Data.EventList.Relative.BodyBody  as EventListBB@@ -22,9 +23,9 @@  import qualified Sound.MIDI.Message.Channel as ChannelMsg import qualified Sound.MIDI.Message.Channel.Mode as Mode+import qualified Sound.MIDI.ALSA.Check as Check import qualified Sound.MIDI.ALSA as MALSA -import qualified Data.Accessor.Basic as Acc import Data.Accessor.Basic ((^.), )  import System.IO.Unsafe (unsafeInterleaveIO, )@@ -40,7 +41,6 @@ import qualified Numeric.NonNegative.Chunky as NonNegChunky -- import Data.Monoid (Monoid, mconcat, mappend, ) -import qualified Algebra.ToRational as ToRational import qualified Algebra.RealField  as RealField import qualified Algebra.Field      as Field -- import qualified Algebra.Additive as Additive@@ -49,16 +49,15 @@  import qualified Data.List.HT as ListHT import Data.Tuple.HT (mapPair, mapFst, mapSnd, )+import Data.Ord.HT (limit, ) import Data.Maybe.HT (toMaybe, ) import Data.Maybe (catMaybes, isNothing, ) import Control.Monad.HT ((<=<), )-import Control.Monad (liftM, liftM2, guard, )--import qualified Data.List as List+import Control.Monad (liftM, liftM2, guard, mzero, )  import NumericPrelude.Numeric import NumericPrelude.Base-import qualified Prelude as P+-- import qualified Prelude as P  -- import Debug.Trace (trace, ) @@ -114,29 +113,40 @@              (const $ return [])    in  loop +{- |+RealTime.toFractional for NumericPrelude.+-}+realTimeToField :: (Field.C a) => RealTime.T -> a+realTimeToField (RealTime.Cons s n) =+   fromIntegral s + fromIntegral n / (10^9)++addStamp ::+   (RealField.C time) =>+   Event.T -> StampedEvent time+addStamp ev =+   (case Event.timestamp ev of+      Event.RealTime t -> realTimeToField t+      _ -> error "unsupported time stamp type",+    ev)+ {- | only use it for blocking sequencers -}-getEventsUntilEcho_ ::-   (Field.C time, SndSeq.AllowInput mode) =>-   SndSeq.T mode -> IO [StampedEvent time]-getEventsUntilEcho_ h =-   let loop = do-          ev <- Event.input h-          let t =-                 case Event.timestamp ev of-                    Event.RealTime rt ->---                       realToFrac $-                       fromRational' $ toRational $-                       RealTime.toDouble rt-                    _ -> error "unsupported time stamp type"-          case Event.body ev of-             Event.CustomEv Event.Echo _ -> return []-             _ -> liftM ((t,ev):) loop-   in  loop+getStampedEventsUntilTime ::+   (RealField.C time,+    SndSeq.AllowInput mode, SndSeq.AllowOutput mode) =>+   SndSeq.T mode ->+   Queue.T -> Port.T -> time ->+   IO [StampedEvent time]+getStampedEventsUntilTime h q p t =+   fmap (map addStamp) $ getEventsUntilTime h q p t ++{- |+The client id may differ from the receiving sequencer.+I do not know, whether there are circumstances, where this is useful.+-} getEventsUntilEcho ::    (SndSeq.AllowInput mode) =>-   Client.T ->-   SndSeq.T mode -> IO [Event.T]+   Client.T -> SndSeq.T mode -> IO [Event.T] getEventsUntilEcho c h =    let loop = do           ev <- Event.input h@@ -150,7 +160,24 @@             else liftM (ev:) loop    in  loop +{- |+Get events until a certain point in time.+It sends itself an Echo event in order to measure time.+-}+getEventsUntilTime ::+   (RealField.C time,+    SndSeq.AllowInput mode, SndSeq.AllowOutput mode) =>+   SndSeq.T mode ->+   Queue.T -> Port.T -> time ->+   IO [Event.T]+getEventsUntilTime h q p t = do+   c <- Client.getId h+   _ <- Event.output h $+           makeEcho c q p t (Event.Custom 0 0 0)+   _ <- Event.drainOutput h+   getEventsUntilEcho c h + getWaitingEvents ::    (SndSeq.AllowInput mode) =>    SndSeq.T mode -> IO [Event.T]@@ -164,18 +191,8 @@   type StrictTime = NonNegW.Integer--{- |-Returns a list of non-zero times.--}-{-# INLINE chopLongTime #-}-chopLongTime :: StrictTime -> [StrictTime]-chopLongTime n =-   let d = NonNegW.fromNumber $ fromIntegral (maxBound :: Int)-       (q,r) = P.divMod n d-   in  List.genericReplicate q d ++-       if r /= NonNeg.zero then [r] else []-+newtype ClientName = ClientName String+   deriving (Show)  {- ghc -i:src -e 'withMIDIEvents 44100 print' src/Synthesizer/Storable/ALSA/MIDI.hs@@ -187,7 +204,7 @@ then play and event fetching get out of sync over the time. -} withMIDIEvents :: (RealField.C time) =>-   time -> time ->+   ClientName -> time -> time ->    (EventList.T StrictTime [Event.T] -> IO a) -> IO a withMIDIEvents =    withMIDIEventsBlockEcho@@ -197,10 +214,10 @@ as a quick hack, we neglect the ALSA time stamp and use getTime or so -} withMIDIEventsNonblockWaitGrouped :: (RealField.C time) =>-   time -> time ->+   ClientName -> time -> time ->    (EventList.T StrictTime [Event.T] -> IO a) -> IO a-withMIDIEventsNonblockWaitGrouped beat rate proc =-   withInPort SndSeq.Nonblock $ \ h _p ->+withMIDIEventsNonblockWaitGrouped name beat rate proc =+   withInPort name SndSeq.Nonblock $ \ h _p ->    do start <- getTimeSeconds       l <- lazySequence $               flip map (iterate (beat+) start) $ \t ->@@ -223,10 +240,10 @@ but ones xruns occur, this implies more and more xruns. -} withMIDIEventsNonblockWaitDefer :: (RealField.C time) =>-   time -> time ->+   ClientName -> time -> time ->    (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a-withMIDIEventsNonblockWaitDefer beat rate proc =-   withInPort SndSeq.Nonblock $ \ h _p ->+withMIDIEventsNonblockWaitDefer name beat rate proc =+   withInPort name SndSeq.Nonblock $ \ h _p ->    do start <- getTimeSeconds       l <- lazySequence $               flip map (iterate (beat+) start) $ \t ->@@ -249,10 +266,10 @@ (Or debug output slows down processing.) -} withMIDIEventsNonblockWaitSkip :: (RealField.C time) =>-   time -> time ->+   ClientName -> time -> time ->    (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a-withMIDIEventsNonblockWaitSkip beat rate proc =-   withInPort SndSeq.Nonblock $ \ h _p ->+withMIDIEventsNonblockWaitSkip name beat rate proc =+   withInPort name SndSeq.Nonblock $ \ h _p ->    do start <- getTimeSeconds       l <- lazySequence $            flip map (iterate (beat+) start) $ \t ->@@ -271,10 +288,10 @@          AbsEventList.fromPairList $ concat l  withMIDIEventsNonblockWaitMin :: (RealField.C time) =>-   time -> time ->+   ClientName -> time -> time ->    (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a-withMIDIEventsNonblockWaitMin beat rate proc =-   withInPort SndSeq.Nonblock $ \ h _p ->+withMIDIEventsNonblockWaitMin name beat rate proc =+   withInPort name SndSeq.Nonblock $ \ h _p ->    do start <- getTimeSeconds       l <- lazySequence $               flip map (iterate (beat+) start) $ \t ->@@ -295,10 +312,10 @@          AbsEventList.fromPairList $ concat l  withMIDIEventsNonblockConstantPause :: (RealField.C time) =>-   time -> time ->+   ClientName -> time -> time ->    (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a-withMIDIEventsNonblockConstantPause beat rate proc =-   withInPort SndSeq.Nonblock $ \ h _p ->+withMIDIEventsNonblockConstantPause name beat rate proc =+   withInPort name SndSeq.Nonblock $ \ h _p ->    do l <- ioToLazyList $ threadDelay (round $ flip asTypeOf rate $ beat*1e6) >>               liftM2 (:)                  (liftM (\t->(t,Nothing)) getTimeSeconds)@@ -308,10 +325,10 @@          AbsEventList.fromPairList $ concat l  withMIDIEventsNonblockSimple :: (RealField.C time) =>-   time -> time ->+   ClientName -> time -> time ->    (EventList.T StrictTime Event.T -> IO a) -> IO a-withMIDIEventsNonblockSimple beat rate proc =-   withInPort SndSeq.Nonblock $ \ h _p ->+withMIDIEventsNonblockSimple name beat rate proc =+   withInPort name SndSeq.Nonblock $ \ h _p ->    do l <- ioToLazyList $               threadDelay (round $ flip asTypeOf rate $ beat*1e6) >>               getWaitingStampedEvents h@@ -319,38 +336,126 @@          discretizeTime rate $          AbsEventList.fromPairList $ concat l ++setTimestamping ::+   SndSeq.T mode -> Port.T -> Queue.T -> IO ()+setTimestamping h p q = do+   info <- PortInfo.get h p+   PortInfo.setTimestamping info True+   PortInfo.setTimestampReal info True+   PortInfo.setTimestampQueue info q+   PortInfo.set h p info+ withMIDIEventsBlockEcho :: (RealField.C time) =>-   time -> time ->+   ClientName -> time -> time ->    (EventList.T StrictTime [Event.T] -> IO a) -> IO a-withMIDIEventsBlockEcho beat rate proc =-   withInPort SndSeq.Block $ \ h p ->+withMIDIEventsBlockEcho name beat rate proc =+   withInPort name SndSeq.Block $ \ h p ->    Queue.with h $ \ q ->-   do {--      info <- PortInfo.get h p-      PortInfo.setTimestamping info True-      PortInfo.setTimestampReal info True-      PortInfo.setTimestampQueue info q-      PortInfo.set h p info-      -}-+   do setTimestamping h p q       Queue.control h q Event.QueueStart 0 Nothing-      Event.drainOutput h+      _ <- Event.drainOutput h -      c <- Client.getId h-      l <--         lazySequence $-         flip map (iterate (beat+) 0) $ \t -> do-            Event.output h $-               makeEcho c q p (t+beat) (Event.Custom 0 0 0)-            Event.drainOutput h+      proc .+         discretizeTime rate .+         AbsEventList.fromPairList .+         concat =<<+         (lazySequence $+          flip map (iterate (beat+) 0) $ \t ->+             let end = t+beat+             in  -- (\act -> do evs <- act; print evs; return evs) $+                 -- add a laziness break+                 fmap ((t,[]) :) $+                 fmap (map (mapPair (limit (t,end), (:[])))) $+                 getStampedEventsUntilTime h q p end)++{- |+This is like withMIDIEventsBlockEcho+but collects all events at the beginning of the beats.+This way, further processing steps may collapse+all controller events within one beat to one event.+-}+withMIDIEventsBlockEchoQuantised :: (RealField.C time) =>+   ClientName -> time -> time ->+   (EventList.T StrictTime [Event.T] -> IO a) -> IO a+withMIDIEventsBlockEchoQuantised name beat rate proc =+   withInPort name SndSeq.Block $ \ h p ->+   Queue.with h $ \ q ->+   do Queue.control h q Event.QueueStart 0 Nothing+      _ <- Event.drainOutput h++      proc .+         discretizeTime rate .+         AbsEventList.fromPairList =<<+         (lazySequence $+          flip map (iterate (beat+) 0) $ \t ->             liftM                (\evs -> (t, evs))-               (getEventsUntilEcho c h)+               (getEventsUntilTime h q p (t+beat))) +{- |+Make sure, that @beat@ is an integer multiple of @recip rate@.+Since we round time within each chunk,+we would otherwise accumulate rounding errors over time.+-}+withMIDIEventsChunked ::+   (RealField.C time) =>+   ClientName -> time -> time ->+   ([IO (EventListTT.T StrictTime [Event.T])] -> IO a) ->+   IO a+withMIDIEventsChunked name beat rate proc =+   withInPort name SndSeq.Block $ \ h p ->+   Queue.with h $ \ q ->+   do setTimestamping h p q+      Queue.control h q Event.QueueStart 0 Nothing+      _ <- Event.drainOutput h+       proc $-         discretizeTime rate $-         AbsEventList.fromPairList l+         map+            (\t ->+               let end = t+beat+               in  liftM+                      (\evs ->+                         EventListTM.switchBodyR+                            (error "withMIDIEventsChunked: empty list, but there must be at least the end event")+                            const $+                         discretizeTime rate $+                         AbsEventList.fromPairList $+                         (t,[]) :+                         {-+                         FIXME: This is a quick hack in order to assert+                         that all events are within one chunk+                         and do not lie on the boundary.+                         -}+                         map (mapPair (limit (t , end - recip rate), (:[]))) evs +++                         (end, []) :+                         [])+                      (getStampedEventsUntilTime h q p end))+            (iterate (beat+) 0) +withMIDIEventsChunkedQuantised ::+   (RealField.C time) =>+   ClientName -> time -> time ->+   ([IO (EventList.T StrictTime [Event.T])] -> IO a) ->+   IO a+withMIDIEventsChunkedQuantised name beat rate proc =+   withInPort name SndSeq.Block $ \ h p ->+   Queue.with h $ \ q ->+   do Queue.control h q Event.QueueStart 0 Nothing+      _ <- Event.drainOutput h++      proc $+         map+            (\t ->+               liftM+                  (\evs ->+                     EventList.cons NonNeg.zero evs $+                     EventList.singleton+                        (NonNegW.fromNumberMsg "chunked time conversion" $+                         round (beat*rate)) [])+                  (getEventsUntilTime h q p (t+beat)))+            (iterate (beat+) 0)+ makeEcho ::    RealField.C time =>    Client.T -> Queue.T -> Port.T ->@@ -375,21 +480,23 @@       }  withMIDIEventsBlock :: (RealField.C time) =>-   time ->+   ClientName -> time ->    (EventList.T StrictTime Event.T -> IO a) -> IO a-withMIDIEventsBlock rate proc =-   withInPort SndSeq.Block $ \ h _p ->+withMIDIEventsBlock name rate proc =+   withInPort name SndSeq.Block $ \ h _p ->    do l <- ioToLazyList $ getStampedEvent h       proc $          discretizeTime rate $          AbsEventList.fromPairList l  withInPort ::-   SndSeq.BlockMode -> (SndSeq.T SndSeq.DuplexMode -> Port.T -> IO t) -> IO t-withInPort blockMode act =+   ClientName ->+   SndSeq.BlockMode ->+   (SndSeq.T SndSeq.DuplexMode -> Port.T -> IO t) -> IO t+withInPort (ClientName name) blockMode act =    SndSeq.with SndSeq.defaultName blockMode $ \h ->-   Client.setName h "Haskell-Synthesizer" >>-   Port.withSimple h "listener"+   Client.setName h name >>+   Port.withSimple h "input"       (Port.caps [Port.capWrite, Port.capSubsWrite])       Port.typeMidiGeneric       (act h)@@ -449,27 +556,11 @@ type Program    = ChannelMsg.Program  -maybeAnyController ::-   Channel -> Event.T -> Maybe (Controller, Int)-maybeAnyController chan e = do-   -- let Event.TickTime n = Event.timestamp e-   Event.CtrlEv Event.Controller c <- Just $ Event.body e-   guard (c ^. MALSA.ctrlChannel  ==  chan)-   MALSA.Controller cn cv <- Just $ c ^. MALSA.ctrlControllerMode-   return (cn, cv)--maybeController :: Channel -> Controller -> Event.T -> Maybe Int-maybeController chan ctrl e = do-   (c,n) <- maybeAnyController chan e-   guard (ctrl==c)-   return n-- getControllerEvents ::    Channel -> Controller ->    Filter (EventList.T StrictTime [Int]) getControllerEvents chan ctrl =-   getSlice (maybeController chan ctrl)+   getSlice (Check.controller chan ctrl)  {- getControllerEvents ::@@ -477,28 +568,9 @@    Filter (EventList.T StrictTime (Maybe Int)) getControllerEvents chan ctrl =    fmap (fmap (fmap snd . ListHT.viewR)) $-   getSlice (maybeController chan ctrl)+   getSlice (Check.controller chan ctrl) -} -maybePitchBend :: Channel -> Event.T -> Maybe Int-maybePitchBend chan e =-   case Event.body e of-      Event.CtrlEv Event.PitchBend c ->-         toMaybe-            (c ^. MALSA.ctrlChannel == chan)-            (c ^. MALSA.ctrlValue)-      _ -> Nothing--maybeChannelPressure :: Channel -> Event.T -> Maybe Int-maybeChannelPressure chan e =-   case Event.body e of-      Event.CtrlEv Event.ChanPress c ->-         toMaybe-            (c ^. MALSA.ctrlChannel == chan)-            (c ^. MALSA.ctrlValue)-      _ -> Nothing-- data NoteBoundary a =      NoteBoundary Pitch Velocity a    | AllNotesOff@@ -515,33 +587,38 @@    Channel ->    Filter (EventList.T StrictTime [Either Program (NoteBoundary Bool)]) getNoteEvents chan =-   getSlice $ \e ->-      case Event.body e of-         Event.NoteEv notePart note ->-            do guard (note ^. MALSA.noteChannel == chan)-               let (part,vel) =-                      MALSA.normalNoteFromEvent notePart note-               press <--                  case part of-                     Event.NoteOn  -> Just True-                     Event.NoteOff -> Just False-                     _ -> Nothing-               return $ Right $ NoteBoundary-                  (note ^. MALSA.notePitch) vel press-         Event.CtrlEv Event.PgmChange ctrl ->-            do guard (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.CtrlEv Event.Controller ctrl ->-            do guard (ctrl ^. MALSA.ctrlControllerMode ==-                        MALSA.Mode Mode.AllNotesOff)-               return $ Right AllNotesOff-         _ -> Nothing+   getSlice $ checkNoteEvent chan +checkNoteEvent ::+   Channel -> Event.T ->+   Maybe (Either Program (NoteBoundary Bool))+checkNoteEvent chan e =+   case Event.body e of+      Event.NoteEv notePart note ->+         do guard (note ^. MALSA.noteChannel == chan)+            let (part,vel) =+                   MALSA.normalNoteFromEvent notePart note+            press <-+               case part of+                  Event.NoteOn  -> return True+                  Event.NoteOff -> return False+                  _ -> mzero+            return $ Right $ NoteBoundary+               (note ^. MALSA.notePitch) vel press+      Event.CtrlEv Event.PgmChange ctrl ->+         do guard (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.CtrlEv Event.Controller ctrl ->+         do guard (ctrl ^. MALSA.ctrlControllerMode ==+                     MALSA.Mode Mode.AllNotesOff)+            return $ Right AllNotesOff+      _ -> mzero+ embedPrograms ::    Program ->    EventList.T StrictTime [Either Program (NoteBoundary Bool)] ->@@ -549,18 +626,23 @@ embedPrograms initPgm =    fmap catMaybes .    flip evalState initPgm .-   traverse (traverse-      (-- evaluate program for every event in order to prevent a space leak-       (\n -> state (\s -> (seq s n, s)))-       <=<-       either-          (\pgm -> put pgm >> return Nothing)-          (\bnd ->-             gets (Just .-             case bnd of-                AllNotesOff -> const AllNotesOff-                NoteBoundary p v press ->-                   NoteBoundary p v . toMaybe press))))+   traverse (traverse embedProgramState)++embedProgramState ::+   Either Program (NoteBoundary Bool) ->+   State Program (Maybe (NoteBoundary (Maybe Program)))+embedProgramState =+   -- evaluate program for every event in order to prevent a space leak+   (\n -> state (\s -> (seq s n, s)))+   <=<+   either+      (\pgm -> put pgm >> return Nothing)+      (\bnd ->+         gets (Just .+         case bnd of+            AllNotesOff -> const AllNotesOff+            NoteBoundary p v press ->+               NoteBoundary p v . toMaybe press))   matchNoteEvents ::
src/Synthesizer/Generic/ALSA/MIDI.hs view
@@ -8,11 +8,11 @@ import Synthesizer.EventList.ALSA.MIDI    (LazyTime, StrictTime, Filter, Channel,     Program, embedPrograms, makeInstrumentArray, getInstrumentFromArray,-    Note(Note), matchNoteEvents, getNoteEvents,-    chopLongTime, )+    Note(Note), matchNoteEvents, getNoteEvents, )  import qualified Sound.MIDI.Message.Channel as ChannelMsg +import qualified Synthesizer.PiecewiseConstant.Signal as PC import qualified Synthesizer.Generic.Cut        as CutG import qualified Synthesizer.Generic.Signal     as SigG @@ -61,8 +61,8 @@       SigG.replicate --         (SigG.LazySize $ fromIntegral $ maxBound::Int)          SigG.defaultLazySize-         (fromInteger $ NonNegW.toNumber t) y) $-   chopLongTime tl+         (NonNegW.toNumber t) y) $+   PC.chopLongTime tl  {- ToDo: move to Generic.Signal@@ -200,8 +200,8 @@           EventListBT.toPairList xs    in  (evaluateVectorHead ys t, ys) -type Arranger signal =-   EventList.T NonNegW.Int signal -> signal+type FilterSequence signal =+   Filter (EventList.T PC.ShortStrictTime signal)  {- | The state action for the time@@ -251,14 +251,12 @@ {-# INLINE sequenceCore #-} sequenceCore ::    (Monoid signal) =>-   Arranger signal ->    Channel ->    Program ->    Modulator Note signal ->-   Filter signal-sequenceCore arranger chan initPgm md =-   fmap (arranger .-         EventList.mapTime fromIntegral .+   FilterSequence signal+sequenceCore chan initPgm md =+   fmap (EventList.mapTime fromIntegral .          flatten .          applyModulator md .          matchNoteEvents .@@ -279,12 +277,11 @@ {-# INLINE sequence #-} sequence ::    (Monoid signal, Trans.C y) =>-   Arranger signal ->    Channel ->    Instrument y signal ->-   Filter signal-sequence arranger chan instr =-   sequenceCore arranger chan errorNoProgram+   FilterSequence signal+sequence chan instr =+   sequenceCore chan errorNoProgram       (Modulator () return           (return . renderInstrumentIgnoreProgram instr)) @@ -293,13 +290,12 @@ sequenceModulated ::    (CutG.Transform ctrl, CutG.NormalForm ctrl,     Monoid signal, Trans.C y) =>-   Arranger signal ->    ctrl ->    Channel ->    (ctrl -> Instrument y signal) ->-   Filter signal-sequenceModulated arranger ctrl chan instr =-   sequenceCore arranger chan errorNoProgram+   FilterSequence signal+sequenceModulated ctrl chan instr =+   sequenceCore chan errorNoProgram       (Modulator ctrl advanceModulationChunk           (\note -> gets $ \c -> renderInstrumentIgnoreProgram (instr c) note)) @@ -307,14 +303,13 @@ {-# INLINE sequenceMultiModulated #-} sequenceMultiModulated ::    (Monoid signal, Trans.C y) =>-   Arranger signal ->    Channel ->    instrument ->    Modulator (instrument, Note) (Instrument y signal, Note) ->-   Filter signal-sequenceMultiModulated arranger chan instr+   FilterSequence signal+sequenceMultiModulated chan instr       (Modulator modulatorInit modulatorTime modulatorBody) =-   sequenceCore arranger chan errorNoProgram+   sequenceCore chan errorNoProgram       (Modulator modulatorInit modulatorTime           (fmap (uncurry renderInstrumentIgnoreProgram) .            modulatorBody .@@ -323,14 +318,13 @@ {-# INLINE sequenceMultiProgram #-} sequenceMultiProgram ::    (Monoid signal, Trans.C y) =>-   Arranger signal ->    Channel ->    Program ->    [Instrument y signal] ->-   Filter signal-sequenceMultiProgram arranger chan initPgm instrs =+   FilterSequence signal+sequenceMultiProgram chan initPgm instrs =    let bank = makeInstrumentArray instrs-   in  sequenceCore arranger chan initPgm+   in  sequenceCore chan initPgm           (Modulator () return               (return . renderInstrument                  (getInstrumentFromArray bank initPgm)))@@ -339,15 +333,14 @@ sequenceModulatedMultiProgram ::    (CutG.Transform ctrl, CutG.NormalForm ctrl,     Monoid signal, Trans.C y) =>-   Arranger signal ->    ctrl ->    Channel ->    Program ->    [ctrl -> Instrument y signal] ->-   Filter signal-sequenceModulatedMultiProgram arranger ctrl chan initPgm instrs =+   FilterSequence signal+sequenceModulatedMultiProgram ctrl chan initPgm instrs =    let bank = makeInstrumentArray instrs-   in  sequenceCore arranger chan initPgm+   in  sequenceCore chan initPgm           (Modulator               ctrl advanceModulationChunk               (\note -> gets $ \c -> renderInstrument
src/Synthesizer/MIDIValue.hs view
@@ -9,7 +9,6 @@  import qualified Algebra.Transcendental as Trans import qualified Algebra.Field          as Field-import qualified Algebra.Additive       as Additive  import NumericPrelude.Numeric -- import NumericPrelude.Base
+ src/Synthesizer/MIDIValue/BendModulation.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE NoImplicitPrelude #-}+{- |+Combine pitchbend and modulation in one data type.+-}+module Synthesizer.MIDIValue.BendModulation where++import qualified Synthesizer.MIDIValue.BendWheelPressure as BWP+import qualified Synthesizer.MIDIValue as MV++import qualified Algebra.Transcendental as Trans+import qualified Algebra.RealRing       as RealRing+import qualified Algebra.Ring           as Ring++import Foreign.Storable (Storable(sizeOf, alignment, peek, poke), )+import qualified Foreign.Storable.Traversable as Store++import qualified Data.Foldable as Fold+import qualified Data.Traversable as Trav++import Control.Applicative (Applicative, (<*>), pure, liftA2, )++import Control.DeepSeq (NFData, rnf, )++import NumericPrelude.Numeric+import NumericPrelude.Base+++{- |+'bend' is a frequency factor+and 'depth' is a modulation depth to be interpreted by the instrument.+-}+data T a = Cons {bend, depth :: a}+   deriving (Show, Eq)++deflt :: (Ring.C a) => T a+deflt = Cons one zero+++instance (NFData a) => NFData (T a) where+   rnf bm =+      case rnf (bend bm) of () -> rnf (depth bm)+++instance Functor T where+   {-# INLINE fmap #-}+   fmap f (Cons b m) = Cons (f b) (f m)++-- useful for defining 'peek' instance+instance Applicative T where+   {-# INLINE pure #-}+   pure a = Cons a a+   {-# INLINE (<*>) #-}+   (Cons fb fm) <*> (Cons b m) =+      Cons (fb b) (fm m)++instance Fold.Foldable T where+   {-# INLINE foldMap #-}+   foldMap = Trav.foldMapDefault++-- this allows for kinds of generic programming+instance Trav.Traversable T where+   {-# INLINE sequenceA #-}+   sequenceA (Cons b m) =+      liftA2 Cons b m+++force :: T a -> T a+force ~(Cons a b) = (Cons a b)++instance (Storable a) => Storable (T a) where+   {-# INLINE sizeOf #-}+   sizeOf = Store.sizeOf . force+   {-# INLINE alignment #-}+   alignment = Store.alignment . force+   {-# INLINE peek #-}+   peek = Store.peekApplicative+   {-# INLINE poke #-}+   poke = Store.poke++++{- |+Multiply the pitch bend by a given factor.+This way you can e.g. shift the pitch bend from around 1+to the actual frequency.+-}+shift ::+   (Ring.C a) =>+   a -> T a -> T a+shift k (Cons b d) = Cons (k*b) d++fromBendWheelPressure ::+   (RealRing.C a, Trans.C a) =>+   Int -> a -> a ->+   BWP.T -> T a+fromBendWheelPressure+      pitchRange wheelDepth pressDepth bwp =+   Cons+      (MV.pitchBend (2^?(fromIntegral pitchRange/12)) 1 (BWP.bend_ bwp))+      (MV.controllerLinear (0,wheelDepth) (BWP.wheel_ bwp) ++       MV.controllerLinear (0,pressDepth) (BWP.pressure_ bwp))
+ src/Synthesizer/MIDIValue/BendWheelPressure.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Synthesizer.MIDIValue.BendWheelPressure where++import qualified Data.Accessor.Basic as Accessor++import Control.DeepSeq (NFData, rnf, )++import NumericPrelude.Numeric+import NumericPrelude.Base+++data T = Cons {bend_, wheel_, pressure_ :: Int}+   deriving (Show, Eq)++deflt :: T+deflt = Cons 0 0 0+++bend, wheel, pressure :: Accessor.T T Int+bend =+   Accessor.fromSetGet+      (\b (Cons _ w p) -> Cons b w p)+      bend_++wheel =+   Accessor.fromSetGet+      (\w (Cons b _ p) -> Cons b w p)+      wheel_++pressure =+   Accessor.fromSetGet+      (\p (Cons b w _) -> Cons b w p)+      pressure_+++instance NFData T where+   rnf (Cons b w p) =+      case (rnf b, rnf w, rnf p) of+         ((), (), ()) -> ()
src/Synthesizer/PiecewiseConstant/ALSA/MIDI.hs view
@@ -4,60 +4,59 @@ {-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.PiecewiseConstant.ALSA.MIDI (    T,-   subdivide,-   subdivideInt,    duration,-   zipWith,+   PC.zipWith,     initWith,    controllerLinear,    controllerExponential,    pitchBend,    channelPressure,-   BendModulation(BendModulation),-   shiftBendModulation,    bendWheelPressure,+   checkBendWheelPressure,+   bendWheelPressureZip,    ) where  import qualified Synthesizer.EventList.ALSA.MIDI as Ev import Synthesizer.EventList.ALSA.MIDI (LazyTime, StrictTime, Filter, Channel, ) -import qualified Synthesizer.MIDIValue as MV+import qualified Sound.MIDI.ALSA.Check as Check import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+import qualified Sound.ALSA.Sequencer.Event as Event+import qualified Synthesizer.MIDIValue.BendModulation as BM+import qualified Synthesizer.MIDIValue.BendWheelPressure as BWP+import qualified Synthesizer.MIDIValue as MV -import qualified Data.EventList.Relative.TimeTime  as EventListTT+import qualified Synthesizer.PiecewiseConstant.Signal as PC++-- import qualified Data.EventList.Relative.TimeTime  as EventListTT 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.Relative.TimeBody  as EventList  import qualified Numeric.NonNegative.Class   as NonNeg-import qualified Numeric.NonNegative.Wrapper as NonNegW+-- import qualified Numeric.NonNegative.Wrapper as NonNegW import qualified Numeric.NonNegative.Chunky as NonNegChunky-import Numeric.NonNegative.Class ((-|), )  import qualified Algebra.Transcendental as Trans-import qualified Algebra.RealRing      as RealRing+import qualified Algebra.RealRing       as RealRing import qualified Algebra.Field          as Field-import qualified Algebra.Ring           as Ring-import qualified Algebra.Additive       as Additive -import Control.Monad.Trans.State (evalState, get, put, )-import Control.Monad (liftM, liftM2, )-import Data.Traversable (traverse, )+import qualified Data.Accessor.Monad.Trans.State as AccState+import Control.Monad.Trans.State (State, evalState, state, get, put, )+import Control.Monad (liftM, liftM2, msum, )+import Data.Traversable (traverse, sequence, ) import Data.Foldable (traverse_, )-import Control.DeepSeq (NFData, rnf, ) -import Data.Maybe.HT (toMaybe, )+import qualified Data.List.HT as ListHT import qualified Data.List as List-import Data.Maybe (Maybe(Just, Nothing), maybe, )-import Data.Ord (Ordering(LT,GT,EQ), min, compare, )-import Data.Bool (Bool(False,True), (||), )-import Data.Function ((.), ($), flip, id, )+import Data.Either (Either(Left, Right), )+import Data.Maybe (maybe, )+import Data.Function ((.), ($), flip, )  import NumericPrelude.Numeric-import Prelude as P-   (Eq, Show, uncurry, fmap, return, (>>), )+import Prelude as P (Maybe, fmap, (>>), )   type T = EventListBT.T StrictTime@@ -67,41 +66,7 @@ duration =    NonNegChunky.fromChunks . EventListBT.getTimes -{--ToDo: move to PiecewiseConstant.Signal or so.--}-{-# INLINE subdivide #-}-subdivide ::-   EventListBT.T LazyTime y -> EventListBT.T StrictTime y-subdivide =-   EventListBT.foldrPair-      (\y lt r ->-         List.foldr-            (\dt ->-               EventListMT.consBody y .-               EventListMT.consTime dt) r $-         NonNegChunky.toChunks (NonNegChunky.normalize lt))-      EventListBT.empty -{- |-Subdivide lazy times into chunks that fit into the number range-representable by @Int@.--}-{-# INLINE subdivideInt #-}-subdivideInt ::-   EventListBT.T LazyTime y -> EventListBT.T NonNegW.Int y-subdivideInt =-   EventListBT.mapTime-      (NonNegW.fromNumber .-       fromIntegral .-       NonNegW.toNumber) .-   subdivide .-   EventListBT.mapTime-      (NonNegChunky.fromChunks .-       List.concatMap Ev.chopLongTime .-       NonNegChunky.toChunks)-- {-# INLINE initWith #-} initWith ::    (y -> c) ->@@ -153,7 +118,7 @@    Filter (T y) pitchBend chan range center =    liftM (initWith (MV.pitchBend range center) center) $-   Ev.getSlice (Ev.maybePitchBend chan)+   Ev.getSlice (Check.pitchBend chan) --   getPitchBendEvents chan  {-# INLINE channelPressure #-}@@ -164,153 +129,60 @@    Filter (T y) channelPressure chan maxVal initVal =    liftM (initWith (MV.controllerLinear (0,maxVal)) initVal) $-   Ev.getSlice (Ev.maybeChannelPressure chan)+   Ev.getSlice (Check.channelPressure chan)  -data BendModulation a = BendModulation a a-   deriving (P.Show, P.Eq)--instance (NFData a) => NFData (BendModulation a) where-   rnf (BendModulation bend depth) =-      case rnf bend of () -> rnf depth+{-# INLINE bendWheelPressure #-}+bendWheelPressure ::+   (RealRing.C y, Trans.C y) =>+   Channel ->+   Int -> y -> y ->+   Filter (T (BM.T y))+bendWheelPressure chan+      pitchRange wheelDepth pressDepth =+   let toBM = BM.fromBendWheelPressure pitchRange wheelDepth pressDepth+   in  liftM (initWith toBM (toBM BWP.deflt)) $+       state $+       EventList.unzip .+       fmap ListHT.unzipEithers .+       flip evalState BWP.deflt .+       traverse (traverse (separateBWP chan)) +separateBWP :: Channel -> Event.T -> State BWP.T (Either BWP.T Event.T)+separateBWP chan ev =+   fmap (maybe (Right ev) Left) $+   checkBendWheelPressure chan ev  {- |-Multiply the pitch bend by a given factor.-This way you can e.g. shift the pitch bend from around 1-to the actual frequency.+I hesitate to move this to MIDIValue or BendWheelPressure module+because it depends on ALSA specific Event. -}-shiftBendModulation ::-   (Ring.C a) =>-   a -> BendModulation a -> BendModulation a-shiftBendModulation k (BendModulation bend depth) =-   BendModulation (k*bend) depth---_subdivideMaybe ::-   EventListBT.T LazyTime y -> EventListBT.T StrictTime (Maybe y)-_subdivideMaybe =-   EventListBT.foldrPair-      (\y lt r ->-         case NonNegChunky.toChunks (NonNegChunky.normalize lt) of-            [] -> r-            (t:ts) ->-               EventListBT.cons (Just y) t $-               List.foldr (EventListBT.cons Nothing) r ts)-      EventListBT.empty+checkBendWheelPressure ::+   Channel -> Event.T -> State BWP.T (Maybe BWP.T)+checkBendWheelPressure chan ev =+   sequence $+   (fmap (>> get)) $+   msum $ List.map ($ev) $+      (fmap (AccState.set BWP.bend) . Check.pitchBend chan) :+      (fmap (AccState.set BWP.wheel) . Check.controller chan VoiceMsg.modulation) :+      (fmap (AccState.set BWP.pressure) . Check.channelPressure chan) :+      []  {- |-When a lazy time value is split into chunks-then do not just replicate the sample for the whole time,-but insert 'Nothing's.--}-{-# INLINE subdivideMaybe #-}-subdivideMaybe ::-   EventListTT.T LazyTime y ->-   EventListTT.T StrictTime (Maybe y)-subdivideMaybe =-   EventListTT.foldr-      (\lt r ->-         uncurry EventListMT.consTime $-         case NonNegChunky.toChunks (NonNegChunky.normalize lt) of-            [] ->-               (NonNegW.fromNumber zero, r)-            (t:ts) ->-               (t, List.foldr (EventListBT.cons Nothing) r ts))-      (\y r -> EventListMT.consBody (Just y) r)-      EventListBT.empty--{-# INLINE unionMaybe #-}-unionMaybe ::-   EventListTT.T StrictTime (Maybe y) ->-   EventListTT.T LazyTime y-unionMaybe =-   EventListTT.foldr-      (\t ->-         EventListMT.mapTimeHead-            (NonNegChunky.fromChunks . (t:) . NonNegChunky.toChunks))-      (\my ->-         case my of-            Nothing -> id-            Just y ->-               EventListMT.consTime NonNegChunky.zero .-               EventListMT.consBody y)-      (EventListTT.pause NonNegChunky.zero)--{--ToDo: move to PiecewiseConstant.Signal or so.--}-zipWithCore ::-   (a -> b -> c) ->-   a -> b ->-   EventListTT.T StrictTime (Maybe a) ->-   EventListTT.T StrictTime (Maybe b) ->-   EventListTT.T StrictTime (Maybe c)-zipWithCore f =-   let switch ac ar g =-          flip (EventListMT.switchBodyL EventListBT.empty) ar $ \am ar1 ->-          g (maybe (False,ac) ((,) True) am) ar1-       cont j ac bc as bs =-          EventListMT.consBody (toMaybe j $ f ac bc) $-          recourse ac bc as bs-       recourse ac bc as bs =-          flip EventListMT.switchTimeL as $ \at ar ->-          flip EventListMT.switchTimeL bs $ \bt br ->-          let ct = min at bt-          in  -- ToDo: redundant comparison of 'at' and 'bt'-              EventListMT.consTime ct $-              case compare at bt of-                 LT ->-                    switch ac ar $ \(ab,a) ar1 ->-                       cont ab a bc ar1 (EventListMT.consTime (bt-|ct) br)-                 GT ->-                    switch bc br $ \(bb,b) br1 ->-                       cont bb ac b (EventListMT.consTime (at-|ct) ar) br1-                 EQ ->-                    switch ac ar $ \(ab,a) ar1 ->-                    switch bc br $ \(bb,b) br1 ->-                       cont (ab||bb) a b ar1 br1-   in  recourse--zipWith ::-   (a -> b -> c) ->-   EventListBT.T StrictTime a ->-   EventListBT.T StrictTime b ->-   EventListBT.T StrictTime c-zipWith f as0 bs0 =-   flip (EventListMT.switchBodyL EventListBT.empty) as0 $ \a0 as1 ->-   flip (EventListMT.switchBodyL EventListBT.empty) bs0 $ \b0 bs1 ->-   let c0 = f a0 b0-   in  EventListMT.consBody c0 $-       flip evalState c0 $-       traverse (\mc -> maybe (return ()) put mc >> get) $-       zipWithCore f a0 b0 (fmap Just as1) (fmap Just bs1)--_zipWithLazy ::-   (a -> b -> c) ->-   EventListBT.T LazyTime a ->-   EventListBT.T LazyTime b ->-   EventListBT.T LazyTime c-_zipWithLazy f as0 bs0 =-   flip (EventListMT.switchBodyL EventListBT.empty) as0 $ \a0 as1 ->-   flip (EventListMT.switchBodyL EventListBT.empty) bs0 $ \b0 bs1 ->-   EventListMT.consBody (f a0 b0) $ unionMaybe $-   zipWithCore f a0 b0 (subdivideMaybe as1) (subdivideMaybe bs1)-{--*Synthesizer.PiecewiseConstant.ALSA.MIDI Data.EventList.Relative.MixedTime> zipWithLazy (,) ('a' ./ 2 /. 'b' ./ 7 /. EventListBT.empty) ('c' ./ (1 P.+ 1) /. 'd' ./ 1 /. EventListBT.empty)+This one is certainly not as efficient as 'bendWheelPressure'+since it first slices the event list+and then zips the slices together. -}---{-# INLINE bendWheelPressure #-}-bendWheelPressure ::+{-# INLINE bendWheelPressureZip #-}+bendWheelPressureZip ::    (RealRing.C y, Trans.C y) =>    Channel ->    Int -> y -> y ->-   Filter (T (BendModulation y))-bendWheelPressure chan+   Filter (T (BM.T y))+bendWheelPressureZip chan      pitchRange wheelDepth pressDepth =-   liftM2 (zipWith BendModulation)+   liftM2 (PC.zipWith BM.Cons)       (pitchBend chan (2^?(fromIntegral pitchRange/12)) 1)-      (liftM2 (zipWith (+))+      (liftM2 (PC.zipWith (+))          (controllerLinear chan VoiceMsg.modulation (0,wheelDepth) 0)          (channelPressure chan pressDepth 0))
src/Synthesizer/PiecewiseConstant/ALSA/MIDIControllerSet.hs view
@@ -3,24 +3,34 @@ -} {-# LANGUAGE NoImplicitPrelude #-} module Synthesizer.PiecewiseConstant.ALSA.MIDIControllerSet (-   T,+   T(Cons),+   mapStream,+    Controller(Controller,PitchBend,Pressure),    fromChannel,+   maybeController,    controllerLinear,    controllerExponential,    pitchBend,    channelPressure,-   PC.BendModulation(PC.BendModulation),-   PC.shiftBendModulation,    bendWheelPressure,+   checkBendWheelPressure,+   bendWheelPressureZip,++   -- * internal data needed in synthesizer-llvm+   initial, stream,    ) where -import qualified Synthesizer.PiecewiseConstant.ALSA.MIDI as PC+import qualified Synthesizer.PiecewiseConstant.Signal as PC import qualified Synthesizer.EventList.ALSA.MIDI as Ev import Synthesizer.EventList.ALSA.MIDI (StrictTime, Channel, ) -import qualified Synthesizer.MIDIValue as MV+import qualified Sound.ALSA.Sequencer.Event as Event+import qualified Sound.MIDI.ALSA.Check as Check import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+import qualified Synthesizer.MIDIValue.BendModulation as BM+import qualified Synthesizer.MIDIValue.BendWheelPressure as BWP+import qualified Synthesizer.MIDIValue as MV  import qualified Synthesizer.Generic.Cut as CutG import Control.DeepSeq (NFData, rnf, )@@ -37,16 +47,17 @@ -- import Numeric.NonNegative.Class ((-|), )  import qualified Algebra.Transcendental as Trans-import qualified Algebra.RealRing      as RealRing+import qualified Algebra.RealRing       as RealRing import qualified Algebra.Field          as Field import qualified Algebra.Additive       as Additive --- import qualified Data.Set as Set import qualified Data.Map as Map import Data.Map (Map, ) +import qualified Data.Accessor.Monad.Trans.State as AccState+import qualified Data.Accessor.Basic as Acc import Control.Monad.Trans.State (State, evalState, state, get, put, )-import Control.Monad (liftM2, msum, fmap, )+import Control.Monad (liftM2, msum, ) import Data.Traversable (traverse, ) import Data.Foldable (traverse_, ) import Data.Monoid (Monoid, mempty, mappend, )@@ -99,13 +110,17 @@ fromChannel chan =    fmap (Cons Map.empty) $    fmap (flip EventListTM.snocTime NonNeg98.zero) $-   Ev.getSlice (\e -> msum $-      (fmap (mapFst Controller) $ Ev.maybeAnyController chan e) :-      (fmap ((,) PitchBend) $ Ev.maybePitchBend chan e) :-      (fmap ((,) Pressure) $ Ev.maybeChannelPressure chan e) :-      [])+   Ev.getSlice (maybeController chan) +maybeController ::+   Channel -> Event.T -> Maybe (Controller, Int)+maybeController chan e = msum $+   (fmap (mapFst Controller) $ Check.anyController chan e) :+   (fmap ((,) PitchBend) $ Check.pitchBend chan e) :+   (fmap ((,) Pressure) $ Check.channelPressure chan e) :+   [] + instance CutG.Read (T key a) where    null =       List.null . List.filter (> P.fromInteger 0) .@@ -236,12 +251,13 @@    error $    "getSlice: uninitialized controller " ++ show c +{-# INLINE getSlice #-} getSlice ::    Controller ->    (Int -> a) ->    a -> Filter (PC.T a) getSlice c f deflt =-   state (\xs ->+   state $ \xs ->       let (ys,zs) =              EventListTT.unzip $              fmap@@ -258,7 +274,7 @@              traverse                 (\ys0 -> traverse_ (put . f) ys0 >> get)       in  (EventListMT.consBody yin1 (fill ys),-           Cons zis zs))+           Cons zis zs)   {-# INLINE controllerLinear #-}@@ -301,13 +317,62 @@   +-- adapted from getSlice {-# INLINE bendWheelPressure #-} bendWheelPressure ::    (RealRing.C y, Trans.C y) =>    Int -> y -> y ->-   Filter (PC.T (PC.BendModulation y))+   Filter (PC.T (BM.T y)) bendWheelPressure pitchRange wheelDepth pressDepth =-   liftM2 (PC.zipWith PC.BendModulation)+   state $ \xs ->+      let (ys,zs) =+             EventListTT.unzip $+             fmap ListHT.unzipEithers $+             flip evalState BWP.deflt $+             traverse (traverse separateBWP) (stream xs)+          move key field (bwp,mp) =+             mapFst (maybe bwp (\y -> Acc.set field y bwp)) $+             Map.updateLookupWithKey+                (\ _k _a -> Nothing) key mp+          (yin,zis) =+             move PitchBend BWP.bend $+             move (Controller VoiceMsg.modulation) BWP.wheel $+             move Pressure BWP.pressure $+             (BWP.deflt, initial xs)+          fill =+             flip evalState yin .+             traverse+                (\ys0 -> traverse_ put ys0 >> get)+      in  (fmap (BM.fromBendWheelPressure pitchRange wheelDepth pressDepth) $+           EventListMT.consBody yin (fill ys),+           Cons zis zs)++separateBWP ::+   (Controller, Int) -> State BWP.T (Either BWP.T (Controller, Int))+separateBWP ev =+   fmap (maybe (Right ev) Left) $+   checkBendWheelPressure ev++checkBendWheelPressure ::+   (Controller, Int) -> State BWP.T (Maybe BWP.T)+checkBendWheelPressure (ctrl,val) =+   let update field = AccState.set field val >> fmap Just get+   in  case ctrl of+          PitchBend -> update BWP.bend+          Pressure -> update BWP.pressure+          Controller cc ->+             if cc == VoiceMsg.modulation+               then update BWP.wheel+               else return $ Nothing+++{-# INLINE bendWheelPressureZip #-}+bendWheelPressureZip ::+   (RealRing.C y, Trans.C y) =>+   Int -> y -> y ->+   Filter (PC.T (BM.T y))+bendWheelPressureZip pitchRange wheelDepth pressDepth =+   liftM2 (PC.zipWith BM.Cons)       (pitchBend (2 ^? (fromIntegral pitchRange / 12)) 1)       (liftM2 (PC.zipWith (+))          (controllerLinear VoiceMsg.modulation (0,wheelDepth) 0)
src/Synthesizer/Storable/ALSA/MIDI.hs view
@@ -33,9 +33,7 @@ import Synthesizer.EventList.ALSA.MIDI           (LazyTime, StrictTime, Filter, Note,            Program, Channel, Controller,-           getControllerEvents, getSlice,-           maybePitchBend, maybeChannelPressure,-           chopLongTime, )+           getControllerEvents, getSlice, ) import qualified Synthesizer.Generic.ALSA.MIDI as Gen import qualified Synthesizer.MIDIValue as MV @@ -50,8 +48,10 @@ import qualified Synthesizer.State.Filter.NonRecursive as FiltNRS import qualified Synthesizer.Basic.Wave         as Wave +import qualified Sound.MIDI.ALSA.Check as Check import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg +import qualified Synthesizer.PiecewiseConstant.Signal as PC -- import qualified Data.EventList.Relative.TimeTime  as EventListTT -- import qualified Data.EventList.Relative.MixedTime as EventListMT -- import qualified Data.EventList.Relative.MixedBody as EventListMB@@ -84,15 +84,15 @@ chunkSizesFromStrictTime :: StrictTime -> NonNegChunky.T SigSt.ChunkSize chunkSizesFromStrictTime =    NonNegChunky.fromChunks .-   map (SVL.ChunkSize . fromInteger . NonNegW.toNumber) .-   chopLongTime+   map (SVL.ChunkSize . NonNegW.toNumber) .+   PC.chopLongTime   chunkSizesFromLazyTime :: LazyTime -> NonNegChunky.T SigSt.ChunkSize chunkSizesFromLazyTime =    NonNegChunky.fromChunks .-   map (SVL.ChunkSize . fromInteger . NonNegW.toNumber) .-   concatMap chopLongTime .+   map (SVL.ChunkSize . NonNegW.toNumber) .+   concatMap PC.chopLongTime .    NonNegChunky.toChunks .    NonNegChunky.normalize @@ -179,7 +179,7 @@    Filter (SigSt.T y) pitchBend chan range center =    liftM (piecewiseConstantInitWith (MV.pitchBend range center) center) $-   getSlice (maybePitchBend chan)+   getSlice (Check.pitchBend chan) --   getPitchBendEvents chan  {-# INLINE channelPressure #-}@@ -190,7 +190,7 @@    Filter (SigSt.T y) channelPressure chan maxVal initVal =    liftM (piecewiseConstantInitWith (MV.controllerLinear (0,maxVal)) initVal) $-   getSlice (maybeChannelPressure chan)+   getSlice (Check.channelPressure chan)   {-@@ -230,8 +230,9 @@    Program ->    Gen.Modulator Note (SigSt.T yv) ->    Filter (SigSt.T yv)-sequenceCore chunkSize =-   Gen.sequenceCore (CutSt.arrangeEquidist chunkSize)+sequenceCore chunkSize chan pgm modu =+   fmap (CutSt.arrangeEquidist chunkSize) $+   Gen.sequenceCore chan pgm modu   {-# INLINE sequence #-}@@ -241,8 +242,9 @@    Channel ->    Instrument y yv ->    Filter (SigSt.T yv)-sequence chunkSize =-   Gen.sequence (CutSt.arrangeEquidist chunkSize)+sequence chunkSize chan bank =+   fmap (CutSt.arrangeEquidist chunkSize) $+   Gen.sequence chan bank   {-# INLINE sequenceModulated #-}@@ -253,8 +255,9 @@    Channel ->    (SigSt.T c -> Instrument y yv) ->    Filter (SigSt.T yv)-sequenceModulated chunkSize =-   Gen.sequenceModulated (CutSt.arrangeEquidist chunkSize)+sequenceModulated chunkSize modu chan instr =+   fmap (CutSt.arrangeEquidist chunkSize) $+   Gen.sequenceModulated modu chan instr   {-# INLINE sequenceMultiModulated #-}@@ -265,8 +268,9 @@    instrument ->    Gen.Modulator (instrument, Note) (Instrument y yv, Note) ->    Filter (SigSt.T yv)-sequenceMultiModulated chunkSize =-   Gen.sequenceMultiModulated (CutSt.arrangeEquidist chunkSize)+sequenceMultiModulated chunkSize chan instr modu =+   fmap (CutSt.arrangeEquidist chunkSize) $+   Gen.sequenceMultiModulated chan instr modu   applyModulation ::@@ -310,5 +314,6 @@    Program ->    [Instrument y yv] ->    Filter (SigSt.T yv)-sequenceMultiProgram chunkSize =-   Gen.sequenceMultiProgram (CutSt.arrangeEquidist chunkSize)+sequenceMultiProgram chunkSize chan pgm bank =+   fmap (CutSt.arrangeEquidist chunkSize) $+   Gen.sequenceMultiProgram chan pgm bank
src/Synthesizer/Storable/ALSA/Play.hs view
@@ -1,13 +1,23 @@ {-# LANGUAGE NoImplicitPrelude #-} {- |-Convert MIDI events of a MIDI controller to a control signal.+Play audio signals via ALSA.+The module could also be called @Output@,+because with a @file@ sink, data can also be written to disk. -} module Synthesizer.Storable.ALSA.Play (+   -- * auxiliary functions+   Device,+   defaultDevice,+   defaultChunkSize,+   makeSink,+   write,+   writeLazy,+   -- * play functions    auto,    autoAndRecord,+   autoAndRecordMany,    monoToInt16,    stereoToInt16,-   defaultChunkSize,    ) where  import qualified Sound.ALSA.PCM as ALSA@@ -22,7 +32,9 @@ import Foreign.Storable (Storable, ) import Foreign.Marshal.Array (advancePtr, ) import Foreign.Ptr (Ptr, minusPtr, )+import Data.Int (Int16, ) import qualified System.IO as IO+import qualified System.Exit as Exit  -- import qualified Synthesizer.State.Signal     as SigS @@ -32,30 +44,65 @@  import qualified Algebra.RealRing as RealRing +import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+ import NumericPrelude.Numeric import NumericPrelude.Base  +{- |+A suggested default chunk size.+It is not used by the functions in this module.+-}+{-+Better move to Storable.Server.Common or Dimensional.Server.Common?+-} defaultChunkSize :: SigSt.ChunkSize+defaultChunkSize = SigSt.chunkSize 512+{-+At some epochs this chunk size leads to buffer underruns.+I cannot reproduce this:+Some months it works this way on Suse but not on Ubuntu or vice versa.+Other months it works the other way round. defaultChunkSize = SigSt.chunkSize 256+-}  +type Device = String++defaultDevice :: Device+defaultDevice = "default"+++{- |+Useful values for the output device are++* @\"default\"@ for mixing with the output of other applications.++* @\"plughw:0,0\"@ for accessing sound output in an exclusive way.++* @\"tee:default,'output.raw',raw\"@ for playing and simultaneously writing raw data to disk.++* @\"tee:default,'output.wav',wav\"@ for playing and writing to WAVE file format.+  Note that the length cannot be written,+  when the program is terminated,+  leaving the file in an invalid format.+-} makeSink ::    (ALSA.SampleFmt y, RealRing.C t) =>-   t ->-   ALSA.SampleFreq ->+   Device {- ^ ALSA output device -} ->+   t {- ^ period (buffer) size expressed in seconds -} ->+   ALSA.SampleFreq {- ^ sample rate -} ->    ALSA.SoundSink y ALSA.Pcm-makeSink periodTime rate =-   let {-# INLINE soundFormat #-}-       soundFormat :: ALSA.SoundFmt y-       soundFormat =-          ALSA.SoundFmt {-             ALSA.sampleFreq = rate-          }-   in  ALSA.alsaSoundSinkTime "plughw:0,0" soundFormat $-       ALSA.SoundBufferTime-          (round (5000000*periodTime))-          (round (1000000*periodTime))+makeSink device periodTime rate =+   ALSA.alsaSoundSinkTime device+      (ALSA.SoundFmt {+         ALSA.sampleFreq = rate+      }) $+   ALSA.SoundBufferTime+      (round (5000000*periodTime))+      (round (1000000*periodTime))  {- alsaOpen: only few buffer underruns with@@ -72,33 +119,49 @@ -} {-# INLINE auto #-} auto ::-   (ALSA.SampleFmt y, RealRing.C t) =>-   t {- ^ period (buffer) size expressed in seconds -} ->-   ALSA.SampleFreq {- ^ sample rate -} ->+   (ALSA.SampleFmt y) =>+   ALSA.SoundSink y handle ->    SigSt.T y -> IO ()-auto periodTime rate ys =-   let sink = makeSink periodTime rate-   in  ALSA.withSoundSink sink $ \to ->-       flip mapM_ (SVL.chunks ys) $ \c ->-       SVB.withStartPtr c $ \ptr size ->-       ALSA.soundSinkWrite sink to ptr size+auto sink ys =+   ALSA.withSoundSink sink $ \to ->+   writeLazy sink to ys +{-# INLINE writeLazy #-}+writeLazy ::+   (Storable a) =>+   ALSA.SoundSink a handle -> handle ->+   SVL.Vector a -> IO ()+writeLazy sink to ys =+   mapM_ (write sink to) (SVL.chunks ys)++{-# INLINE write #-}+write ::+   (Storable a) =>+   ALSA.SoundSink a handle -> handle ->+   SVB.Vector a -> IO ()+write sink to c =+   SVB.withStartPtr c $ \ptr size ->+   ALSA.soundSinkWrite sink to ptr size++ -- cf. Alsa.hs {-# INLINE arraySize #-} arraySize :: Storable y => Ptr y -> Int -> Int arraySize p n = advancePtr p n `minusPtr` p +{- |+Play a signal and write it to disk via SoX simultaneously.+Consider using 'auto' with @tee@ device.+-} {-# INLINE autoAndRecord #-} autoAndRecord ::-   (ALSA.SampleFmt y, SoxFrame.C y, RealRing.C t) =>-   t ->+   (ALSA.SampleFmt y, SoxFrame.C y) =>    FilePath ->-   ALSA.SampleFreq ->-   SigSt.T y -> IO ()-autoAndRecord periodTime fileName rate =-   let sink = makeSink periodTime rate+   ALSA.SoundSink y handle ->+   SigSt.T y -> IO Exit.ExitCode+autoAndRecord fileName sink =+   let rate = ALSA.sampleFreq $ ALSA.soundSinkFmt sink    in  (\act ->-          fmap (const ()) .           SoxWrite.simple act SoxOption.none fileName rate) $ \h ys ->        ALSA.withSoundSink sink $ \to ->        flip mapM_ (SVL.chunks ys) $ \c ->@@ -107,22 +170,41 @@        IO.hPutBuf h ptr (arraySize ptr size)  +{- |+Play a signal and write it to multiple files.+The Functor @f@ may be @Maybe@ for no or one file to write,+or @[]@ for many files to write.+-}+{-# INLINE autoAndRecordMany #-}+autoAndRecordMany ::+   (ALSA.SampleFmt y, SoxFrame.C y,+    Trav.Traversable f) =>+   f FilePath ->+   ALSA.SoundSink y handle ->+   SigSt.T y -> IO (f Exit.ExitCode)+autoAndRecordMany fileNames sink =+   let rate = ALSA.sampleFreq $ ALSA.soundSinkFmt sink+   in  (\act ->+          SoxWrite.manyExtended act SoxOption.none SoxOption.none fileNames rate) $ \hs ys ->+       ALSA.withSoundSink sink $ \to ->+       flip mapM_ (SVL.chunks ys) $ \c ->+       SVB.withStartPtr c $ \ptr size ->+       ALSA.soundSinkWrite sink to ptr size >>+       Fold.traverse_ (\h -> IO.hPutBuf h ptr (arraySize ptr size)) hs++ {-# INLINE monoToInt16 #-} monoToInt16 ::-   (Storable y, RealRing.C y, RealRing.C t) =>-   t ->-   ALSA.SampleFreq ->+   (Storable y, RealRing.C y) =>+   ALSA.SoundSink Int16 handle ->    SigSt.T y -> IO ()-monoToInt16 periodTime rate xs =-   auto periodTime rate-      (SigSt.map BinSmp.int16FromCanonical xs)+monoToInt16 sink xs =+   auto sink (SigSt.map BinSmp.int16FromCanonical xs)  {-# INLINE stereoToInt16 #-} stereoToInt16 ::-   (Storable y, RealRing.C y, RealRing.C t) =>-   t ->-   ALSA.SampleFreq ->+   (Storable y, RealRing.C y) =>+   ALSA.SoundSink (Stereo.T Int16) handle ->    SigSt.T (Stereo.T y) -> IO ()-stereoToInt16 periodTime rate xs =-   auto periodTime rate-      (SigSt.map (fmap BinSmp.int16FromCanonical) xs)+stereoToInt16 sink xs =+   auto sink (SigSt.map (fmap BinSmp.int16FromCanonical) xs)
src/Synthesizer/Storable/ALSA/Server.hs view
@@ -10,11 +10,10 @@ import qualified Synthesizer.Storable.ALSA.Play as Play import qualified Synthesizer.Storable.Oscillator  as OsciSt import qualified Synthesizer.Storable.Signal      as SigSt--import qualified Algebra.Additive  as Additive+import qualified Data.StorableVector.Lazy as SVL  import NumericPrelude.Numeric (zero, )-import Prelude hiding (Real, round, break, id, (.), )+import Prelude hiding (Real, break, id, (.), )   {-@@ -22,9 +21,7 @@ -} main :: IO () main =-   case 110::Int of-      000 -> Play.auto (periodTime::Real) 44100 $-                OsciSt.static chunkSize Wave.sine zero (800/sampleRate::Real)+   case 208::Int of       001 -> print Test.keyboard3       002 -> play (periodTime::Real) sampleRate Test.keyboard3       003 -> Test.speed@@ -66,18 +63,51 @@       050 -> Test.speed       051 -> Test.speedChunky       052 -> Test.speedArrange-      100 -> Run.pitchBend-      101 -> Run.volumeFrequency-      102 -> Run.keyboard-      103 -> Run.keyboardMulti-      104 -> Run.keyboardStereo-      105 -> Run.keyboardPitchbend-      106 -> Run.keyboardFM-      107 -> Run.keyboardDetuneFM-      108 -> Run.keyboardFilter-      109 -> Run.keyboardSample-      110 -> Run.keyboardVariousStereo-      111 -> Run.keyboardSampleTFM-      112 -> Run.keyboardNoisyTone-      113 -> Run.keyboardFilteredNoisyTone+      053 -> Play.auto+{-+                (ALSA.alsaSoundSinkTime Play.defaultDevice+                    (ALSA.SoundFmt {+                       ALSA.sampleFreq = sampleRate+                    }) $+                 ALSA.SoundBufferTime+                    (round (5000000*periodTime::Real))+                    (round (1000000*periodTime::Real))+                ) $+-}+{-+                (ALSA.fileSoundSink "test.f32"+                   (ALSA.SoundFmt {+                      ALSA.sampleFreq = sampleRate+                   })) $+-}+                (Play.makeSink Play.defaultDevice (periodTime::Real) sampleRate) $+             SVL.cycle $+             SigSt.take 100000 $+                OsciSt.static chunkSize (fmap (0.9*) Wave.sine) zero (1/100::Real)+      054 -> Play.auto+                (Play.makeSink Play.defaultDevice (periodTime::Real) sampleRate) $+                OsciSt.static chunkSize (fmap (0.9*) Wave.sine)+                   zero (600/sampleRate::Real)+      055 -> play (periodTime::Real) sampleRate $+                OsciSt.static chunkSize (fmap (0.9*) Wave.sine)+                   zero (600/sampleRate::Real)+      100 -> Run.volume+      101 -> Run.frequency+      102 -> Run.frequencyCausal+      103 -> Run.pitchBend+      104 -> Run.volumeFrequency+      105 -> Run.volumeFrequencyCausal+      200 -> Run.keyboard+      201 -> Run.keyboardMulti+      202 -> Run.keyboardStereo+      203 -> Run.keyboardPitchbend+      204 -> Run.keyboardFM+      205 -> Run.keyboardDetuneFM+      206 -> Run.keyboardFilter+      207 -> Run.keyboardSample+      208 -> Run.keyboardVariousStereo+      209 -> Run.keyboardSampleTFM+      210 -> Run.keyboardNoisyTone+      211 -> Run.keyboardFilteredNoisyTone+      300 -> Run.keyboardCausal       _   -> error "not implemented server part"
src/Synthesizer/Storable/ALSA/Server/Common.hs view
@@ -17,6 +17,7 @@ import qualified Data.EventList.Relative.TimeBody  as EventList  import qualified Sound.Sox.Frame         as SoxFrame+import qualified System.Exit as Exit  import Control.Category ((.), ) @@ -56,7 +57,13 @@    let (SVL.ChunkSize size) = chunkSize    in  ToInteger.fromIntegral size Field./ Ring.fromInteger sampleRate +device :: Play.Device+device = Play.defaultDevice +clientName :: MIDIEv.ClientName+clientName = MIDIEv.ClientName "Haskell-Synthesizer"++ type Real = Float  @@ -67,7 +74,7 @@ withMIDIEvents action proc =    let rate = sampleRate        per  = periodTime-   in  MIDIEv.withMIDIEvents per rate $+   in  MIDIEv.withMIDIEvents clientName per rate $        action per rate . proc  @@ -76,7 +83,7 @@    (RealField.C t, Additive.C y, ALSA.SampleFmt y) =>    t -> t -> SigSt.T y -> IO () play period rate =-   Play.auto period (round rate) .+   Play.auto (Play.makeSink device period (round rate)) .    SigSt.append (SigSt.replicate chunkSize latency zero) --   FiltG.delayPosLazySize chunkSize latency --   FiltG.delayPos latency@@ -85,9 +92,7 @@ {-# INLINE playAndRecord #-} playAndRecord ::    (RealField.C t, Additive.C y, ALSA.SampleFmt y, SoxFrame.C y) =>-   FilePath -> t -> t -> SigSt.T y -> IO ()+   FilePath -> t -> t -> SigSt.T y -> IO Exit.ExitCode playAndRecord fileName period rate =-   Play.autoAndRecord period fileName (round rate) .+   Play.autoAndRecord fileName (Play.makeSink device period (round rate)) .    SigSt.append (SigSt.replicate chunkSize latency zero)--
src/Synthesizer/Storable/ALSA/Server/Instrument.hs view
@@ -2,27 +2,31 @@  import Synthesizer.Storable.ALSA.Server.Common -import qualified Synthesizer.Storable.ALSA.MIDI as AlsaSt import Synthesizer.Storable.ALSA.MIDI (    Instrument, chunkSizesFromLazyTime, ) -import qualified Synthesizer.EventList.ALSA.MIDI as MIDIEv import Synthesizer.EventList.ALSA.MIDI (LazyTime, ) +import qualified Synthesizer.CausalIO.ALSA.Process as PAlsa+import qualified Synthesizer.CausalIO.Gate as Gate+import qualified Synthesizer.CausalIO.Process as PIO+ import qualified Synthesizer.Basic.Wave          as Wave import qualified Synthesizer.Frame.Stereo        as Stereo  import qualified Synthesizer.Causal.Process as Causal-import qualified Synthesizer.Causal.Interpolation as Interpolation import qualified Synthesizer.Causal.Oscillator as OsciC+import qualified Synthesizer.Causal.Interpolation as Interpolation import qualified Synthesizer.Causal.Filter.Recursive.Integration as IntegC-import Control.Arrow ((<<<), (^<<), (<<^), (***), )+import qualified Synthesizer.Causal.Filter.NonRecursive as FiltNRC import qualified Synthesizer.Interpolation.Module as Ip+import Control.Arrow ((<<<), (^<<), (<<^), (***), )  import qualified Synthesizer.Storable.Filter.NonRecursive as FiltNRSt 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              as SV  import qualified Synthesizer.Generic.Wave      as WaveG import qualified Synthesizer.State.Signal      as SigS@@ -43,12 +47,6 @@ import Control.Monad (mzero, ) import Control.Category ((.), ) -import qualified Algebra.RealRing as RealRing--- import qualified Algebra.Field     as Field--- import qualified Algebra.Ring      as Ring--- import qualified Algebra.ToInteger as ToInteger-import qualified Algebra.Additive  as Additive- import NumericPrelude.Numeric (zero, round, (*>), ) import Prelude hiding (Real, round, break, id, (.), ) @@ -70,6 +68,17 @@    SigStV.take (chunkSizesFromLazyTime dur) $    ping vel freq +pingCausal :: PAlsa.Instrument Real (SV.Vector Real)+pingCausal vel freq =+   (PIO.fromCausal $+    Causal.applyStorableChunk $+    Causal.feed $+    FiltNRS.envelope+       (CtrlS.exponential2 (0.2*sampleRate) (amplitudeFromVelocity vel)) $+    OsciS.static Wave.saw zero (freq/sampleRate))+   <<<+   Gate.toStorableVector+ pingReleaseEnvelope :: Real -> LazyTime -> SigSt.T Real pingReleaseEnvelope vel dur =    SigSt.switchR SigSt.empty@@ -95,6 +104,34 @@          (OsciS.static Wave.saw zero (freq*0.999/sampleRate))          (OsciS.static Wave.saw zero (freq*1.001/sampleRate)))       (pingReleaseEnvelope vel dur)++pingReleaseEnvelopeCausal :: Real -> PIO.T PAlsa.GateChunk (SV.Vector Real)+pingReleaseEnvelopeCausal vel =+   PIO.continue+      ((PIO.fromCausal $+        Causal.applyStorableChunk $ Causal.feed $+        CtrlS.exponential2 (0.4*sampleRate) (amplitudeFromVelocity vel))+       <<<+       Gate.toStorableVector+       {-+       <<<+       arr (\x -> trace (show x) x) -})+      (\y -> -- trace ("continue with " ++ show y) $+         (PIO.fromCausal $+          Causal.applyStorableChunk $ Causal.feed $+          SigS.take (round (1*sampleRate :: Real)) $+          CtrlS.exponential2 (0.1*sampleRate) y)+         <<<+         Gate.allToStorableVector)++pingReleaseCausal :: PAlsa.Instrument Real (SV.Vector Real)+pingReleaseCausal vel freq =+   (PIO.fromCausal $+    Causal.applyStorableChunk $+    FiltNRC.envelope <<<+    Causal.feedFst (OsciS.static Wave.saw zero (freq/sampleRate)))+   <<<+   pingReleaseEnvelopeCausal vel  tine :: Instrument Real Real tine vel freq dur =
src/Synthesizer/Storable/ALSA/Server/Run.hs view
@@ -2,12 +2,19 @@  import qualified Synthesizer.Storable.ALSA.Server.Instrument as Instr import Synthesizer.Storable.ALSA.Server.Common-          (Real, withMIDIEvents, play, playAndRecord,-           sampleRate, lazySize, chunkSize, channel, )+          (Real, withMIDIEvents, play, device, clientName,+           sampleRate, lazySize, chunkSize, periodTime, channel, )  import qualified Synthesizer.Storable.ALSA.MIDI as AlsaSt import Synthesizer.Storable.ALSA.MIDI (applyModulation, ) +import qualified Synthesizer.CausalIO.ALSA.Process as PAlsa+import qualified Synthesizer.CausalIO.Process as PIO++import qualified Synthesizer.Causal.Oscillator as OsciC+import qualified Synthesizer.Causal.Process as Causal+import qualified Synthesizer.Causal.Filter.NonRecursive as FiltNRC+ import qualified Synthesizer.Basic.Wave          as Wave  import qualified Synthesizer.Interpolation.Module as Ip@@ -15,8 +22,11 @@ import qualified Synthesizer.Storable.Oscillator  as OsciSt import qualified Synthesizer.Storable.Signal      as SigSt import qualified Data.StorableVector.Lazy         as SVL+import qualified Data.StorableVector              as SV+import Foreign.Storable (Storable, )  import qualified Synthesizer.Generic.Loop      as LoopG+import qualified Synthesizer.Generic.Signal    as SigG import qualified Synthesizer.State.Signal      as SigS import qualified Synthesizer.Plain.Filter.Recursive    as FiltR import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter@@ -25,8 +35,7 @@  import Control.Monad.Trans.State (evalState, ) import Control.Category ((.), )--import qualified Algebra.Additive  as Additive+import Control.Arrow (arr, second, (&&&), )  import Data.Tuple.HT (mapSnd, ) @@ -41,16 +50,37 @@    (withMIDIEvents play $       SigSt.zipWith (*)          (OsciSt.static chunkSize Wave.sine zero (800/sampleRate)) .-      evalState (AlsaSt.controllerLinear channel VoiceMsg.mainVolume (0,1) (0::Real)))+      evalState (AlsaSt.controllerLinear channel VoiceMsg.mainVolume (0,1) (0.2::Real)))  frequency :: IO () frequency =    withMIDIEvents play $       OsciSt.freqMod chunkSize Wave.sine zero .-      evalState (AlsaSt.controllerLinear channel VoiceMsg.mainVolume-         (400/sampleRate, 1200/sampleRate) (800/sampleRate::Real))+      evalState (AlsaSt.controllerExponential channel VoiceMsg.modulation+         (400/sampleRate, 1600/sampleRate) (800/sampleRate::Real))  +{-# INLINE storableChunk #-}+storableChunk ::+   (SigG.Read sig a, Storable a) =>+   sig a -> SV.Vector a+storableChunk chunk =+   SigS.toStrictStorableSignal (SigG.length chunk) $+   SigG.toState chunk++frequencyCausal :: IO ()+frequencyCausal =+   PAlsa.playFromEvents device clientName 0.01 (periodTime::Double) sampleRate+      ((PIO.fromCausal $+        Causal.applyStorableChunk $+        OsciC.freqMod (fmap (0.99*) Wave.sine) zero)+       .+       arr storableChunk+       .+       (PAlsa.controllerExponential channel VoiceMsg.modulation+          (400/sampleRate, 1600/sampleRate) (800/sampleRate::Real)))++ pitchBend :: IO () pitchBend =    withMIDIEvents play $@@ -68,7 +98,26 @@             SigSt.zipWith (*) vol                (OsciSt.freqMod chunkSize Wave.sine zero freq))) +volumeFrequencyCausal :: IO ()+volumeFrequencyCausal =+   PAlsa.playFromEvents device clientName 0.01 (periodTime::Double) sampleRate+      ((PIO.fromCausal $+        Causal.applyStorableChunk $+        FiltNRC.envelope+        .+        second (OsciC.freqMod Wave.sine zero))+       .+       arr (uncurry (SV.zipWith (,)))+       .+       (arr storableChunk+        .+        PAlsa.controllerLinear channel VoiceMsg.mainVolume (0,0.99) (0.5::Real)+        &&&+        arr storableChunk+        .+        PAlsa.pitchBend channel 2 (880/sampleRate::Real))) + keyboard :: IO () keyboard =    withMIDIEvents play $@@ -180,7 +229,7 @@       let loopedString =              LoopG.timeReverse lazySize Ip.linear Ip.linear                 LoopG.timeControlZigZag 8750 500 string-      withMIDIEvents (playAndRecord "session.wav") $+      withMIDIEvents play $          SigSt.map ((0.2::Real)*>) .          evalState (AlsaSt.sequenceMultiProgram chunkSize channel                (VoiceMsg.toProgram 0) $@@ -270,3 +319,12 @@                  applyModulation speed .                  applyModulation cutoff .                  applyModulation resonance))++++keyboardCausal :: IO ()+keyboardCausal =+   PAlsa.playFromEvents device clientName 0.01 (periodTime::Double) sampleRate $+      arr (SV.map (0.2*))+      .+      PAlsa.sequenceStorable channel (\ _pgm -> Instr.pingReleaseCausal)
src/Synthesizer/Storable/ALSA/Server/Test.hs view
@@ -41,7 +41,6 @@ import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg  import qualified Data.EventList.Relative.TimeBody  as EventList-import qualified Data.EventList.Relative.MixedBody as EventListMB import qualified Data.EventList.Relative.BodyTime  as EventListBT import Data.EventList.Relative.MixedBody ((/.), (./), ) @@ -55,9 +54,6 @@ import qualified Numeric.NonNegative.Wrapper as NonNegW import qualified Numeric.NonNegative.Chunky as NonNegChunky -import qualified Algebra.RealRing as RealRing-import qualified Algebra.Additive  as Additive- import Data.Maybe.HT (toMaybe, )  import NumericPrelude.Numeric (zero, round, (^?), )@@ -220,7 +216,8 @@ arrangeSpaceLeak0 :: IO () arrangeSpaceLeak0 =    SVL.writeFile "test.f32" $-   evalState (Gen.sequence (CutSt.arrange chunkSize) channel+   CutSt.arrange chunkSize $+   evalState (Gen.sequence channel       (error "no sound" :: Instrument Real Real)) $    let evs = EventList.cons 10 [] evs    in  evs@@ -228,8 +225,9 @@ arrangeSpaceLeak1 :: IO () arrangeSpaceLeak1 =    SVL.writeFile "test.f32" $+   CutSt.arrange chunkSize $    evalState-      (Gen.sequenceModulated (CutSt.arrange chunkSize)+      (Gen.sequenceModulated          (SigSt.iterate chunkSize (1+) 0) channel          (error "no sound" :: SigSt.T Real -> Instrument Real Real)) $    let evs = EventList.cons 10 [] evs@@ -263,8 +261,9 @@ arrangeSpaceLeak3 :: IO () arrangeSpaceLeak3 =    SVL.writeFile "test.f32" $+   CutSt.arrange chunkSize $    evalState-      (Gen.sequenceModulated (CutSt.arrange chunkSize)+      (Gen.sequenceModulated          (SigSt.iterate chunkSize (1e-7 +) 1) channel          Instr.stringStereoFM) $ --         (const Instr.pingDur :: SigSt.T Real -> Instrument Real Real)) $@@ -285,9 +284,8 @@ chordSpaceLeak1 :: IO () chordSpaceLeak1 =    SVL.writeFile "test.f32" $-   evalState-      (Gen.sequence (CutSt.arrange chunkSize)-          channel Instr.pingDur) $+   CutSt.arrange chunkSize $+   evalState (Gen.sequence channel Instr.pingDur) $    let evs t = EventList.cons t [] (evs (20-t))    in  EventList.cons 10 [makeNote Event.NoteOn 60] $        EventList.cons 10 [makeNote Event.NoteOn 64] $@@ -297,9 +295,10 @@ sequencePitchBend :: IO () sequencePitchBend =    SVL.writeFile "test.f32" $+      CutSt.arrange chunkSize $       evalState          (let fm y = (EventListBT.cons $! y) 10 (fm (2-y))-          in  Gen.sequenceModulated (CutSt.arrange chunkSize) (fm 1) channel+          in  Gen.sequenceModulated (fm 1) channel                  (error "no sound" ::                      PC.T Real -> Instrument Real Real)) $       let evs = EventList.cons 10 [] evs@@ -308,12 +307,13 @@ sequencePitchBend1 :: IO () sequencePitchBend1 =    SVL.writeFile "test.f32" $+      CutSt.arrange chunkSize $       evalState          (let fm y = EventListBT.cons y 10 (fm (2-y))               instr :: PC.T Real -> Instrument Real Real               instr = error "no sound"           in  Gen.sequenceCore-                 (CutSt.arrange chunkSize) channel Gen.errorNoProgram+                 channel Gen.errorNoProgram                  (Gen.Modulator (fm 1) Gen.advanceModulationChunk                      (\note -> gets $ \c ->                          Gen.renderInstrumentIgnoreProgram (instr c) note))) $@@ -548,8 +548,8 @@ sequenceStaccato1 :: IO () sequenceStaccato1 =    SVL.writeFile "test.f32" $-      evalState-         (do Gen.sequence (CutSt.arrange chunkSize) channel dummySound) $+      CutSt.arrange chunkSize $+      evalState (Gen.sequence channel dummySound) $       let evs t =              EventList.cons t [makeNote Event.NoteOn  60] $              EventList.cons t [makeNote Event.NoteOff 60] $
src/Test.hs view
@@ -7,7 +7,6 @@ import qualified Sound.ALSA.Sequencer.Event as Event import qualified Synthesizer.Generic.ALSA.MIDI as Gen import qualified Synthesizer.Storable.ALSA.Play as Play-import qualified Synthesizer.Storable.ALSA.MIDI as AlsaSt import Synthesizer.Storable.ALSA.MIDI (    Instrument, chunkSizesFromLazyTime, ) @@ -88,7 +87,8 @@ sequenceSpaceLeakEmpty :: Bool sequenceSpaceLeakEmpty =    evaluatePrefix $-   evalState (Gen.sequence (CutSt.arrange chunkSize) channel+   CutSt.arrange chunkSize $+   evalState (Gen.sequence channel       (error "no sound" :: Instrument Real Real)) $    let evs = consNone 10 evs    in  evs@@ -96,8 +96,9 @@ sequenceSpaceLeakModulatedEmpty :: Bool sequenceSpaceLeakModulatedEmpty =    evaluatePrefix $+   CutSt.arrange chunkSize $    evalState-      (Gen.sequenceModulated (CutSt.arrange chunkSize)+      (Gen.sequenceModulated          (SigSt.iterate chunkSize (1+) 0) channel          (error "no sound" :: SigSt.T Real -> Instrument Real Real)) $    let evs = consNone 10 evs@@ -107,9 +108,10 @@ sequenceSpaceLeakLazyDrop :: Bool sequenceSpaceLeakLazyDrop =    evaluatePrefix $+   CutSt.arrange chunkSize $    evalState       (let fm y = (EventListBT.cons $! y) 10 (fm (2-y))-       in  Gen.sequenceModulated (CutSt.arrange chunkSize) (fm 1) channel+       in  Gen.sequenceModulated (fm 1) channel               (error "no sound" ::                   PC.T Real -> Instrument Real Real)) $    let evs = consNone 10 evs@@ -131,8 +133,9 @@ sequenceSpaceLeakModulatedInfinite :: Bool sequenceSpaceLeakModulatedInfinite =    evaluatePrefix $+   CutSt.arrange chunkSize $    evalState-      (Gen.sequenceModulated (CutSt.arrange chunkSize)+      (Gen.sequenceModulated          (SigSt.iterate chunkSize (1e-7 +) 1) channel          stringStereoFM) $    let evs t = consNone t (evs (20-t))@@ -142,8 +145,9 @@ sequenceSpaceLeakModulatedChordStep :: Bool sequenceSpaceLeakModulatedChordStep =    evaluatePrefix $+   CutSt.arrange chunkSize $    evalState-      (Gen.sequenceModulated (CutSt.arrange chunkSize)+      (Gen.sequenceModulated          (SigSt.iterate chunkSize (1e-7 +) 1) channel          stringStereoFM) $    let evs t = consNone t (evs (20-t))@@ -155,8 +159,9 @@ sequenceSpaceLeakModulatedChordSimultaneous :: Bool sequenceSpaceLeakModulatedChordSimultaneous =    evaluatePrefix $+   CutSt.arrange chunkSize $    evalState-      (Gen.sequenceModulated (CutSt.arrange chunkSize)+      (Gen.sequenceModulated          (SigSt.iterate chunkSize (1e-7 +) 1) channel          stringStereoFM) $    let evs t = EventList.cons t [] (evs (20-t))@@ -169,8 +174,9 @@ sequenceSpaceLeakStaccato :: Bool sequenceSpaceLeakStaccato =    evaluatePrefix $+   CutSt.arrange chunkSize $    evalState-      (Gen.sequenceModulated (CutSt.arrange chunkSize)+      (Gen.sequenceModulated          (SigSt.iterate chunkSize (1e-7 +) 1) channel          stringStereoFM) $    let evs t =
synthesizer-alsa.cabal view
@@ -1,11 +1,10 @@ Name:           synthesizer-alsa-Version:        0.3+Version:        0.4 License:        GPL License-File:   LICENSE Author:         Henning Thielemann <haskell@henning-thielemann.de> Maintainer:     Henning Thielemann <haskell@henning-thielemann.de> Homepage:       http://www.haskell.org/haskellwiki/Synthesizer-Package-URL:    http://code.haskell.org/synthesizer/alsa/ Category:       Sound, Music Synopsis:       Control synthesizer effects via ALSA/MIDI Description:@@ -14,10 +13,19 @@   that can be used for audio effects.   As demonstration there is a keyboard controlled music synthesizer. Stability:      Experimental-Tested-With:    GHC==6.4.1, GHC==6.8.2, GHC==6.10.4-Cabal-Version:  >=1.2+Tested-With:    GHC==6.4.1, GHC==6.8.2, GHC==6.10.4, GHC==6.12.3, GHC==7.0.4, GHC==7.2.1+Cabal-Version:  >=1.6 Build-Type:     Simple +Source-Repository this+  Tag:         0.4+  Type:        darcs+  Location:    http://code.haskell.org/synthesizer/alsa/++Source-Repository head+  Type:        darcs+  Location:    http://code.haskell.org/synthesizer/alsa/+ Flag splitBase   description: Choose the new smaller, split-up base package. @@ -35,34 +43,41 @@  Library   Build-Depends:-    synthesizer-dimensional >=0.5 && < 0.6,-    synthesizer-core >=0.4 && < 0.5,-    sox >=0.2 && <0.3,-    midi-alsa >=0.1 && <0.2,-    alsa-seq >=0.5 && <0.6,+    synthesizer-dimensional >=0.6 && <0.7,+    synthesizer-core >=0.5 && <0.6,+    sox >=0.2.1 && <0.3,+    midi-alsa >=0.1.2 && <0.2,+    alsa-seq >=0.5.1 && <0.6,     alsa-pcm >=0.5 && <0.6,     alsa-core >=0.5 && <0.6,     midi >=0.1.1 && <0.2,+    storable-record >=0.0.2 && <0.1,     storablevector >=0.2.5 && <0.3,     deepseq >=1.1 && <1.2,-    numeric-prelude >=0.2 && <0.3,+    numeric-prelude >=0.3 && <0.4,     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.4,+    containers >=0.1 && <0.5,     array >=0.1 && <0.4,     transformers >=0.2 && <0.3,     utility-ht >=0.0.1 && <0.1    If flag(splitBase)     Build-Depends:-      base >= 3 && <6,       random >= 1.0 && < 1.1,-      old-time >= 1.0 && < 1.1+      old-time >= 1.0 && < 1.1,+      base >= 3 && <5   Else     Build-Depends:       base >= 1.0 && < 2 +  If impl(ghc>=7.0)+    GHC-Options: -fwarn-unused-do-bind+    CPP-Options: -DNoImplicitPrelude=RebindableSyntax+    Extensions: CPP+   GHC-Options:    -Wall   Hs-source-dirs: src   Exposed-modules:@@ -74,10 +89,16 @@     Synthesizer.Generic.ALSA.MIDI     Synthesizer.Dimensional.ALSA.MIDI     Synthesizer.Dimensional.ALSA.Play+    Synthesizer.CausalIO.ALSA.Process+    Synthesizer.CausalIO.ALSA.MIDIControllerSet+    Synthesizer.CausalIO.ALSA.MIDIControllerSelection     -- these modules would be better located in midi package,     -- but they are based on NumericPrelude     Synthesizer.MIDIValue+    Synthesizer.MIDIValue.BendModulation+    Synthesizer.MIDIValue.BendWheelPressure     Synthesizer.Dimensional.MIDIValue+    Synthesizer.Dimensional.MIDIValuePlain  Executable realtimesynth   If !flag(buildExamples)@@ -86,6 +107,10 @@     GHC-Options: -O2 -fvia-C -optc-O2 -optc-msse3 -optc-ffast-math   GHC-Options: -Wall -fexcess-precision -threaded -- -ddump-simpl-stats -ddump-asm+  If impl(ghc>=7.0)+    GHC-Options: -fwarn-unused-do-bind+    CPP-Options: -DNoImplicitPrelude=RebindableSyntax+    Extensions: CPP   Hs-Source-Dirs: src   Other-modules:     Synthesizer.Storable.ALSA.Server.Common@@ -101,6 +126,10 @@     GHC-Options: -O2 -fvia-C -optc-O2 -optc-ffast-math   GHC-Options: -Wall -fexcess-precision -threaded -- -ddump-simpl-stats+  If impl(ghc>=7.0)+    GHC-Options: -fwarn-unused-do-bind+    CPP-Options: -DNoImplicitPrelude=RebindableSyntax+    Extensions: CPP   Hs-Source-Dirs: src   Other-modules:     Synthesizer.Dimensional.ALSA.Server.Common@@ -116,5 +145,9 @@     GHC-Options: -O2 -fvia-C -optc-O2 -optc-msse3 -optc-ffast-math   GHC-Options: -Wall -fexcess-precision -threaded -- -ddump-simpl-stats -ddump-asm+  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