YampaSynth 0.1.2 → 0.2
raw patch · 4 files changed
+51/−62 lines, 4 filesdep ~HCodecs
Dependency ranges changed: HCodecs
Files
- LICENSE +1/−1
- YampaSynth.cabal +17/−10
- src/Player/OpenAL.hs +28/−46
- src/Player/Wav.hs +5/−5
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2007 - 2010, George Giorgidze and Henrik Nilsson+Copyright (c) 2007 - 2014, George Giorgidze and Henrik Nilsson Contributors: Erik Flister All rights reserved.
YampaSynth.cabal view
@@ -1,16 +1,16 @@ name: YampaSynth-version: 0.1.2-cabal-Version: >= 1.2+version: 0.2+cabal-Version: >= 1.6 license: BSD3 license-file: LICENSE-copyright: (c) 2007-2010 George Giorgidze and Henrik Nilsson+copyright: (c) 2007-2014 George Giorgidze and Henrik Nilsson author: George Giorgidze and Henrik Nilsson-maintainer: George Giorgidze (GGG at CS dot NOTT dot AC dot UK)-homepage: http://www.cs.nott.ac.uk/~ggg/+maintainer: George Giorgidze (giorgidze@gmail.com)+homepage: http://www-db.informatik.uni-tuebingen.de/team/giorgidze stability: experimental category: Sound, Music synopsis: Software synthesizer-description: +description: YampaSynth is a software synthesizer implemented in Yampa, domain specific language embedded in Haskell. It contains a little framework of sound generating and sound shaping modules (e.g. oscillator, amplifier, mixer, envelope generator, filter, etc.) and example applications: . * "yampasynth-wav" is an application which synthesizes a MIDI music and writes result into a WAVE audio file.@@ -29,28 +29,35 @@ data-files: gui/YampaSynth.glade, README +source-repository head+ type: git+ location: https://github.com/giorgidze/YampaSynth.git+ flag wav description: Builds yampasynth-wav executable which synthesizes a MIDI music and writes result into a WAVE audio file.+ default: True flag openal description: Builds yampasynth-openal executable which synthesizes MIDI music and sends audio data in real-time to a sound card. We use Haskell binding of OpenAL library as an interface to audio hardware.+ default: False flag gtk description: Builds yampasynth-gtk executable with simple graphical user interface which allows you to play music with various instruments in real-time using keyboard of your computer. We use Haskell binding of GTK library for GUI programming and Haskell binding of OpenAL library as an interface to audio hardware.+ default: False executable yampasynth-wav if flag (wav)- build-depends: base < 5, array, bytestring, containers, Yampa, HCodecs+ build-depends: base < 5, array, bytestring, containers, Yampa, HCodecs >= 0.5 else buildable: False hs-source-dirs: src main-is: Main/Wav.hs- other-modules: SynthBasics, SynthParams, MidiSynth, Player.Wav + other-modules: SynthBasics, SynthParams, MidiSynth, Player.Wav ghc-options: -O3 -Wall executable yampasynth-openal if flag (openal)- build-Depends: base < 5, array, containers, OpenAL, Yampa, HCodecs+ build-Depends: base < 5, array, containers, OpenAL, Yampa, HCodecs >= 0.5 else buildable: False extensions: FlexibleInstances, UndecidableInstances@@ -61,7 +68,7 @@ executable yampasynth-gtk if flag (gtk)- build-Depends: base < 5, array, containers, OpenAL, glade, gtk, Yampa, HCodecs + build-Depends: base < 5, array, containers, OpenAL, glade, gtk, Yampa, HCodecs >= 0.5 else buildable: False extensions: FlexibleInstances, UndecidableInstances
src/Player/OpenAL.hs view
@@ -8,20 +8,19 @@ , Chunk (..) ) where -import Data.Audio+import Foreign (Storable, Ptr, Bits, isSigned, mallocArray, free, pokeElemOff, peekElemOff, sizeOf) import FRP.Yampa--import Sound.OpenAL --import Data.Int()-import Data.IORef-import Foreign-import Control.Concurrent +import Sound.OpenAL+import Control.Concurrent import Control.Monad-import Data.Maybe import Control.Applicative+import Data.Audio+import Data.IORef+import Data.Int+import Data.Maybe + play :: Int -> Int -> Int -> SF () (Sample, Event ()) -> IO () play sampleRate' sampleNumber' numBuffs sf = do (device,context,pSource,pBuffers) <- initOpenAL numBuffs@@ -71,7 +70,7 @@ Nothing -> fail "opening OpenAL device" Just device -> do mContext <- createContext device []- case mContext of + case mContext of Nothing -> fail "opening OpenAL context" Just context -> do currentContext $= Just context@@ -81,7 +80,7 @@ return (device,context,pSource,pBuffers) deInitOpenAL :: Device -> Context -> Source -> [Buffer] -> IO ()-deInitOpenAL device context pSource pBuffers = do +deInitOpenAL device context pSource pBuffers = do dequeue pSource deleteObjectNames [pSource] deleteObjectNames pBuffers@@ -90,23 +89,12 @@ whenM (not <$> closeDevice device) $ fail "closing OpenAL device" printErrs -data Chunkable a => Chunk a = Chunk {- chunkData :: Ptr a- , numElems :: Int- } deriving (Eq, Show)-- -- 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+data Chunk a = Chunk { chunkData :: Ptr a+ , numElems :: Int+ } deriving (Eq, Show) -lastInd :: (Chunkable a) => (a -> Bool) -> Chunk a -> IO (Maybe Int)-lastInd p c = do +lastInd :: (Storable 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)@@ -114,16 +102,15 @@ (numElems c - 1,Nothing) return $ (+ 1) <$> mInd -process :: (Chunkable a) => Int -> Source -> [Buffer] -> [Buffer] -> MVar (Maybe (Chunk a)) -> MVar () -> IO ()+process :: (Storable a, Bits a) => Int -> Source -> [Buffer] -> [Buffer] -> MVar (Maybe (Chunk a)) -> MVar () -> IO () process sampleRate' pSource freeBuffers usedBuffers mVarMaybeChunk mVarReply = do mChunk <- takeMVar mVarMaybeChunk- Foreign.void $ reply mChunk (\chunk -> do+ 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 + (f,u) <- reply mInd (\ind -> do+ (buff,newFree,newUsed) <- if null freeBuffers then do waitForBuffer pSource- let b = head usedBuffers- unqueueBuffers pSource [b]+ [b] <- unqueueBuffers pSource (1 :: ALsizei) return (b,[],tail usedBuffers ++ [b]) else do let h = head freeBuffers return (h, tail freeBuffers, usedBuffers ++ [h])@@ -147,7 +134,7 @@ dequeue :: Source -> IO () dequeue pSource = waitForSource pSource >> buffer pSource $= Nothing -createBufferData :: (Chunkable a) => Int -> Chunk a -> Int -> IO (BufferData a)+createBufferData :: (Storable a, Bits a) => Int -> Chunk a -> Int -> IO (BufferData a) createBufferData sampleRate' chunk n = do ex <- peekElemOff (chunkData chunk) 0 let elemSize = sizeOf ex@@ -160,24 +147,19 @@ 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 = whenM ((== Playing) <$> (get $ sourceState pSource)) delWait where delWait = do threadDelay 10 -- micro seconds waitForSource pSource++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++whenM :: (Monad m, Functor m) => m Bool -> m () -> m ()+whenM test action = join $ flip when action <$> test
src/Player/Wav.hs view
@@ -2,7 +2,7 @@ import Data.Audio import Codec.Wav-import Data.ByteString.Builder+import Codec.ByteString.Builder import FRP.Yampa @@ -32,13 +32,13 @@ hClose h correctWavHeader filePath -correctWavHeader :: FilePath -> IO () +correctWavHeader :: FilePath -> IO () correctWavHeader filePath = do h <- openFile filePath ReadWriteMode hSetBuffering h NoBuffering s <- hFileSize h- hSeek h AbsoluteSeek 0x04 + hSeek h AbsoluteSeek 0x04 hPut h (toLazyByteString $ putWord32le $ fromIntegral $ s - 0x04 - 4)- hSeek h AbsoluteSeek 0x28 - hPut h (toLazyByteString $ putWord32le $ fromIntegral $ s - 0x28 - 4) + hSeek h AbsoluteSeek 0x28+ hPut h (toLazyByteString $ putWord32le $ fromIntegral $ s - 0x28 - 4) hClose h