-- must be compiled with the threaded runtime! module Main where import Control.Monad import Control.Concurrent import Data.Maybe import Foreign import Foreign.C import Foreign.StablePtr import System.IO.Unsafe import System.MacOSX.CoreFoundation import System.MacOSX.CoreAudio -------------------------------------------------------------------------------- bufSize = 2048 :: Int sampleRate = 48000 :: Int -------------------------------------------------------------------------------- myAudioDeviceIOProc :: BufferFillCallback a -> AudioDeviceIOProc Float () myAudioDeviceIOProc filler dev pnow pinbufl pintime poutbufl pouttime pclient = do (mvtick,userdata) <- deRefStablePtr (castPtrToStablePtr pclient) AudioBufferList inbufl <- peekAudioBufferList pinbufl AudioBufferList outbufl <- peekAudioBufferList poutbufl let outbuf = head outbufl nch = fromIntegral $ ab_NumberChannels outbuf siz = fromIntegral $ ab_DataByteSize outbuf q = ab_Data outbuf :: Ptr Float let nframes = fromIntegral (siz `div` (4*nch)) -- 4 = sizeOf Float32 tick <- takeMVar mvtick putMVar mvtick (tick + nframes) filler nch q nframes userdata return 0 -- | the arguments are: -- -- * @Int@ -- number of channels; -- -- * @Ptr Float@ -- you should put the data here... -- -- * @Int@ -- ...this many frames; -- -- * @a@ -- you can supply some additional data to the callback function. -- type BufferFillCallback a = Int -- number of channels; -> Ptr Float -- you should put the data here... -> Int -- ...this many frames; -> a -- you can supply some additional data to the callback function. -> IO () -- | Initializes the device for audio playback. -- The ticks are updated with the same granularity as the buffer size. initAudioDeviceIOProc :: Device -- ^ the audio device -> BufferFillCallback a -- ^ callback -- do we need a StablePtr here or not, that is the question...? -> a -- ^ you can supply some additional data to the callback function -> IO ( MVar Int , IO () , IO () ) -- ^ first is a variable storing the number of frames (=samples) passed; second and third are start and stop actions. initAudioDeviceIOProc device filler userdata = do tick <- newMVar 0 client <- newStablePtr (tick,userdata) -- !!! proc <- mkAudioDeviceIOProc (myAudioDeviceIOProc filler) os <- audioDeviceAddIOProc device proc (castStablePtrToPtr client) when (os /= 0) $ error "attaching our IOProc failed" let start = audioDeviceStart device proc >> return () let stop = audioDeviceStop device proc >> return () return ( tick , start , stop ) -------------------------------------------------------------------------------- frameCounter = unsafePerformIO (newMVar 0) :: MVar Int fillMono :: Int -> Ptr Float -> Int -> IO () fillMono c buf nframes = do forM_ [0..nframes-1] $ \i -> do let k = fromIntegral i :: Int x = fromIntegral (c+i) / fromIntegral sampleRate :: Float y = sin ( x * 440.0 * 6.2830 + 100.0 * sin ( x*10.0) ) pokeElemOff buf k y fillStereo :: Int -> Ptr Float -> Int -> IO () fillStereo c buf nframes = do c <- readMVar frameCounter forM_ [0..nframes-1] $ \i -> do let k = fromIntegral (i+i) :: Int x = fromIntegral (c+i) / fromIntegral sampleRate :: Float y = sin ( x * 440.0 * 6.2830 + 100.0 * sin ( x*10.0) ) pokeElemOff buf (k ) y -- left channel pokeElemOff buf (k+1) y -- right channel fillAudioBuffer :: BufferFillCallback () fillAudioBuffer nchn ptr nframes _ = do c <- readMVar frameCounter case nchn of 1 -> fillMono c ptr nframes 2 -> fillStereo c ptr nframes _ -> error "too many channels" swapMVar frameCounter (c+nframes) return () -------------------------------------------------------------------------------- -- misc waitFor :: IO Bool -> IO () waitFor cond = do b <- cond unless b $ do threadDelay 1000 -- 1 ms waitFor cond maybeRead :: Read a => String -> Maybe a maybeRead s = case reads s of [(x,"")] -> Just x _ -> Nothing -- main selectDevice :: Direction -> IO Device selectDevice In = selectDevice' True selectDevice Out = selectDevice' False selectDevice' :: Bool -> IO Device selectDevice' isInput = do let dir = (if isInput then fst else snd) devices <- enumerateAudioDevices let ndev1 = length devices list1 <- forM devices $ \dev -> do name <- audioDeviceName dev streams <- enumerateAudioStreams dev return (dev,name,streams) let list2 = [ (dev,name) | (dev,name,str) <- list1 , dir str /= [] ] ndev2 = length list2 (dev,name) <- case ndev2 of 0 -> do error "no audio devices found :(" 1 -> return (head list2) _ -> do putStrLn "please select a sound device:" forM_ (zip [1..] list2) $ \(i,(_,name)) -> putStrLn $ show i ++ ": " ++ name l <- getLine let k = case maybeRead l of { Nothing -> 1 ; Just n -> if n<1 || n>ndev2 then 1 else n } return $ list2 !! (k-1) putStrLn $ "selected device = " ++ show name return dev checkTick :: MVar Int -> Int -> IO Bool checkTick mvar seconds = do tick <- readMVar mvar return (tick > sampleRate*seconds) main = do dev <- selectDevice Out name <- liftM fromJust $ audioDeviceGetPropertyString dev 0 Out "name" bufsizerange <- liftM fromJust $ audioDeviceGetProperty dev 0 Out "fsz#" :: IO AudioValueRange audioDeviceSetProperty dev 0 Out "fsiz" (fromIntegral bufSize :: UInt32) -- 2048/44100 ~= 46 milisecs bufsize <- liftM fromJust $ audioDeviceGetProperty dev 0 Out "fsiz" :: IO UInt32 nsrlist <- liftM fromJust $ audioDeviceGetPropertyList dev 0 Out "nsr#" :: IO [AudioValueRange] audioDeviceSetProperty dev 0 Out "nsrt" (fromIntegral sampleRate :: Double) nsr <- liftM fromJust $ audioDeviceGetProperty dev 0 Out "nsrt" :: IO Double putStrLn $ "audio device name = " ++ name putStrLn $ "initial buffer size = " ++ show bufsize putStrLn $ "buffer size range = " ++ show bufsizerange putStrLn $ "new buffer size = " ++ show bufsize putStrLn $ "available sample rates = " ++ show nsrlist putStrLn $ "nominal sample rate = " ++ show nsr ( ticksMVar , startAudio , stopAudio ) <- initAudioDeviceIOProc dev fillAudioBuffer () startAudio waitFor (checkTick ticksMVar 10) stopAudio putStrLn "ok"