alsa-pcm-0.6: examples/synth.hs
import qualified Sound.ALSA.PCM.Node.ALSA as PCM
import qualified Sound.ALSA.PCM.Parameters.Software as SwParam
import qualified Sound.ALSA.PCM.Parameters.Hardware as HwParam
import qualified Sound.ALSA.PCM.Debug as Debug
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.InfoMonad as PortInfo
import qualified Sound.ALSA.Sequencer.Event as Event
import qualified Sound.ALSA.Sequencer.Queue as Queue
import qualified Sound.ALSA.Sequencer.Time as Time
import qualified Sound.ALSA.Sequencer.RealTime as RealTime
import qualified Sound.ALSA.Sequencer as SndSeq
import Sound.ALSA.Sequencer.Event (Pitch, Velocity, )
import qualified Data.StorableVector.ST.Strict as SVST
import qualified Data.StorableVector as SV
import qualified Data.StorableVector.Base as SVB
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 Control.Exception (bracket, )
import Control.Monad (liftM, forever, )
import Debug.Trace (trace, )
openPCM ::
(PCM.Access i, PCM.SampleFmt y) =>
IO (PCM.Size, PCM.SampleFreq, PCM.Handle i y)
openPCM = do
Debug.put "alsaOpenTest"
(((bufferSize,periodSize),(bufferTime,periodTime),sampleRate), h) <-
PCM.open (PCM.modes []) PCM.StreamPlayback
(setHwParams 44100 1024 64)
(\q@(sizes,_,_) -> do
uncurry SwParam.setBufferSize sizes
return q)
"default"
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 :: (PCM.Size, PCM.SampleFreq, PCM.Handle i y) -> IO ()
closePCM (_,_,pcm) = do
Debug.put "alsaClose"
PCM.drain pcm
PCM.close pcm
setHwParams ::
PCM.SampleFreq -- ^ sample frequency
-> PCM.Size -- ^ buffer size
-> PCM.Size -- ^ period size
-> HwParam.T i y ((PCM.Size,PCM.Size),(PCM.Time,PCM.Time),PCM.SampleFreq)
-- ^ ((bufferSize,periodSize),(bufferTime,periodTime),sampleRate)
setHwParams rate bufferSize periodSize = do
{-
(actualRate,ord) <- HwParam.getRateMax
print ord
-}
HwParam.setRateResample False
(actualRate,_) <-
HwParam.setRateNear rate EQ
(actualPeriodSize,_) <-
HwParam.setPeriodSizeNear periodSize EQ
actualBufferSize <-
HwParam.setBufferSizeNear
(max bufferSize (actualPeriodSize*2))
{-
let actualBufferSize = bufferSize
HwParam.setBufferSize bufferSize
-}
(actualBufferTime,_) <- HwParam.getBufferTime
(actualPeriodTime,_) <- HwParam.getPeriodTime
return ((actualBufferSize, actualPeriodSize),
(actualBufferTime, actualPeriodTime),
actualRate)
setTimestamping ::
SndSeq.T mode -> Port.T -> Queue.T -> IO ()
setTimestamping h p q =
PortInfo.modify h p $ do
PortInfo.setTimestamping True
PortInfo.setTimestampReal True
PortInfo.setTimestampQueue q
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, Event.T)
type Time = Integer
{- |
RealTime.toFractional for NumericPrelude.
realTimeToField :: (Fractional a) => RealTime.T -> a
realTimeToField (RealTime.Cons s n) =
fromIntegral s + fromIntegral n / (10^(9::Int))
-}
addStamp ::
Time -> Event.T -> StampedEvent
addStamp rate ev =
(case Event.time ev of
Time.Cons Time.Absolute (Time.Real t) ->
div (RealTime.toInteger t * rate) nano
_ -> error "unsupported time stamp type",
ev)
nano :: Integer
nano = 10^(9::Int)
{- | only use it for blocking sequencers -}
getStampedEventsUntilTime ::
(SndSeq.AllowInput mode, SndSeq.AllowOutput mode) =>
SndSeq.T mode ->
Queue.T -> Port.T ->
Time -> Time ->
IO [StampedEvent]
getStampedEventsUntilTime h q p r t =
fmap (map (addStamp r)) $ getEventsUntilTime h q p r t
{- |
Get events until a certain point in time.
It sends itself an Echo event in order to measure time.
-}
getEventsUntilTime ::
(SndSeq.AllowInput mode, SndSeq.AllowOutput mode) =>
SndSeq.T mode ->
Queue.T -> Port.T ->
Time -> Time ->
IO [Event.T]
getEventsUntilTime h q p r t = do
-- putStrLn $ "schedule echo for " ++ show (milliseconds t)
c <- Client.getId h
_ <- Event.output h $
makeEcho c q p
(RealTime.fromInteger $ div (t * nano) r)
(Event.Custom 0 0 0)
_ <- Event.drainOutput h
getEventsUntilEcho c h
makeEcho ::
Client.T -> Queue.T -> Port.T ->
RealTime.T -> 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.time = Time.consAbs $ Time.Real t
, Event.dest = Addr.Cons {
Addr.client = c,
Addr.port = p
}
}
{- |
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.time ev of
Time.Cons Time.Absolute (Time.Real _t) -> do
-- putStrLn $ "got Echo at: " ++ show (RealTime.toInteger t :: Double)
return []
_ -> error "unsupported time stamp type"
else liftM (ev:) loop
in loop
check :: Monad m => Bool -> String -> m () -> m ()
check b msg act =
if not b
then trace msg $ return ()
else act
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 check (start>=0)
("start negative: " ++ show (start, SV.length xs)) $
check (start <= SVST.length v)
("start too late: " ++ show (start, SV.length xs)) $
check (start+SV.length xs <= SVST.length v)
("end too late: " ++ show (start, SV.length xs)) $
go start 0
arrange ::
(Storable a, Num a) =>
PCM.Size ->
[(Int, SV.Vector a)] ->
SV.Vector a
arrange size evs =
SVST.runSTVector (do
v <- SVST.new (fromIntegral size) 0
mapM_ (uncurry $ unsafeAddChunkToBuffer v) evs
return v)
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 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))
amplitudeFromVelocity ::
(Floating y) =>
Velocity -> y
amplitudeFromVelocity (Event.Velocity vel) =
4 ** ((fromIntegral vel - 64) / 128)
frequencyFromPitch ::
(Floating y) =>
Pitch -> y
frequencyFromPitch (Event.Pitch pitch) =
440 * 2 ** (fromIntegral (fromIntegral pitch + 3 - 6*12 :: Int) / 12)
normalizeNote :: Event.NoteEv -> Event.Note -> (Event.NoteEv, Velocity)
normalizeNote notePart note =
case Event.noteVelocity note of
velocity ->
case notePart of
Event.NoteOn ->
if velocity == Event.offVelocity
then (Event.NoteOff, Event.normalVelocity)
else (Event.NoteOn, velocity)
_ -> (notePart, velocity)
processEvents ::
(Storable a, Floating a, Monad m) =>
PCM.Size ->
PCM.SampleFreq ->
[StampedEvent] ->
MS.StateT (Time, 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 (fromIntegral 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 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 s))
(Event.noteNote note)
(Just (time,
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 s))
(Event.noteNote note)
oscis
_ -> oscis
_ -> oscis)
(fmap (\s -> (Just (0, s), [])) oscis0)
(map (\(time,ev) -> (fromInteger (time-chunkTime), ev)) input)
MS.put (chunkTime, Map.mapMaybe fst pendingOscis)
return (concatMap snd $ Map.elems pendingOscis)
write ::
(PCM.SampleFmt y) =>
PCM.Handle PCM.Interleaved y -> SV.Vector y -> IO ()
write h xs =
SVB.withStartPtr xs $ \buf ->
fmap (const ()) . PCM.writeiRetry h buf . fromIntegral
{-
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.
-}
main :: IO ()
main =
bracket openPCM closePCM $ \(size,rate,h) -> do
putStrLn $ "period size: " ++ show size
putStrLn $ "sample rate: " ++ show rate
withInPort SndSeq.Block $ \sq port ->
Queue.with sq $ \ q ->
do setTimestamping sq port q
Queue.control sq q Event.QueueStart Nothing
_ <- Event.drainOutput sq
write h (SV.replicate (2 * fromIntegral size) 0 :: SV.Vector Float)
flip MS.evalStateT (0,Map.empty) $ forever $ do
startTime <- MS.gets fst
let stopTime = startTime + fromIntegral size
evs <-
liftIO $
getStampedEventsUntilTime sq q port (fromIntegral rate) stopTime
chunks <- processEvents size rate evs
liftIO $
write h (arrange size chunks :: SV.Vector Float)
MS.modify $ \(_,ss) -> (stopTime, ss)