alsa-pcm-0.5.0.1: examples/synth.hs
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 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
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 Data.Word (Word8, )
import Control.Exception (bracket, )
import Control.Monad (liftM, forever, )
import Debug.Trace (trace, )
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)
1024 64
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
-> Int -- ^ buffer size
-> Int -- ^ period size
-> IO (Int,Int,Int,Int,Int)
-- ^ (bufferTime,bufferSize,periodTime,periodSize)
setHwParams h format channels rate bufferSize periodSize =
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
(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,
actualRate)
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, 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.timestamp ev of
Event.RealTime 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.timestamp = Event.RealTime 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.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
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) =>
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
type Velocity = 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 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 vel =
4 ** ((fromIntegral vel - 64) / 128)
frequencyFromPitch ::
(Floating y) =>
Pitch -> y
frequencyFromPitch 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 == 0
then (Event.NoteOff, 64)
else (Event.NoteOn, velocity)
_ -> (notePart, velocity)
processEvents ::
(Storable a, Floating a, Monad m) =>
Int ->
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 (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 a) =>
Core.Pcm -> SV.Vector a -> IO ()
write h xs =
SVB.withStartPtr xs $ PCM.alsaWrite h
{-
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 0 Nothing
_ <- Event.drainOutput sq
write h (SV.replicate (2*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)