hunk ./alsa-pcm.cabal 32
+Flag buildSynthesizer
+  description: Build example synthesizer (needs alsa-seq, too)
+  default:     False
+
hunk ./alsa-pcm.cabal 67
+Executable alsa-minisynth
+  Main-Is: synth.hs
+  If !flag(buildSynthesizer)
+    Buildable: False
+  Hs-Source-Dirs: src, debug, examples
+  GHC-Options: -Wall -threaded
+  Other-modules:
+    Sound.ALSA.PCM
+    Sound.ALSA.PCM.Core
+    Sound.ALSA.PCM.C2HS
+  Build-Depends:
+    alsa-seq >=0.5 && <0.6,
+    alsa-core >=0.5 && <0.6,
+    storablevector >=0.2.7 && <0.3,
+    sample-frame >=0.0.1 && <0.1,
+    base >=3 && <5
+
addfile ./examples/synth.hs
hunk ./examples/synth.hs 1
+import qualified Sound.ALSA.PCM as PCM
+
+import qualified Sound.ALSA.PCM.Core as Core
+import qualified Sound.ALSA.Exception as AlsaExc
+import qualified Sound.ALSA.PCM.Debug as Debug
+
+import qualified Data.StorableVector.Lazy as SVL
+import qualified Data.StorableVector.Base as SVB
+
+import Control.Exception (bracket, )
+
+
+soundFormat :: PCM.SoundFmt Float
+soundFormat = PCM.SoundFmt { PCM.sampleFreq = 44100 }
+
+openPCM :: IO (Int, Int, Core.Pcm)
+openPCM = do
+   Debug.put "alsaOpenTest"
+   h <- Core.pcm_open "default" Core.PcmStreamPlayback 0
+   (bufferTime,bufferSize,periodTime,periodSize,sampleRate) <-
+      setHwParams h
+         (PCM.withSampleFmt PCM.sampleFmtToPcmFormat soundFormat)
+         (PCM.numChannels soundFormat)
+         (PCM.sampleFreq soundFormat)
+         100000
+         20000
+   PCM.setSwParams h bufferSize periodSize
+   Core.pcm_prepare h
+   Debug.put $ "bufferTime = " ++ show bufferTime
+   Debug.put $ "bufferSize = " ++ show bufferSize
+   Debug.put $ "periodTime = " ++ show periodTime
+   Debug.put $ "periodSize = " ++ show periodSize
+   return (periodSize, sampleRate, h)
+
+closePCM :: (Int, Int, Core.Pcm) -> IO ()
+closePCM (_,_,pcm) = AlsaExc.rethrow $ do
+   Debug.put "alsaClose"
+   Core.pcm_drain pcm
+   Core.pcm_close pcm
+
+setHwParams ::
+      Core.Pcm
+   -> Core.PcmFormat
+   -> Int -- ^ number of channels
+   -> PCM.SampleFreq -- ^ sample frequency
+   -> PCM.Time -- ^ buffer time
+   -> PCM.Time -- ^ period time
+   -> IO (Int,Int,Int,Int,Int)
+      -- ^ (bufferTime,bufferSize,periodTime,periodSize)
+setHwParams h format channels rate bufferTime periodTime =
+   PCM.withHwParams h $ \p -> do
+      Core.pcm_hw_params_set_access h p Core.PcmAccessRwInterleaved
+      Core.pcm_hw_params_set_format h p format
+      Core.pcm_hw_params_set_channels h p channels
+{-
+      (actualRate,ord) <-
+         Core.pcm_hw_params_get_rate_max p
+      print ord
+-}
+      Core.pcm_hw_params_set_rate_resample h p False
+      (actualRate,_) <-
+         Core.pcm_hw_params_set_rate_near h p rate EQ
+      (actualBufferTime,_) <-
+          Core.pcm_hw_params_set_buffer_time_near h p bufferTime EQ
+      bufferSize <- Core.pcm_hw_params_get_buffer_size p
+      (actualPeriodTime,_) <-
+          Core.pcm_hw_params_set_period_time_near h p periodTime EQ
+      (periodSize,_) <- Core.pcm_hw_params_get_period_size p
+      return (actualBufferTime, bufferSize,
+              actualPeriodTime, periodSize,
+              actualRate)
+
+main :: IO ()
+main =
+   bracket openPCM closePCM $ \(size,rate,h) -> do
+   putStrLn $ "period size: " ++ show size
+   putStrLn $ "sample rate: " ++ show rate
+   mapM_ (flip SVB.withStartPtr $ PCM.alsaWrite h) $
+      SVL.chunks $
+      SVL.map ((0.99*) . sin . ((2*pi * 440 / fromIntegral rate :: Float)*)) $
+      SVL.iterate (SVL.chunkSize size) (1 +) 0
hunk ./examples/synth.hs 25
-         100000
-         20000
+         1024 64
hunk ./examples/synth.hs 45
-   -> PCM.Time -- ^ buffer time
-   -> PCM.Time -- ^ period time
+   -> Int -- ^ buffer size
+   -> Int -- ^ period size
hunk ./examples/synth.hs 49
-setHwParams h format channels rate bufferTime periodTime =
+setHwParams h format channels rate bufferSize periodSize =
hunk ./examples/synth.hs 62
-      (actualBufferTime,_) <-
-          Core.pcm_hw_params_set_buffer_time_near h p bufferTime EQ
-      bufferSize <- Core.pcm_hw_params_get_buffer_size p
-      (actualPeriodTime,_) <-
-          Core.pcm_hw_params_set_period_time_near h p periodTime EQ
-      (periodSize,_) <- Core.pcm_hw_params_get_period_size p
-      return (actualBufferTime, bufferSize,
-              actualPeriodTime, periodSize,
+      (actualPeriodSize,_) <-
+         Core.pcm_hw_params_set_period_size_near h p periodSize EQ
+      actualBufferSize <-
+         Core.pcm_hw_params_set_buffer_size_near h p
+            (max bufferSize (actualPeriodSize*2))
+{-
+      let actualBufferSize = bufferSize
+      Core.pcm_hw_params_set_buffer_size h p bufferSize
+-}
+      (actualBufferTime,_) <- Core.pcm_hw_params_get_buffer_time p
+      (actualPeriodTime,_) <- Core.pcm_hw_params_get_period_time p
+      return (actualBufferTime, actualBufferSize,
+              actualPeriodTime, actualPeriodSize,
hunk ./examples/synth.hs 7
-import qualified Data.StorableVector.Lazy as SVL
+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
+import qualified Sound.ALSA.Sequencer as SndSeq
+-- import qualified Sound.ALSA.Exception as AlsaExc
+
+import qualified Data.StorableVector.ST.Strict as SVST
+import qualified Data.StorableVector as SV
hunk ./examples/synth.hs 21
+import Foreign.Storable (Storable, )
+import Control.Monad.ST.Strict as ST
+
+import qualified Control.Monad.Trans.State.Strict as MS
+import Control.Monad.IO.Class (liftIO, )
+
+import qualified Data.Map as Map
+
+import Data.Word (Word8, )
+
hunk ./examples/synth.hs 32
+import Control.Monad (liftM, forever, )
hunk ./examples/synth.hs 99
+
+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
+
+
+withInPort ::
+   SndSeq.BlockMode ->
+   (SndSeq.T SndSeq.DuplexMode -> Port.T -> IO t) -> IO t
+withInPort blockMode act =
+   SndSeq.with SndSeq.defaultName blockMode $ \h ->
+   Client.setName h "alsa-haskell-minisynth" >>
+   Port.withSimple h "input"
+      (Port.caps [Port.capWrite, Port.capSubsWrite])
+      Port.typeApplication
+      (act h)
+
+
+type StampedEvent time = (time, Event.T)
+
+
+{- |
+RealTime.toFractional for NumericPrelude.
+-}
+realTimeToField :: (Fractional a) => RealTime.T -> a
+realTimeToField (RealTime.Cons s n) =
+   fromIntegral s + fromIntegral n / (10^(9::Int))
+
+addStamp ::
+   (RealFrac time) =>
+   Event.T -> StampedEvent time
+addStamp ev =
+   (case Event.timestamp ev of
+      Event.RealTime t -> realTimeToField t
+      _ -> error "unsupported time stamp type",
+    ev)
+
+
+milliseconds ::
+   (RealFrac time) =>
+   time -> Integer
+milliseconds t =
+   floor (t*1000)
+
+{- | only use it for blocking sequencers -}
+getStampedEventsUntilTime ::
+   (RealFrac 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]
+getEventsUntilEcho c h =
+   let loop = do
+          ev <- Event.input h
+          let abort =
+                 case Event.body ev of
+                    Event.CustomEv Event.Echo _ ->
+                       c == Addr.client (Event.source ev)
+                    _ -> False
+          if abort
+            then
+               case Event.timestamp ev of
+                 Event.RealTime t -> do
+                    putStrLn $ "got Echo at: " ++ show (realTimeToField t :: Double)
+                    return []
+                 _ -> error "unsupported time stamp type"
+            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 ::
+   (RealFrac time,
+    SndSeq.AllowInput mode, SndSeq.AllowOutput mode) =>
+   SndSeq.T mode ->
+   Queue.T -> Port.T -> time ->
+   IO [Event.T]
+getEventsUntilTime h q p t = do
+   putStrLn $ "schedule echo for " ++ show (milliseconds t)
+   c <- Client.getId h
+   _ <- Event.output h $
+           makeEcho c q p t (Event.Custom 0 0 0)
+   _ <- Event.drainOutput h
+   getEventsUntilEcho c h
+
+
+makeEcho ::
+   RealFrac time =>
+   Client.T -> Queue.T -> Port.T ->
+   time -> Event.Custom -> Event.T
+makeEcho c q p t dat =
+   (Event.simple
+      (Addr.Cons c Port.unknown)
+      (Event.CustomEv Event.Echo dat))
+      { Event.queue = q
+      , Event.timestamp =
+           Event.RealTime $ RealTime.fromInteger $
+           floor (10^(9::Int) * t)
+      , Event.dest = Addr.Cons {
+           Addr.client = c,
+           Addr.port = p
+        }
+      }
+
+
+unsafeAddChunkToBuffer :: (Storable a, Num a) =>
+   SVST.Vector s a -> Int -> SV.Vector a -> ST s ()
+unsafeAddChunkToBuffer v start xs =
+   let go i j =
+          if j >= SV.length xs
+            then return ()
+            else
+              SVST.unsafeModify v i (SV.index xs j +) >>
+              go (i + 1) (j + 1)
+   in  go start 0
+
+arrange ::
+   (Storable a, Num a) =>
+   Int ->
+   [(Int, SV.Vector a)] ->
+   SV.Vector a
+arrange size evs =
+   SVST.runSTVector (do
+      v <- SVST.new size 0
+      mapM_ (uncurry $ unsafeAddChunkToBuffer v) evs
+      return v)
+
+
+type Pitch = Word8
+
+data OscillatorState a = OscillatorState a a Int
+
+{-
+type ToneSequence a =
+        (Maybe (Int, OscillatorState a),
+         [(Int, Int, OscillatorState a)])
+
+startTone :: ToneSequence a -> ToneSequence a
+-}
+
+stopTone ::
+   Int ->
+   (Maybe (Int, OscillatorState a),
+    [(Int, Int, OscillatorState a)]) ->
+   [(Int, Int, OscillatorState a)]
+stopTone stopTime (mplaying, finished) =
+   case mplaying of
+      Just (startTime, osci) ->
+         (startTime, stopTime-startTime, osci) : finished
+      Nothing -> finished
+
+renderTone ::
+   (Storable a, Floating a) =>
+   Int -> OscillatorState a ->
+   (SV.Vector a, OscillatorState a)
+renderTone dur (OscillatorState amp freq phase) =
+   (SV.map (\k -> amp * sin (2*pi*fromIntegral k * freq)) $
+    SV.iterateN dur (1+) phase,
+    OscillatorState amp freq (phase+dur))
+
+frequencyFromPitch ::
+   (Floating y) =>
+   Pitch -> y
+frequencyFromPitch pitch =
+   440 * 2 ** (fromIntegral (fromIntegral pitch + 3 - 6*12 :: Int) / 12)
+
+processEvents ::
+   (Storable a, Floating a, Monad m) =>
+   Int ->
+   PCM.SampleFreq ->
+   [(Int, Event.T)] ->
+   MS.StateT (Int, Map.Map Pitch (OscillatorState a)) m [(Int, SV.Vector a)]
+processEvents size rate input = do
+   (chunkTime, oscis0) <- MS.get
+   let pendingOscis =
+          fmap
+             (\(mplaying, finished) ->
+                let mplayingNew =
+                       fmap
+                          (\(start,s0) ->
+                             case renderTone (size-start) s0 of
+                                (chunk, s1) -> ((start,chunk), s1))
+                          mplaying
+                in  (fmap snd mplayingNew,
+                     maybe id (\p -> (fst p :)) mplayingNew $
+                     map
+                        (\(start, dur, s) -> (start, fst $ renderTone dur s))
+                        finished)) $
+          foldl
+             (\oscis (time,ev) ->
+                case Event.body ev of
+                   Event.NoteEv Event.NoteOn note ->
+                      Map.insertWith
+                         (\(newOsci, []) s ->
+                            {-
+                            A key may be pressed that was already pressed.
+                            This should not happen, but we must be prepared for it.
+                            Thus we call stopTone.
+                            -}
+                            (newOsci, stopTone (time-chunkTime) s))
+                         (Event.noteNote note)
+                         (Just (time-chunkTime,
+                             OscillatorState
+                                (fromIntegral (Event.noteVelocity note) / 200)
+                                (frequencyFromPitch (Event.noteNote note) /
+                                 fromIntegral rate)
+                                0),
+                          [])
+                         oscis
+                   Event.NoteEv Event.NoteOff note ->
+                      Map.adjust
+                         (\s ->
+                            {-
+                            A key may be released that was not pressed.
+                            This should not happen, but we must be prepared for it.
+                            Thus stopTone also handles that case.
+                            -}
+                            (Nothing, stopTone (time-chunkTime) s))
+                         (Event.noteNote note)
+                         oscis
+                   _ -> oscis)
+             (fmap (\s -> (Just (0, s), [])) oscis0)
+             input
+   MS.put (chunkTime, Map.mapMaybe fst pendingOscis)
+   return (concatMap snd $ Map.elems pendingOscis)
+
+
hunk ./examples/synth.hs 349
-   mapM_ (flip SVB.withStartPtr $ PCM.alsaWrite h) $
-      SVL.chunks $
-      SVL.map ((0.99*) . sin . ((2*pi * 440 / fromIntegral rate :: Float)*)) $
-      SVL.iterate (SVL.chunkSize size) (1 +) 0
+   withInPort SndSeq.Block $ \sq port ->
+      Queue.with sq $ \ q ->
+      do setTimestamping sq port q
+         Queue.control sq q Event.QueueStart 0 Nothing
+         _ <- Event.drainOutput sq
+         flip MS.evalStateT (0,Map.empty) $ forever $ do
+            time <- MS.gets fst
+            evs <-
+               liftIO $
+               getStampedEventsUntilTime sq q port
+                  (fromIntegral time / fromIntegral rate)
+            chunks <-
+               processEvents size rate $
+               map (\(t,ev) -> (floor (t*fromIntegral rate :: Double), ev)) evs
+            liftIO $
+               SVB.withStartPtr (arrange size chunks :: SV.Vector Float) $
+               PCM.alsaWrite h
+            MS.modify $ \(_,ss) -> (time+size, ss)
hunk ./examples/synth.hs 246
+type Velocity = Word8
hunk ./examples/synth.hs 278
+amplitudeFromVelocity ::
+   (Floating y) =>
+   Velocity -> y
+amplitudeFromVelocity vel =
+   4 ** ((fromIntegral vel - 64) / 128)
+
hunk ./examples/synth.hs 290
+normalizeNote :: Event.NoteEv -> Event.Note -> (Event.NoteEv, Velocity)
+normalizeNote notePart note =
+   case Event.noteVelocity note of
+      velocity ->
+         case notePart of
+            Event.NoteOn ->
+               if velocity == 0
+                 then (Event.NoteOff, 64)
+                 else (Event.NoteOn, velocity)
+            _ -> (notePart, velocity)
+
hunk ./examples/synth.hs 326
-                   Event.NoteEv Event.NoteOn note ->
-                      Map.insertWith
-                         (\(newOsci, []) s ->
-                            {-
-                            A key may be pressed that was already pressed.
-                            This should not happen, but we must be prepared for it.
-                            Thus we call stopTone.
-                            -}
-                            (newOsci, stopTone (time-chunkTime) s))
-                         (Event.noteNote note)
-                         (Just (time-chunkTime,
-                             OscillatorState
-                                (fromIntegral (Event.noteVelocity note) / 200)
-                                (frequencyFromPitch (Event.noteNote note) /
-                                 fromIntegral rate)
-                                0),
-                          [])
-                         oscis
-                   Event.NoteEv Event.NoteOff note ->
-                      Map.adjust
-                         (\s ->
-                            {-
-                            A key may be released that was not pressed.
-                            This should not happen, but we must be prepared for it.
-                            Thus stopTone also handles that case.
-                            -}
-                            (Nothing, stopTone (time-chunkTime) s))
-                         (Event.noteNote note)
-                         oscis
+                   Event.NoteEv noteEv note ->
+                      case normalizeNote noteEv note of
+                         (Event.NoteOn, velocity) ->
+                            Map.insertWith
+                               (\(newOsci, []) s ->
+                                  {-
+                                  A key may be pressed that was already pressed.
+                                  This should not happen, but we must be prepared for it.
+                                  Thus we call stopTone.
+                                  -}
+                                  (newOsci, stopTone (time-chunkTime) s))
+                               (Event.noteNote note)
+                               (Just (time-chunkTime,
+                                   OscillatorState
+                                      (0.2 * amplitudeFromVelocity velocity)
+                                      (frequencyFromPitch (Event.noteNote note) /
+                                       fromIntegral rate)
+                                      0),
+                                [])
+                               oscis
+                         (Event.NoteOff, _) ->
+                            Map.adjust
+                               (\s ->
+                                  {-
+                                  A key may be released that was not pressed.
+                                  This should not happen, but we must be prepared for it.
+                                  Thus stopTone also handles that case.
+                                  -}
+                                  (Nothing, stopTone (time-chunkTime) s))
+                               (Event.noteNote note)
+                               oscis
+                         _ -> oscis
hunk ./examples/synth.hs 34
+import Debug.Trace (trace, )
+
hunk ./examples/synth.hs 224
+check :: Monad m => Bool -> String -> m () -> m ()
+check b msg act =
+   if not b
+     then trace msg $ return ()
+     else act
+
hunk ./examples/synth.hs 239
-   in  go start 0
+   in  check (start>=0) ("start negative: " ++ show start) $
+       check (start+SV.length xs <= SVST.length v)
+                ("start too big: " ++ show (start, SV.length xs)) $
+       go start 0
hunk ./examples/synth.hs 376
+write ::
+   (PCM.SampleFmt a) =>
+   Core.Pcm -> SV.Vector a -> IO ()
+write h xs =
+   SVB.withStartPtr xs $ PCM.alsaWrite h
+
+
hunk ./examples/synth.hs 393
+         write h (SV.replicate (2*size) 0 :: SV.Vector Float)
hunk ./examples/synth.hs 395
-            time <- MS.gets fst
+            startTime <- MS.gets fst
+            let stopTime = startTime+size
hunk ./examples/synth.hs 400
-                  (fromIntegral time / fromIntegral rate)
+                  (fromIntegral stopTime / fromIntegral rate)
hunk ./examples/synth.hs 405
-               SVB.withStartPtr (arrange size chunks :: SV.Vector Float) $
-               PCM.alsaWrite h
-            MS.modify $ \(_,ss) -> (time+size, ss)
+               write h (arrange size chunks :: SV.Vector Float)
+            MS.modify $ \(_,ss) -> (stopTime, ss)
hunk ./examples/synth.hs 284
-renderTone dur (OscillatorState amp freq phase) =
-   (SV.map (\k -> amp * sin (2*pi*fromIntegral k * freq)) $
-    SV.iterateN dur (1+) phase,
-    OscillatorState amp freq (phase+dur))
+renderTone dur state@(OscillatorState amp freq phase) =
+   if dur<0
+     then
+       trace ("renderTone: negative duration " ++ show dur) $
+       (SV.empty, state)
+     else
+       let gain = 0.9999
+       in  (SV.zipWith (\y k -> y * sin (2*pi*fromIntegral k * freq))
+               (SV.iterateN dur (gain*) amp)
+               (SV.iterateN dur (1+) phase),
+            OscillatorState (amp*gain^dur) freq (phase+dur))
hunk ./examples/synth.hs 124
-type StampedEvent time = (time, Event.T)
+type StampedEvent = (Time, Event.T)
+
+type Time = Integer
hunk ./examples/synth.hs 137
-   (RealFrac time) =>
-   Event.T -> StampedEvent time
-addStamp ev =
+   Time -> Event.T -> StampedEvent
+addStamp rate ev =
hunk ./examples/synth.hs 140
-      Event.RealTime t -> realTimeToField t
+      Event.RealTime t ->
+         div (RealTime.toInteger t * rate) nano
hunk ./examples/synth.hs 146
-milliseconds ::
-   (RealFrac time) =>
-   time -> Integer
-milliseconds t =
-   floor (t*1000)
+nano :: Integer
+nano = 10^(9::Int)
hunk ./examples/synth.hs 151
-   (RealFrac time,
-    SndSeq.AllowInput mode, SndSeq.AllowOutput mode) =>
+   (SndSeq.AllowInput mode, SndSeq.AllowOutput mode) =>
hunk ./examples/synth.hs 153
-   Queue.T -> Port.T -> time ->
-   IO [StampedEvent time]
-getStampedEventsUntilTime h q p t =
-   fmap (map addStamp) $ getEventsUntilTime h q p t
-
+   Queue.T -> Port.T ->
+   Time -> Time ->
+   IO [StampedEvent]
+getStampedEventsUntilTime h q p r t =
+   fmap (map (addStamp r)) $ getEventsUntilTime h q p r t
hunk ./examples/synth.hs 159
-{- |
-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]
-getEventsUntilEcho c h =
-   let loop = do
-          ev <- Event.input h
-          let abort =
-                 case Event.body ev of
-                    Event.CustomEv Event.Echo _ ->
-                       c == Addr.client (Event.source ev)
-                    _ -> False
-          if abort
-            then
-               case Event.timestamp ev of
-                 Event.RealTime t -> do
-                    putStrLn $ "got Echo at: " ++ show (realTimeToField t :: Double)
-                    return []
-                 _ -> error "unsupported time stamp type"
-            else liftM (ev:) loop
-   in  loop
hunk ./examples/synth.hs 165
-   (RealFrac time,
-    SndSeq.AllowInput mode, SndSeq.AllowOutput mode) =>
+   (SndSeq.AllowInput mode, SndSeq.AllowOutput mode) =>
hunk ./examples/synth.hs 167
-   Queue.T -> Port.T -> time ->
+   Queue.T -> Port.T ->
+   Time -> Time ->
hunk ./examples/synth.hs 170
-getEventsUntilTime h q p t = do
-   putStrLn $ "schedule echo for " ++ show (milliseconds t)
+getEventsUntilTime h q p r t = do
+--   putStrLn $ "schedule echo for " ++ show (milliseconds t)
hunk ./examples/synth.hs 174
-           makeEcho c q p t (Event.Custom 0 0 0)
+           makeEcho c q p
+              (RealTime.fromInteger $ div (t * nano) r)
+              (Event.Custom 0 0 0)
hunk ./examples/synth.hs 182
-   RealFrac time =>
hunk ./examples/synth.hs 183
-   time -> Event.Custom -> Event.T
+   RealTime.T -> Event.Custom -> Event.T
hunk ./examples/synth.hs 189
-      , Event.timestamp =
-           Event.RealTime $ RealTime.fromInteger $
-           floor (10^(9::Int) * t)
+      , Event.timestamp = Event.RealTime t
hunk ./examples/synth.hs 197
+{- |
+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]
+getEventsUntilEcho c h =
+   let loop = do
+          ev <- Event.input h
+          let abort =
+                 case Event.body ev of
+                    Event.CustomEv Event.Echo _ ->
+                       c == Addr.client (Event.source ev)
+                    _ -> False
+          if abort
+            then
+               case Event.timestamp ev of
+                 Event.RealTime t -> do
+--                    putStrLn $ "got Echo at: " ++ show (RealTime.toInteger t :: Double)
+                    return []
+                 _ -> error "unsupported time stamp type"
+            else liftM (ev:) loop
+   in  loop
+
+
hunk ./examples/synth.hs 322
-   [(Int, Event.T)] ->
-   MS.StateT (Int, Map.Map Pitch (OscillatorState a)) m [(Int, SV.Vector a)]
+   [StampedEvent] ->
+   MS.StateT (Time, Map.Map Pitch (OscillatorState a)) m [(Int, SV.Vector a)]
hunk ./examples/synth.hs 353
-                                  (newOsci, stopTone (time-chunkTime) s))
+                                  (newOsci, stopTone time s))
hunk ./examples/synth.hs 355
-                               (Just (time-chunkTime,
+                               (Just (time,
hunk ./examples/synth.hs 371
-                                  (Nothing, stopTone (time-chunkTime) s))
+                                  (Nothing, stopTone time s))
hunk ./examples/synth.hs 377
-             input
+             (map (\(time,ev) -> (fromInteger (time-chunkTime), ev)) input)
hunk ./examples/synth.hs 402
-            let stopTime = startTime+size
+            let stopTime = startTime + fromIntegral size
hunk ./examples/synth.hs 405
-               getStampedEventsUntilTime sq q port
-                  (fromIntegral stopTime / fromIntegral rate)
-            chunks <-
-               processEvents size rate $
-               map (\(t,ev) -> (floor (t*fromIntegral rate :: Double), ev)) evs
+               getStampedEventsUntilTime sq q port (fromIntegral rate) stopTime
+            chunks <- processEvents size rate evs
hunk ./examples/synth.hs 238
-   in  check (start>=0) ("start negative: " ++ show start) $
+   in  check (start>=0)
+                ("start negative: " ++ show (start, SV.length xs)) $
+       check (start <= SVST.length v)
+                ("start too late: " ++ show (start, SV.length xs)) $
hunk ./examples/synth.hs 243
-                ("start too big: " ++ show (start, SV.length xs)) $
+                ("end too late: " ++ show (start, SV.length xs)) $
hunk ./examples/synth.hs 392
+{-
+Caution:
+ - MIDI clock and PCM clock are quite different:
+   After running the synth for about an hour
+   I got messages like "start too late: (8969,0)",
+   that is, the MIDI clock was about 9000/44100 seconds
+   ahead of the PCM clock.
+-}