YampaSynth 0.1 → 0.1.1
raw patch · 6 files changed
+186/−159 lines, 6 files
Files
- LICENSE +1/−0
- YampaSynth.cabal +3/−1
- src/Main/Gtk.hs +1/−1
- src/Main/OpenAL.hs +36/−11
- src/Player/Gtk.hs +13/−63
- src/Player/OpenAL.hs +132/−83
LICENSE view
@@ -1,4 +1,5 @@ Copyright (c) 2007 - 2010, George Giorgidze and Henrik Nilsson+Contributors: Erik Flister All rights reserved.
YampaSynth.cabal view
@@ -1,5 +1,5 @@ name: YampaSynth-version: 0.1+version: 0.1.1 cabal-Version: >= 1.2 license: BSD3 license-file: LICENSE@@ -53,6 +53,7 @@ build-Depends: base < 5, array, containers, OpenAL, Yampa, HCodecs else buildable: False+ extensions: FlexibleInstances, UndecidableInstances hs-source-dirs: src main-is: Main/OpenAL.hs other-modules: SynthBasics, SynthParams, MidiSynth, Player.OpenAL@@ -63,6 +64,7 @@ build-Depends: base < 5, array, containers, OpenAL, glade, gtk, Yampa, HCodecs else buildable: False+ extensions: FlexibleInstances, UndecidableInstances hs-source-dirs: src main-is: Main/Gtk.hs other-modules: SynthBasics, SynthParams, MidiSynth, Player.OpenAL, Player.Gtk
src/Main/Gtk.hs view
@@ -45,5 +45,5 @@ putStrLn "If you are getting interruptions decrase sampling rate." let paramsGen = soundFontToSynthParams soundFont- Player.Gtk.play sampleRate' (1024) (midiSynth paramsGen)+ Player.Gtk.play sampleRate' 512 2 (midiSynth paramsGen) putStrLn "Done."
src/Main/OpenAL.hs view
@@ -13,11 +13,13 @@ import System.Environment import System.Console.GetOpt +import Control.Monad+import Control.Applicative+ data Flag = SampleRate String | SoundFontFile FilePath | MidiFile FilePath- | Output FilePath deriving Show options :: [OptDescr Flag]@@ -33,15 +35,36 @@ main :: IO () main = do argv <- getArgs- (sampleRate', soundFontFile, midiFile) <-- case getOpt Permute options argv of- ([SampleRate srs, SoundFontFile sf, MidiFile mf], _,_) -> do- sr <- case (readDec srs) of- [] -> fail "SAMPLERATE must be a decimal integer number"- (i,_) : _ -> return i- return (sr, sf, mf)- _ -> fail $ usageInfo "all options are mandatory\n" options+ let (opts,nopts,errs) = getOpt Permute options argv+ printErrs "not valid options" nopts+ mapM_ putStrLn errs+ when (not $ null errs) . ioError . userError $ concat errs ++ usageInfo "aborting" options+ go . concat $ [getSampleRate, getSoundFontFile, getMidiFile] <*> opts +printErrs :: String -> [String] -> IO ()+printErrs s x = when (not $ null x) . putStrLn $ s ++ ": " ++ show x++-- the record transformer approach described here is probably a better way to achieve option order insensitivity+-- http://haskell.org/ghc/docs/6.12.1/html/libraries/base-4.2.0.0/System-Console-GetOpt.html#4++getSampleRate :: MonadPlus m => Flag -> m String+getSampleRate (SampleRate x) = return x+getSampleRate _ = mzero++getSoundFontFile :: MonadPlus m => Flag -> m FilePath+getSoundFontFile (SoundFontFile x) = return x+getSoundFontFile _ = mzero++getMidiFile :: MonadPlus m => Flag -> m FilePath+getMidiFile (MidiFile x) = return x+getMidiFile _ = mzero++go :: [String] -> IO ()+go [srs, soundFontFile, midiFile] = do+ sampleRate' <- case (readDec srs) of+ [] -> fail "SAMPLERATE must be a positive decimal integer number"+ (i,_) : _ -> (putStrLn $ show i) >> return i+ hPutStrLn stderr "Importing MIDI File ..." eMidi <- Midi.importFile midiFile midi <- case eMidi of@@ -60,5 +83,7 @@ hPutStrLn stderr "If you are getting interruptions decrase sampling rate." let paramsGen = soundFontToSynthParams soundFont signalFunction = midiToEventSource midi >>> midiSynth paramsGen- Player.OpenAL.play sampleRate' (64 * 1024) signalFunction- hPutStrLn stderr "Done."+ Player.OpenAL.play sampleRate' (1 * 1024) 2 signalFunction+ putStrLn "Done."++go _ = fail $ usageInfo "all options are mandatory\n" options
src/Player/Gtk.hs view
@@ -4,27 +4,23 @@ import Player.OpenAL -import Codec.Midi-import Data.Audio- import FRP.Yampa -import Data.Int-import qualified Data.Map as Map+import Data.Audio+import Codec.Midi+ import Data.IORef+import qualified Data.Map as Map import Control.Concurrent-import Foreign.Storable-import Foreign.Marshal.Alloc+import Control.Applicative import Graphics.UI.Gtk hiding (eventKeyName) import Graphics.UI.Gtk.Gdk.Events hiding (Event) import Graphics.UI.Gtk.Glade -import Sound.OpenAL--play :: Int -> Int -> SF (Event [Message]) (Sample, Event ()) -> IO ()-play sampleRate' sampleNumber' synth = do- (device,context,pSource,pBuffer) <- initOpenAL+play :: Int -> Int -> Int -> SF (Event [Message]) (Sample, Event ()) -> IO ()+play sampleRate' sampleNumber' numBuffs synth = do+ (device,context,pSource,pBuffers) <- initOpenAL numBuffs mVarMessage <- newEmptyMVar mVarReplyGui <- newEmptyMVar mVarKeyboardActive <- newEmptyMVar@@ -37,7 +33,7 @@ window <- xmlGetWidget xml castToWindow "window1" _ <- onDestroy window $ do- deInitOpenAL device context pSource pBuffer+ deInitOpenAL device context pSource pBuffers mainQuit let onKeyPressWindow e = do@@ -84,8 +80,10 @@ widgetSetSensitivity stopButton False _ <- onClicked playButton $ do- _ <- forkIO $ runSynth sampleRate' sampleNumber' pSource pBuffer- mVarMessage mVarReplyGui synth+ _ <- forkIO $ do frpSynth sampleRate' pSource pBuffers sampleNumber' synth noEvent $ + maybe noEvent (Event . (:[])) <$> tryTakeMVar mVarMessage+ putMVar mVarReplyGui ()+ widgetSetSensitivity playButton False widgetSetSensitivity stopButton True i <- comboBoxGetActive combobox@@ -103,54 +101,6 @@ widgetShowAll window mainGUI--runSynth :: Int -> Int -> Source -> Buffer -> MVar Message -> MVar ()- -> SF (Event [Message]) (Sample, Event ()) -> IO ()-runSynth sampleRate' sampleNumber' pSource pBuffer mVarMessage mVarReplyGui synth = do-- mVarMaybeChunk <- newEmptyMVar- mVarReplyPlayer <- newEmptyMVar-- _ <- forkIO $ process sampleRate' pSource pBuffer mVarMaybeChunk mVarReplyPlayer-- ir <- newIORef (0 :: Int)- let sampleSize = sizeOf (undefined :: Int16)- chunkSize' = sampleNumber' * sampleSize- chunkData' <- mallocBytes chunkSize'-- let chunk = Chunk chunkData' chunkSize'- sense _ = do- let dt = 1.0 / fromIntegral sampleRate'- maybeMsg <- tryTakeMVar mVarMessage- case maybeMsg of- Nothing -> return (dt, Just noEvent)- Just msg -> return (dt, Just (Event [msg]))- actuate _ (s,e) = if (isEvent e)- then return True- else do- i <- readIORef ir- pokeElemOff (chunkData chunk) i (fromSample s)- if i == (sampleNumber' - 1)- then do- putMVar mVarMaybeChunk (Just chunk)- takeMVar mVarReplyPlayer- writeIORef ir 0- return False- else do- writeIORef ir (i + 1)- return False-- reactimate (return noEvent) sense actuate synth-- i <- readIORef ir- putMVar mVarMaybeChunk (Just $ chunk {chunkSize = i * sampleSize})- takeMVar mVarReplyPlayer- putMVar mVarMaybeChunk Nothing- takeMVar mVarReplyPlayer-- free (chunkData chunk)- putMVar mVarReplyGui ()- str2key :: String -> Key str2key s = case s of
src/Player/OpenAL.hs view
@@ -1,8 +1,10 @@+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}+ module Player.OpenAL ( Player.OpenAL.play , initOpenAL , deInitOpenAL- , process+ , frpSynth , Chunk (..) ) where @@ -12,65 +14,58 @@ import Sound.OpenAL -import Data.Int+import Data.Int() import Data.IORef-import Foreign.Storable-import Foreign.Marshal.Alloc-import Foreign.Ptr+import Foreign import Control.Concurrent +import Control.Monad+import Data.Maybe+import Control.Applicative -play ::Int -> Int -> SF () (Sample, Event ()) -> IO ()-play sampleRate' sampleNumber' sf = do- mVarEnd <- newEmptyMVar- _ <- forkIO $ (play' sampleRate' sampleNumber' sf) >> putMVar mVarEnd ()- takeMVar mVarEnd- return ()+play :: Int -> Int -> Int -> SF () (Sample, Event ()) -> IO ()+play sampleRate' sampleNumber' numBuffs sf = do+ (device,context,pSource,pBuffers) <- initOpenAL numBuffs+ frpSynth sampleRate' pSource pBuffers sampleNumber' sf () (return ())+ deInitOpenAL device context pSource pBuffers -play' ::Int -> Int -> SF () (Sample, Event ()) -> IO ()-play' sampleRate' sampleNumber' sf = do- (device,context,pSource,pBuffer) <- initOpenAL- +frpSynth :: Int -> Source -> [Buffer] -> Int -> SF a (Sample, Event b) -> a -> IO a -> IO ()+frpSynth sampleRate' pSource pBuffers sampleNumber' sf ret senseEvt = do mVarMaybeChunk <- newEmptyMVar- mVarReply <- newEmptyMVar- - _ <- forkIO $ process sampleRate' pSource pBuffer mVarMaybeChunk mVarReply+ mVarReplyPlayer <- newEmptyMVar + _ <- forkIO $ process sampleRate' pSource pBuffers [] mVarMaybeChunk mVarReplyPlayer+ ir <- newIORef (0 :: Int)- let sampleSize = sizeOf (undefined :: Int16)- chunkSize' = sampleNumber' * sampleSize- chunkData' <- mallocBytes chunkSize' - let chunk = Chunk chunkData' chunkSize' - sense _ = return (1.0 / fromIntegral sampleRate', Just ())+ chunkData' <- mallocArray sampleNumber'+ let sense = (\x -> (1.0 / fromIntegral sampleRate', x)) . Just <$> senseEvt -- ghc 6.12 required for TupleSections :(+ chunk = Chunk chunkData' sampleNumber' actuate _ (s,e) = if (isEvent e) then return True else do i <- readIORef ir- pokeElemOff (chunkData chunk) i (fromSample s)- if i == (sampleNumber' - 1)- then do- putMVar mVarMaybeChunk (Just chunk)- takeMVar mVarReply- writeIORef ir 0- return False- else do- writeIORef ir (i + 1)- return False+ let samp = fromSample s :: Int16 -- the only place we have to specify our sample representation+ when (i /= 0 || samp /= 0) $ do -- don't put leading zeros in a chunk+ pokeElemOff chunkData' i samp+ if i == (sampleNumber' - 1)+ then do+ putMVar mVarMaybeChunk $ Just chunk+ takeMVar mVarReplyPlayer+ writeIORef ir 0+ else writeIORef ir (i + 1)+ return False - reactimate (return ()) sense actuate sf+ reactimate (return ret) (const sense) actuate sf i <- readIORef ir- putMVar mVarMaybeChunk (Just $ chunk {chunkSize = i * sampleSize})- takeMVar mVarReply+ putMVar mVarMaybeChunk . Just $ chunk {numElems = i}+ takeMVar mVarReplyPlayer putMVar mVarMaybeChunk Nothing- takeMVar mVarReply-- deInitOpenAL device context pSource pBuffer- free (chunkData chunk)+ takeMVar mVarReplyPlayer+ free chunkData' - -initOpenAL :: IO (Device, Context, Source, Buffer)-initOpenAL = do+initOpenAL :: Int -> IO (Device, Context, Source, [Buffer])+initOpenAL numBuffs = do mDevice <- openDevice Nothing case mDevice of Nothing -> fail "opening OpenAL device"@@ -81,54 +76,108 @@ Just context -> do currentContext $= Just context [pSource] <- genObjectNames 1- [pBuffer] <- genObjectNames 1- queueBuffers pSource [pBuffer]- return (device,context,pSource,pBuffer)+ pBuffers <- genObjectNames numBuffs+ printErrs+ return (device,context,pSource,pBuffers) -deInitOpenAL :: Device -> Context -> Source -> Buffer -> IO ()-deInitOpenAL device context pSource pBuffer = do - unqueueBuffers pSource [pBuffer]+deInitOpenAL :: Device -> Context -> Source -> [Buffer] -> IO ()+deInitOpenAL device context pSource pBuffers = do + dequeue pSource deleteObjectNames [pSource]- deleteObjectNames [pBuffer]+ deleteObjectNames pBuffers currentContext $= Nothing destroyContext context- b <- closeDevice device- case b of- True -> return ()- False -> fail "closing OpenAL device"+ whenM (not <$> closeDevice device) $ fail "closing OpenAL device"+ printErrs -data Chunk = Chunk {- chunkData :: Ptr Int16- , chunkSize :: Int+data Chunkable a => Chunk a = Chunk {+ chunkData :: Ptr a+ , numElems :: Int } deriving (Eq, Show) -process :: Int -> Source -> Buffer -> MVar (Maybe Chunk) -> MVar () -> IO ()-process sampleRate' pSource pBuffer mVarMaybeChunk mVarReply = do+ -- does the Bits constraint basically guarantee that it's Integral?+class (Storable a, Bits a, Audible a) => Chunkable a where++instance (Storable a, Bits a, Audible a) => Chunkable a -- thx copumpkin @ #haskell++-- from http://www.haskell.org/pipermail/beginners/2009-January/000690.html (via byorgey @ #haskell)+untilM :: (Monad m) => (a -> Bool) -> (a -> m a) -> a -> m a+untilM p f x | p x = return x+ | otherwise = f x >>= untilM p f++lastInd :: (Chunkable a) => (a -> Bool) -> Chunk a -> IO (Maybe Int)+lastInd p c = do + (_,mInd) <- untilM (\(i,x) -> isJust x || i < 0)+ (\(i,_) -> do e <- peekElemOff (chunkData c) i+ return (i-1, if p e then Just i else Nothing)+ )+ (numElems c - 1,Nothing)+ return $ (+ 1) <$> mInd++process :: (Chunkable a) => Int -> Source -> [Buffer] -> [Buffer] -> MVar (Maybe (Chunk a)) -> MVar () -> IO ()+process sampleRate' pSource freeBuffers usedBuffers mVarMaybeChunk mVarReply = do mChunk <- takeMVar mVarMaybeChunk- case mChunk of- Nothing -> do- waitForSource pSource- putMVar mVarReply ()- Just chunk -> do- unqueueBuffers pSource [pBuffer]- (bufferData pBuffer) $= createBufferData sampleRate' chunk- putMVar mVarReply ()- queueBuffers pSource [pBuffer]- Sound.OpenAL.play [pSource]- waitForSource pSource- process sampleRate' pSource pBuffer mVarMaybeChunk mVarReply+ void $ reply mChunk (\chunk -> do+ mInd <- lastInd (/= 0) chunk -- we aren't sent chunks with leading zeros+ (f,u) <- reply mInd (\ind -> do + (buff,newFree,newUsed) <- if null freeBuffers + then do waitForBuffer pSource+ let b = head usedBuffers+ unqueueBuffers pSource [b]+ return (b,[],tail usedBuffers ++ [b])+ else do let h = head freeBuffers+ return (h, tail freeBuffers, usedBuffers ++ [h])+ ((bufferData buff) $=) =<< createBufferData sampleRate' chunk ind+ _ <- reply Nothing undefined+ queueBuffers pSource [buff]+ whenM ((/= Playing) <$> (get $ sourceState pSource)) $ Sound.OpenAL.play [pSource]+ printErrs+ return (newFree,newUsed)+ )+ process sampleRate' pSource f u mVarMaybeChunk mVarReply+ return (undefined,undefined)+ )+ dequeue pSource+ where reply = flip . maybe $ putMVar mVarReply undefined >> return (freeBuffers,usedBuffers) -createBufferData :: Int -> Chunk -> BufferData Int16-createBufferData sampleRate' chunk =- BufferData (MemoryRegion (chunkData chunk) (fromIntegral $ chunkSize chunk))- Mono16- (fromIntegral sampleRate')+printErrs :: IO ()+printErrs = do e <- get alErrors+ when (not $ null e) . putStrLn $ show e +dequeue :: Source -> IO ()+dequeue pSource = waitForSource pSource >> buffer pSource $= Nothing++createBufferData :: (Chunkable a) => Int -> Chunk a -> Int -> IO (BufferData a)+createBufferData sampleRate' chunk n = do+ ex <- peekElemOff (chunkData chunk) 0+ let elemSize = sizeOf ex+ format = case elemSize of+ 2 -> Mono16+ 1 -> Mono8+ _ -> error "1 or 2 byte buffer required"+ when (not $ isSigned ex) $ fail "signed buffer required" -- how enforce these statically?+ return $ BufferData (MemoryRegion (chunkData chunk) (fromIntegral $ n * elemSize))+ format+ (fromIntegral sampleRate')++{-+untilM_ :: (Functor m, Monad m) => (a -> Bool) -> m a -> m ()+-- untilM_ p f = void $ untilM p (const f) undefined -- isn't there something in this spirit?+untilM_ p f = do b <- p <$> f+ if b then return () else untilM_ p f++void :: (Monad m) => m a -> m ()+void = (>> return ())+-}++waitForBuffer :: Source -> IO () -- better to express using untilM_+waitForBuffer s = do b <- (> 0) <$> (get $ buffersProcessed s)+ if b then return () else threadDelay 10 >> waitForBuffer s++whenM :: (Monad m, Functor m) => m Bool -> m () -> m ()+whenM test action = join $ flip when action <$> test+ waitForSource :: Source -> IO ()-waitForSource pSource = do- state <- get (sourceState pSource)- case state of- Playing -> do- threadDelay 10 -- micro seconds- waitForSource pSource- _ -> return ()+waitForSource pSource = whenM ((== Playing) <$> (get $ sourceState pSource)) delWait+ where delWait = do threadDelay 10 -- micro seconds+ waitForSource pSource