diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,12 @@ # Revision history for lambdasound +## 1.1.0 -- 2023-10-16 + +* Add an example to showcase `loadSound` +* Support loading of wav and raw files as `Sound` +* Fix pathological behavior for repeated cached sounds +* Add `embedIO` to embed IO into sound generation + ## 1.0.1 -- 2023-10-13 * Add `withSampledSound` and `withSampledSoundPulse` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -74,6 +74,8 @@ - Cut apart sounds with `takeSound` and `dropSound` - Scaling playing speed - Cache expensive to compute sounds in your XDG-cache directory +- Loading wav files (with some caveats) +- Embed IO into sounds ## Building diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -20,17 +20,23 @@ bench "Dropped sound" $ nfSound droppedSound, bench "Taken sound" $ nfSound takenSound, bench "Cached sound" $ nfSound cachedSound, + bench "Repeated cached sound" $ nfSound repeatedCachedSound, bench "Timed parallel sound" $ nfSound timedParallelSound, bench "Unfold pulse" $ nfSound unfoldPulse, bench "Unfold normally" $ nfSound unfoldNormally, bench "With sampled sound" $ nfSound useSampledSound, - bench "Repeated with sampled sound" $ nfSound repeatedSampledSound + bench "Repeated with sampled sound" $ nfSound repeatedSampledSound, + bench "Load sound" $ nfSound loadedSound, + bench "Repeated with loaded sound" $ nfSound repeatedLoadedSound ] ] nfSound :: Sound T Pulse -> Benchmarkable nfSound = nfIO . sampleSound 44100 +nfSoundIO :: IO (Sound T Pulse) -> Benchmarkable +nfSoundIO sound = nfIO $ sound >>= sampleSound 44100 + simplePulse :: Sound T Pulse simplePulse = 3 |-> sineWave 440 @@ -74,6 +80,9 @@ cachedSound :: Sound T Pulse cachedSound = cache longSound +repeatedCachedSound :: Sound T Pulse +repeatedCachedSound = repeatSound 20 cachedSound + timedParallelSound :: Sound T Pulse timedParallelSound = parallel $ @@ -100,3 +109,9 @@ repeatedSampledSound :: Sound T Pulse repeatedSampledSound = repeatSound 20 useSampledSound + +loadedSound :: Sound T Pulse +loadedSound = setDuration 3 $ embedIOLazily $ loadWav "sample-sounds/accelerating.wav" + +repeatedLoadedSound :: Sound T Pulse +repeatedLoadedSound = repeatSound 20 loadedSound diff --git a/example/Example1.hs b/example/Example1.hs --- a/example/Example1.hs +++ b/example/Example1.hs @@ -1,4 +1,3 @@ -import Data.Coerce (coerce) import LambdaSound main :: IO () @@ -16,61 +15,3 @@ -- Design a note sample note :: Semitone -> Sound I Pulse note st = easeInOut 2 $ asNote sawWave st + asNote (harmonic triangleWave) st - --- -- simpleReverb 0.1 $ applyIIRFilter (highPassFilter 600 1) sound - --- sound :: Sound T Pulse --- sound = melody <> background - --- background :: Sound T Pulse --- background = --- repeatSound 3 $ --- sequentially $ --- fmap --- (setDuration 0.5) --- [ note c3, --- parallel $ note <$> [e3, g3], --- parallel $ note <$> [e3, g3], --- parallel $ note <$> [e3, g3] --- ] - --- melody :: Sound T Pulse --- melody = --- let mel = --- repeatSound --- 3 --- ( sequentially $ --- fmap --- (setDuration 0.5) --- [ note c4, --- note e4, --- note g4, --- note e4 --- ] --- ) --- >>> end --- end = setDuration 2 $ parallel [note c4, note c3, note g3] --- in mel - --- note :: Semitone -> Sound T Pulse --- note st = --- applyEnvelope (Envelope 0.2 0.1 0.2 0.8) $ --- setDuration 1 $ --- asNote (harmonic sineWave) st - --- -- Further examples - --- metronome :: Sound T Pulse --- metronome = repeatSound 10 $ setDuration 1 $ note c4 >>> setDuration 2 silence - --- upSound :: Sound T Pulse --- upSound = --- zipSoundWith (*) ((\p -> 1 - coerce p) <$> progress) $ --- speedUp $ --- upwards >>> takeSound 2 (raiseSemitones 12 upwards) >>> setDuration 1 (note g5) - --- upwards :: Sound T Pulse --- upwards = setDuration 3.5 $ sequentially $ note <$> [c4, d4, e4, f4, g4, a4, b4] - --- speedUp :: Sound T Pulse -> Sound T Pulse --- speedUp = changeTempo $ \p -> p ** 2 diff --git a/example/Example2.hs b/example/Example2.hs --- a/example/Example2.hs +++ b/example/Example2.hs @@ -3,8 +3,7 @@ main :: IO () main = do play 44100 1 $ setDuration (getDuration sound * 60 / 70) sound - -- samples <- sampleSound 44100 $ setDuration (getDuration sound * 60 / 70) sound - -- saveWav "sound.wav" 44100 samples + -- saveWav "sound.wav" 44100 sound sound :: Sound T Pulse sound = diff --git a/example/Example3.hs b/example/Example3.hs new file mode 100644 --- /dev/null +++ b/example/Example3.hs @@ -0,0 +1,7 @@ +import LambdaSound + +main :: IO () +main = do + nachtmusik <- loadWav "sample-sounds/mozart-kleine-nachtmusik.wav" + play 44100 0.4 $ takeSound 10 $ dropSound 10 nachtmusik + diff --git a/lambdasound.cabal b/lambdasound.cabal --- a/lambdasound.cabal +++ b/lambdasound.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: lambdasound -version: 1.0.1 +version: 1.1 synopsis: A libary for generating low-level sounds with high-level combinators description: 'lambdasound' can generate all kinds of sounds, play them and save them as wav or pcm data. Sound can be manipulated in both a low and high-level way. It is possible to @@ -38,7 +38,9 @@ LambdaSound.Sampling, LambdaSound.Create, LambdaSound.Convolution, - LambdaSound.Filter + LambdaSound.Filter, + LambdaSound.SaveAndLoad, + LambdaSound.SaveAndLoad.RawSamples other-modules: LambdaSound.Sound.ComputeSound, LambdaSound.Sound.Types, @@ -46,7 +48,6 @@ build-depends: base >= 4.17.0.0 && < 5, ansi-terminal >= 1.0 && < 1.1, - binary >= 0.8.9 && < 0.9, bytestring >= 0.11.4 && < 0.12, deepseq >= 1.4.8 && < 1.5, bytestring-to-vector >= 0.3.0 && < 0.4, @@ -86,6 +87,17 @@ executable example2 import: warnings main-is: Example2.hs + build-depends: + base ^>=4.17.0.0, + lambdasound + default-extensions: + DataKinds + hs-source-dirs: example + default-language: GHC2021 + +executable example3 + import: warnings + main-is: Example3.hs build-depends: base ^>=4.17.0.0, lambdasound diff --git a/src/LambdaSound.hs b/src/LambdaSound.hs --- a/src/LambdaSound.hs +++ b/src/LambdaSound.hs @@ -37,6 +37,9 @@ -- * Sample sounds, module Sampling, + -- * Save and load sounds + module SaveAndLoad, + -- * Cache sounds module Cache, ) @@ -53,3 +56,4 @@ import LambdaSound.Samples as Sample import LambdaSound.Sampling as Sampling import LambdaSound.Sound as Sound +import LambdaSound.SaveAndLoad as SaveAndLoad diff --git a/src/LambdaSound/Cache.hs b/src/LambdaSound/Cache.hs --- a/src/LambdaSound/Cache.hs +++ b/src/LambdaSound/Cache.hs @@ -7,7 +7,6 @@ import Data.Hashable (hash) import Data.Massiv.Array qualified as M import Data.Massiv.Array.Unsafe qualified as MU -import Data.Vector.Storable qualified as V import Data.Vector.Storable.ByteString (byteStringToVector, vectorToByteString) import Data.Word import LambdaSound.Sound @@ -19,7 +18,7 @@ -- | Caches a sound. If the sound is cached, then -- the sound gets read from the XDG cache directory and does not have to -- be computed again. --- +-- -- It might load a cached sound which which is incorrect, but this should be very unlikely cache :: Sound d Pulse -> Sound d Pulse cache (TimedSound d msc) = TimedSound d $ cacheComputation msc @@ -27,31 +26,38 @@ cacheComputation :: ComputeSound Pulse -> ComputeSound Pulse cacheComputation cs = ComputeSound $ \si memo -> do - key <- liftIO $ computeCacheKey cs - cacheDir <- liftIO $ getXdgDirectory XdgCache "lambdasound" - let directoryPath = joinPath [cacheDir, show key] - liftIO $ createDirectoryIfMissing True directoryPath + (writeSamples, ci) <- asWriteResult cs si memo - let filePath = joinPath [directoryPath, show $ si.samples] + let tryCache dest = do + let memoInfo = MemoInfo si ci - exists <- liftIO $ doesFileExist filePath - if exists - then do - file <- liftIO $ BL.readFile filePath - let floats = byteStringToVector $ toStrict $ decompress file - (ComputeSound compute) = makeWithIndexFunction @Pulse (\_ index -> floats V.! index) - compute si memo - else - do - (writeResult, ci) <- asWriteResult cs si memo - pure - ( WriteResult $ \dest -> do - writeResult dest - floats <- MU.unsafeFreeze M.Seq dest - let bytes = compress $ fromStrict $ vectorToByteString $ M.toStorableVector floats - BL.writeFile filePath bytes, - ci - ) + memoized <- lookupMemoizedComputeSound memo memoInfo + + case memoized of + Just memoSource -> do + copyArrayIntoMArray memoSource dest + Nothing -> do + key <- liftIO $ computeCacheKey cs + cacheDir <- liftIO $ getXdgDirectory XdgCache "lambdasound" + let directoryPath = joinPath [cacheDir, show key] + liftIO $ createDirectoryIfMissing True directoryPath + + let filePath = joinPath [directoryPath, show $ si.samples] + + exists <- liftIO $ doesFileExist filePath + if exists + then do + file <- liftIO $ BL.readFile filePath + let floats = M.fromStorableVector M.Seq $ byteStringToVector $ toStrict $ decompress file + memoizeComputeSound memo memoInfo floats + M.computeInto dest floats + else do + writeSamples dest + floats <- MU.unsafeFreeze M.Seq dest + let bytes = compress $ fromStrict $ vectorToByteString $ M.toStorableVector floats + BL.writeFile filePath bytes + + pure (WriteResult tryCache, ci) computeCacheKey :: ComputeSound Pulse -> IO Word64 computeCacheKey cs = do diff --git a/src/LambdaSound/Sampling.hs b/src/LambdaSound/Sampling.hs --- a/src/LambdaSound/Sampling.hs +++ b/src/LambdaSound/Sampling.hs @@ -1,14 +1,13 @@ -- | This module contains functions to sample sound and to save it in a file. -- The @LambdaSound.Play@ module exports a function to play sounds directly. -module LambdaSound.Sampling (sampleSound, sampleSoundRaw, saveWav, saveRawPCM) where +module LambdaSound.Sampling (sampleSound, sampleSoundRaw, unsampleSound, unsampleSoundWithHz) where -import Codec.Audio.Wave -import Data.ByteString qualified as B +import Data.Coerce (coerce) import Data.Massiv.Array qualified as M +import Data.Massiv.Array.Unsafe qualified as MU import LambdaSound.Sound import LambdaSound.Sound.ComputeSound (sampleComputeSound) import LambdaSound.Sound.Types (makeSamplingInfo) -import Data.Vector.Storable.ByteString (vectorToByteString) -- | Samples a sound with the given frequency (usually 44100 is good) without post-processing sampleSoundRaw :: Hz -> Sound T Pulse -> IO (M.Vector M.S Pulse) @@ -26,11 +25,6 @@ postProcess :: (M.Source r Pulse) => M.Vector r Pulse -> M.Vector M.D Pulse postProcess = compressDynamically --- | Save the sound as raw floats -saveRawPCM :: FilePath -> M.Vector M.S Pulse -> IO () -saveRawPCM filePath floats = - B.writeFile filePath $ vectorToByteString $ M.toStorableVector floats - -- | Apply dynamic compression on a vector of samples such that -- they are constrained within (-1, 1). Quieter sounds are boosted -- while louder sounds are reduced. @@ -45,20 +39,28 @@ maxPulse = M.maximum' $ M.map abs signal factor = 0.8 --- | Save a sound to a wave file with the given sampling frequency -saveWav :: FilePath -> Int -> M.Vector M.S Pulse -> IO () -saveWav filepath sampleRate floats = do - let floatsLength = M.unSz $ M.size floats - wave = - Wave - { waveFileFormat = WaveVanilla, - waveSampleRate = fromIntegral sampleRate, - waveSampleFormat = SampleFormatIeeeFloat32Bit, - waveChannelMask = speakerMono, - waveDataOffset = 0, - waveDataSize = fromIntegral floatsLength * 4, - waveSamplesTotal = fromIntegral floatsLength, - waveOtherChunks = [] - } - writeWaveFile filepath wave $ \handle -> - B.hPut handle $ vectorToByteString $ M.toStorableVector floats +-- | Convert a vector of samples into the 'Sound' datatype so that it can be transformed +-- with the various combinators. +-- +-- Keep in mind that if you do not exactly match the size of +-- the vector and the needed amount of samples for the sound, +-- then its speed will actually change which will also affect the sound pitch. +-- Also, sub- or supersampling will happen. +unsampleSound :: (M.Source r Pulse) => M.Vector r Pulse -> Sound I Pulse +unsampleSound samples = makeSound $ \si -> + if M.unSz (M.size samples) == si.samples + then MU.unsafeIndex samples + else + let scaler :: Double = fromIntegral (M.unSz $ M.size samples) / fromIntegral si.samples + in \i -> MU.unsafeIndex samples $ floor (fromIntegral i * scaler) + +-- | Convert a vector of samples into the 'Sound' datatype so that it can be transformed +-- with the various combinators. +-- +-- Given the sample rate used for the creation of the vector, the resulting sound +-- will have the same duration as the original sound. However, sub- and supersampling will still happen +-- similarly to `unsampleSound` and changing the 'Duration' also changes the pitch. +unsampleSoundWithHz :: (M.Source r Pulse) => Hz -> M.Vector r Pulse -> Sound T Pulse +unsampleSoundWithHz hz samples = setDuration d $ unsampleSound samples + where + d = coerce $ fromIntegral (M.unSz $ M.size samples) / hz diff --git a/src/LambdaSound/SaveAndLoad.hs b/src/LambdaSound/SaveAndLoad.hs new file mode 100644 --- /dev/null +++ b/src/LambdaSound/SaveAndLoad.hs @@ -0,0 +1,61 @@ +-- | This module exports some functions for simple loading and saving sounds. +-- +-- However, keep in mind that loaded sounds have a fixed amound of samples and thus cannot be stretched +-- in duration losslessly. Stretching a sound results in sub- or supersampling and will also shift the pitch. +-- Pitch-retaining stretching has not been implemented yet! +module LambdaSound.SaveAndLoad + ( saveWav, + loadWav, + saveRaw, + loadRaw, + saveRawCompressed, + loadRawCompressed, + ) +where + +import Data.List.NonEmpty +import LambdaSound.Sampling (sampleSound, unsampleSound, unsampleSoundWithHz) +import LambdaSound.SaveAndLoad.RawSamples qualified as RS +import LambdaSound.Sound + +-- | Save a sound as a wav file using default 'sampleSound'. +saveWav :: FilePath -> Hz -> Sound T Pulse -> IO () +saveWav filePath hz sound = do + floats <- sampleSound hz sound + RS.saveWav filePath hz floats + +-- | Load a wav as a sound, mixing channels with 'parallel2'. +-- +-- If you want to to use this with `embedIO`, you should probably use `embedIOLazily` instead! +loadWav :: FilePath -> IO (Sound T Pulse) +loadWav filePath = do + (hz, channels) <- RS.loadWav filePath + pure $ unsampleSoundWithHz hz $ Data.List.NonEmpty.head channels + +-- | Save a sound as floats. +saveRaw :: FilePath -> Hz -> Sound T Pulse -> IO () +saveRaw filePath hz sound = do + floats <- sampleSound hz sound + RS.saveRaw filePath floats + +-- | Load a sound from floats. +-- +-- If you want to to use this with `embedIO`, you should probably use `embedIOLazily` instead! +loadRaw :: FilePath -> IO (Sound I Pulse) +loadRaw filePath = do + floats <- RS.loadRaw filePath + pure $ unsampleSound floats + +-- | Save a sound as gzip-compressed floats. +saveRawCompressed :: FilePath -> Hz -> Sound T Pulse -> IO () +saveRawCompressed filePath hz sound = do + floats <- sampleSound hz sound + RS.saveRawCompressed filePath floats + +-- | Load a sound from gzip-compressed floats. +-- +-- If you want to to use this with `embedIO`, you should probably use `embedIOLazily` instead! +loadRawCompressed :: FilePath -> IO (Sound I Pulse) +loadRawCompressed filePath = do + floats <- RS.loadRawCompressed filePath + pure $ unsampleSound floats diff --git a/src/LambdaSound/SaveAndLoad/RawSamples.hs b/src/LambdaSound/SaveAndLoad/RawSamples.hs new file mode 100644 --- /dev/null +++ b/src/LambdaSound/SaveAndLoad/RawSamples.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +module LambdaSound.SaveAndLoad.RawSamples + ( saveWav, + saveRaw, + saveRawCompressed, + loadWav, + loadRaw, + loadRawCompressed, + ) +where + +import Codec.Audio.Wave +import Codec.Compression.GZip (compress, decompress) +import Control.Monad.IO.Class (liftIO) +import Data.ByteString qualified as B +import Data.ByteString.Lazy qualified as BL +import Data.Functor ((<&>)) +import Data.Int (Int16, Int32, Int64) +import Data.List.NonEmpty +import Data.Massiv.Array qualified as M +import Data.Semigroup (Max (..)) +import Data.Vector.Storable.ByteString (byteStringToVector, vectorToByteString) +import Data.Word (Word8) +import LambdaSound.Sound (Hz, Pulse) + +-- | Save sound samples to a wave file with the given sampling frequency +saveWav :: FilePath -> Hz -> M.Vector M.S Pulse -> IO () +saveWav filepath sampleRate floats = do + let floatsLength = M.unSz $ M.size floats + wave = + Wave + { waveFileFormat = WaveVanilla, + waveSampleRate = round sampleRate, + waveSampleFormat = SampleFormatIeeeFloat32Bit, + waveChannelMask = speakerMono, + waveDataOffset = 0, + waveDataSize = fromIntegral floatsLength * 4, + waveSamplesTotal = fromIntegral floatsLength, + waveOtherChunks = [] + } + writeWaveFile filepath wave $ \handle -> + B.hPut handle $ vectorToByteString $ M.toStorableVector floats + +-- | Load a wave file to get the sampling frequencies and the sound samples for the channels. +loadWav :: FilePath -> IO (Hz, NonEmpty (M.Vector M.S Pulse)) +loadWav filePath = do + wave <- readWaveFile filePath + file <- B.readFile filePath + let sourceVector = readSource wave $ B.drop (fromIntegral $ waveDataOffset wave) file + pure (fromIntegral $ waveSampleRate wave, splitInChannels wave sourceVector) + where + splitInChannels :: Wave -> M.Vector M.D Pulse -> NonEmpty (M.Vector M.S Pulse) + splitInChannels wave sourceVector = + let channels = fromIntegral $ waveChannels wave + in fromList $ + if channels == 1 + then [M.compute sourceVector] + else + [0 .. pred channels] <&> \channelOffset -> + M.compute $ M.downsample (M.Stride channels) $ M.drop (M.Sz1 channelOffset) sourceVector + readSource :: Wave -> B.ByteString -> M.Vector M.D Pulse + readSource wave sampleData = + case waveSampleFormat wave of + SampleFormatIeeeFloat32Bit -> mapAndLoad @Float + SampleFormatIeeeFloat64Bit -> mapAndLoad @Double + SampleFormatPcmInt 8 -> M.map ((+ (-1)) . (* 2)) $ mapAndLoad @Word8 + SampleFormatPcmInt 16 -> mapAndLoad @Int16 + SampleFormatPcmInt 32 -> mapAndLoad @Int32 + SampleFormatPcmInt 64 -> mapAndLoad @Int64 + _ -> error $ "The sample format \"" <> show (waveSampleFormat wave) <> "\" is not supported" + where + mapAndLoad :: forall a. (Real a, Num a, M.Storable a) => M.Vector M.D Pulse + mapAndLoad = + let rawArray = + M.fromStorableVector @a M.Seq $ + byteStringToVector sampleData + (Max maxSample) = realToFrac <$> M.foldSemi (Max . abs) (Max 0) rawArray + in M.map ((/ maxSample) . realToFrac) rawArray + {-# INLINE mapAndLoad #-} + +-- | Save the sound samples as raw floats +saveRaw :: FilePath -> M.Vector M.S Pulse -> IO () +saveRaw filePath floats = + B.writeFile filePath $ vectorToByteString $ M.toStorableVector floats + +-- | Save the sound samples as raw floats compressed with gzip +saveRawCompressed :: FilePath -> M.Vector M.S Pulse -> IO () +saveRawCompressed filePath floats = do + let bytes = compress $ BL.fromStrict $ vectorToByteString $ M.toStorableVector floats + BL.writeFile filePath bytes + +-- Load the gzip compressed raw sound samples +loadRawCompressed :: FilePath -> IO (M.Vector M.S Pulse) +loadRawCompressed filePath = do + file <- liftIO $ BL.readFile filePath + pure $ M.fromStorableVector M.Seq $ byteStringToVector $ BL.toStrict $ decompress file + +-- Load the raw sound samples +loadRaw :: FilePath -> IO (M.Vector M.S Pulse) +loadRaw filePath = do + file <- liftIO $ B.readFile filePath + pure $ M.fromStorableVector M.Seq $ byteStringToVector file diff --git a/src/LambdaSound/Sound.hs b/src/LambdaSound/Sound.hs --- a/src/LambdaSound/Sound.hs +++ b/src/LambdaSound/Sound.hs @@ -69,6 +69,10 @@ withSamplingInfo, withSampledSound, withSampledSoundPulse, + + -- * Embed IO + embedIO, + embedIOLazily, ) where @@ -399,3 +403,16 @@ -- Take a look at @LambdaSound.Create@ for other creation functions. makeSoundVector :: (SamplingInfo -> M.Vector M.D a) -> Sound I a makeSoundVector f = InfiniteSound $ makeDelayedResult f + +-- | Embed an IO calculation when generating an infinite sound. +-- +-- This IO action will be run each time the sound is used. +embedIO :: IO (Sound d a) -> Sound I a +embedIO ioSound = InfiniteSound $ embedIOCS $ getCS <$> ioSound + +-- | Embed an IO calculation lazily when generating an infinite sound. +-- +-- This IO action will not necessarily run each time the sound is used due to memoization. +-- The IO action will run at least once and at most as often as the sound occurs. +embedIOLazily :: IO (Sound d a) -> Sound I a +embedIOLazily ioSound = InfiniteSound $ embedIOLazilyCS $ getCS <$> ioSound diff --git a/src/LambdaSound/Sound/ComputeSound.hs b/src/LambdaSound/Sound/ComputeSound.hs --- a/src/LambdaSound/Sound/ComputeSound.hs +++ b/src/LambdaSound/Sound/ComputeSound.hs @@ -1,5 +1,6 @@ module LambdaSound.Sound.ComputeSound where +import Control.Monad (join) import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.HashTable.IO qualified as H import Data.Hashable @@ -21,7 +22,7 @@ makeDelayedResult :: (SamplingInfo -> M.Vector M.D a) -> ComputeSound a makeDelayedResult f = ComputeSound $ \si _ -> do stableF <- makeSomeStableName f - pure (DelayedResult $ f si, ComputationInfoMakeDelayedResult stableF) + pure (DelayedResult $ pure $ f si, ComputationInfoMakeDelayedResult stableF) {-# INLINE makeDelayedResult #-} changeSamplingInfo :: (SamplingInfo -> SamplingInfo) -> ComputeSound a -> ComputeSound a @@ -36,13 +37,15 @@ (delayedVector, ci) <- asDelayedResult cs si memo stableMapVector <- makeSomeStableName mapVector let mapVector' = mapVector si - pure (DelayedResult $ mapVector' delayedVector, ComputationInfoMapDelayedResult stableMapVector ci) + pure (DelayedResult $ fmap mapVector' delayedVector, ComputationInfoMapDelayedResult stableMapVector ci) {-# INLINE mapDelayedResult #-} withSamplingInfoCS :: (SamplingInfo -> ComputeSound a) -> ComputeSound a -withSamplingInfoCS f = ComputeSound $ \si memo -> +withSamplingInfoCS f = ComputeSound $ \si memo -> do + stableF <- makeSomeStableName f let (ComputeSound compute) = f si - in compute si memo + (res, _) <- compute si memo + pure (res, ComputationInfoWithSamplingInfo stableF) {-# INLINE withSamplingInfoCS #-} withSampledSoundPulseCS :: Duration -> ComputeSound Pulse -> (M.Vector M.S Pulse -> ComputeSound a) -> ComputeSound a @@ -62,10 +65,14 @@ withSampledSoundCS duration cs f = ComputeSound $ \si memo -> do let sampleSI = makeSamplingInfo si.sampleRate duration (delayedVector, ci) <- asDelayedResult cs sampleSI memo - let (ComputeSound compute) = f delayedVector - (res, _) <- compute si memo + let nextCS = f <$> delayedVector stableF <- makeSomeStableName f - pure (res, ComputationInfoWithSampledSound stableF ci) + pure + ( DelayedResult $ do + (finalDelayedVector, _) <- join $ asDelayedResult <$> nextCS <*> pure si <*> pure memo + finalDelayedVector, + ComputationInfoWithSampledSound stableF ci + ) {-# INLINE withSampledSoundCS #-} mergeDelayedResult :: (SamplingInfo -> M.Vector M.D a -> M.Vector M.D b -> M.Vector M.D c) -> ComputeSound a -> ComputeSound b -> ComputeSound c @@ -74,7 +81,7 @@ (delayedResult1, ci1) <- asDelayedResult cs1 si memo (delayedResult2, ci2) <- asDelayedResult cs2 si memo let merge' = merge si - pure (DelayedResult $ merge' delayedResult1 delayedResult2, ComputationInfoMergeDelayedResult stableMerge ci1 ci2) + pure (DelayedResult $ merge' <$> delayedResult1 <*> delayedResult2, ComputationInfoMergeDelayedResult stableMerge ci1 ci2) {-# INLINE mergeDelayedResult #-} computeSequentially :: Percentage -> ComputeSound Pulse -> ComputeSound Pulse -> ComputeSound Pulse @@ -99,8 +106,11 @@ (delayedResult2, p2) <- asDelayedResult c2 si {samples = c2N} memo pure ( if si.samples == c2N - then DelayedResult $ M.zipWith (+) delayedResult1 delayedResult2 - else DelayedResult $ M.imap (\index -> (+) $ if index < c2N then MU.unsafeIndex delayedResult2 index else 0) delayedResult1, + then DelayedResult $ M.zipWith (+) <$> delayedResult1 <*> delayedResult2 + else DelayedResult $ do + dR1 <- delayedResult1 + dR2 <- delayedResult2 + pure $ M.imap (\index -> (+) $ if index < c2N then MU.unsafeIndex dR2 index else 0) dR1, ComputationInfoParallel factor p1 p2 ) {-# INLINE computeParallel #-} @@ -109,24 +119,27 @@ mapComputeSound f cs = ComputeSound $ \si memo -> do stableF <- makeSomeStableName f (result, ci) <- asDelayedResult cs si memo - pure (DelayedResult $ M.map f result, ComputationInfoMap stableF ci) + pure (DelayedResult $ M.map f <$> result, ComputationInfoMap stableF ci) {-# INLINE mapComputeSound #-} asDelayedResult :: ComputeSound a -> SamplingInfo -> MemoComputeSound -> - IO (M.Vector M.D a, ComputationInfo) + IO (IO (M.Vector M.D a), ComputationInfo) asDelayedResult (ComputeSound compute) si memo = do (result, ci) <- compute si memo case result of DelayedResult vector -> pure (vector, ci) - WriteResult writeResult -> do - marray <- MU.unsafeMallocMArray (M.Sz1 si.samples) - writeResult marray - array <- MU.unsafeFreeze M.Seq marray - - pure (M.delay array, ci) + WriteResult writeResult -> + pure + ( do + marray <- MU.unsafeMallocMArray (M.Sz1 si.samples) + writeResult marray + array <- MU.unsafeFreeze M.Seq marray + pure $ M.delay array, + ci + ) {-# INLINE asDelayedResult #-} asWriteResult :: @@ -143,11 +156,12 @@ pure ( \dest -> do memoized <- lookupMemoizedComputeSound memo memoInfo + case memoized of - Just memoSource -> + Just memoSource -> do copyArrayIntoMArray memoSource dest Nothing -> do - M.computeInto dest vector + vector >>= M.computeInto dest destArray <- MU.unsafeFreeze M.Seq dest memoizeComputeSound memo memoInfo destArray, ci @@ -159,7 +173,7 @@ (dV1, p1) <- asDelayedResult cs1 si memo (dV2, p2) <- asDelayedResult cs2 si memo stableF <- makeSomeStableName f - pure (DelayedResult $ M.zipWith f dV1 dV2, ComputationInfoZip stableF p1 p2) + pure (DelayedResult $ M.zipWith f <$> dV1 <*> dV2, ComputationInfoZip stableF p1 p2) {-# INLINE zipWithCompute #-} mapSoundFromMemory :: (M.Load r M.Ix1 Pulse) => (M.Vector M.S Pulse -> M.Vector r Pulse) -> ComputeSound Pulse -> ComputeSound Pulse @@ -201,6 +215,25 @@ ) {-# INLINE fillSoundInMemoryIO #-} +embedIOCS :: IO (ComputeSound a) -> ComputeSound a +embedIOCS makeCS = ComputeSound $ \si memo -> do + stableIO <- makeSomeStableName makeCS + (ComputeSound compute) <- makeCS + (res, _) <- compute si memo + pure (res, ComputationInfoIO stableIO) +{-# INLINE embedIOCS #-} + +embedIOLazilyCS :: IO (ComputeSound a) -> ComputeSound a +embedIOLazilyCS makeCS = ComputeSound $ \si memo -> do + stableIO <- makeSomeStableName makeCS + pure + ( DelayedResult $ do + (res, _) <- join $ asDelayedResult <$> makeCS <*> pure si <*> pure memo + res, + ComputationInfoIO stableIO + ) +{-# INLINE embedIOLazilyCS #-} + pulseSize :: Int pulseSize = sizeOf (undefined :: Pulse) {-# INLINE pulseSize #-} @@ -243,7 +276,7 @@ data SoundResult a where WriteResult :: (M.MVector M.RealWorld M.S Pulse -> IO ()) -> SoundResult Pulse - DelayedResult :: M.Vector M.D a -> SoundResult a + DelayedResult :: IO (M.Vector M.D a) -> SoundResult a data ComputationInfo = ComputationInfoZip SomeStableName ComputationInfo ComputationInfo @@ -256,7 +289,9 @@ | ComputationInfoMapMemory SomeStableName ComputationInfo | ComputationInfoFillMemory SomeStableName | ComputationInfoChangeSamplingInfo SomeStableName ComputationInfo - | ComputationInfoWithSampledSound SomeStableName ComputationInfo + | ComputationInfoWithSampledSound SomeStableName ComputationInfo + | ComputationInfoIO SomeStableName + | ComputationInfoWithSamplingInfo SomeStableName deriving (Eq, Generic, Show) instance Hashable ComputationInfo diff --git a/src/LambdaSound/Sound/Types.hs b/src/LambdaSound/Sound/Types.hs --- a/src/LambdaSound/Sound/Types.hs +++ b/src/LambdaSound/Sound/Types.hs @@ -20,7 +20,7 @@ newtype Percentage = Percentage Float deriving (Show, Eq, Floating, Num, Fractional, Ord, Real, RealFrac, NFData, Storable, Hashable, Enum) -- | Hz are the unit for frequencies. 440 Hz means that 440 oscillations happen per second -newtype Hz = Hz Float deriving (Show, Eq, Ord, Num, Fractional, Floating, Enum, Generic) +newtype Hz = Hz Float deriving (Show, Eq, Ord, Num, Fractional, Floating, Enum, Generic, Real, RealFrac) -- | Time progresses while a 'Sound' is playing and is used to create samples. -- It is not guaranteed that 'Time' will correspond to the real runtime of a 'Sound'