packages feed

lambdasound (empty) → 1.0.0

raw patch · 25 files changed

+2116/−0 lines, 25 filesdep +ansi-terminaldep +basedep +binary

Dependencies added: ansi-terminal, base, binary, bytestring, bytestring-to-vector, deepseq, directory, falsify, filepath, hashable, hashtables, lambdasound, massiv, proteaaudio-sdl, random, tasty, tasty-bench, tasty-hunit, text, transformers, vector, wave, zlib

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for lambdasound++## 1.0.0 -- 2023-10-12++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2023 Simre1++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,89 @@+# LambdaSound++A Haskell libary for generating low-level sounds with high-level combinators.++You can create sounds as a list of floats and then manipulate them with +combinators like `parallel`, `sequentially` or `dropSound`.++## Examples++```haskell+-- An infinite 440hz sinus curve+sound440Hz :: Sound I Pulse+sound440Hz = sineWave 440 ++-- Three infinite sounds in parallel+triad :: Sound I Pulse+triad = parallel $ fmap (asNote sineWave) [c4, e4, g4]++-- Five sequential 1 second sounds +ascending :: Sound T Pulse+ascending = sequentially $+  fmap (setDuration 1 . asNote sineWave) [c4,d4,e4,f4,g4]++-- Cut apart sounds with takeSound and dropSound+ascendingPart :: Sound T Pulse+ascendingPart = takeSound 1 $ dropSound 1 ascending++-- Add a quiet noise to a sound+noisyAscending :: Sound T Pulse+noisyAscending = parallel+  [ setDuration (getDuration ascending) (reduce 3 (noise 42)),+    ascending+  ]++-- Raise the frequency of a sound so it has a higher pitch+ascendingAnOctaveHigher :: Sound T Pulse+ascendingAnOctaveHigher = raise 8 ascending ++-- Reverse the samples in a sound+descending :: Sound T Pulse+descending = reverseSound ascending++-- Change the tempo the parts of a sound are played at+speedupDuringSound :: Sound d Pulse -> Sound d Pulse+speedupDuringSound = changeTempo $ \progress -> progress ** 1.2++-- Play sound with a sample rate of 44100+main :: IO ()+main = do+  let volume = 0.5+      sampleRate = 44100+  play sampleRate volume ascending+```++You can also take a look at `example/Example1.hs` and `example/Example2.hs` for bigger examples and play them with `cabal run example1` and `cabal run example2`.++## Feature Overview++- Play sounds with SDL2+- Save sounds as WAV+- Create raw audio samples by defining a vector of floats+- Manipulate the duration of a sound+- Combine sounds via `parallel`, `sequentially` or `zipSound`+- Change volume+- Modify the pitch+- Create a sound and then map over its samples+- Convolve sounds+- IIR filters+- Cut apart sounds with `takeSound` and `dropSound`+- Scaling playing speed+- Cache expensive to compute sounds in your XDG-cache directory++## Building++`lambdasound` can be built as usual with the `cabal` package manager. For playing sounds, you will need to have **SDL2** installed.++```+git clone https://github.com/Simre1/lambdasound+cabal build lambdasound+```++You can run the example with:+```+cabal run example+```++## Contributing++Feel free to try out this library and add additional functionality.
+ bench/Main.hs view
@@ -0,0 +1,89 @@+module Main where++import Data.Coerce+import LambdaSound+import Test.Tasty.Bench++main :: IO ()+main =+  defaultMain+    [ bgroup+        "LambdaSound"+        [ bench "Simple Pulse" $ nfSound simplePulse,+          bench "Simple Harmonic" $ nfSound simpleHarmonic,+          bench "Some Sounds" $ nfSound someSounds,+          bench "Noise" $ nfSound noiseSound,+          bench "Convolution" $ nfSound convolutionSound,+          bench "Long Sound" $ nfSound longSound,+          bench "Filtered sound" $ nfSound filteredSound,+          bench "Dropped sound" $ nfSound droppedSound,+          bench "Taken sound" $ nfSound takenSound,+          bench "Cached sound" $ nfSound cachedSound,+          bench "Timed parallel sound" $ nfSound timedParallelSound,+          bench "Unfold pulse" $ nfSound unfoldPulse,+          bench "Unfold normally" $ nfSound unfoldNormally+        ]+    ]++nfSound :: Sound T Pulse -> Benchmarkable+nfSound = nfIO . sampleSound 44100++simplePulse :: Sound T Pulse+simplePulse = 3 |-> sineWave 440++simpleHarmonic :: Sound T Pulse+simpleHarmonic = 3 |-> harmonic sineWave 440++someSounds :: Sound T Pulse+someSounds =+  sequentially+    [ 1 |-> parallel [harmonic sineWave 440, harmonic sineWave 500, harmonic sineWave 1000],+      1 |-> harmonic sineWave 200,+      1 |-> harmonic sineWave 2000+    ]++filteredSound :: Sound T Pulse+filteredSound = applyIIRFilter (highPassFilter 1000 1) someSounds++noiseSound :: Sound T Pulse+noiseSound = 3 |-> noise 42++convolutionSound :: Sound T Pulse+convolutionSound =+  convolveDuration+    ( Kernel+        { size = 0.02,+          offset = 0,+          coefficients = coerce+        }+    )+    (1 |-> simplePulse)++longSound :: Sound T Pulse+longSound = repeatSound 20 someSounds++droppedSound :: Sound T Pulse+droppedSound = repeatSound 10 $ dropSound 0.5 someSounds++takenSound :: Sound T Pulse+takenSound = repeatSound 10 $ takeSound 2.5 someSounds++cachedSound :: Sound T Pulse+cachedSound = cache longSound++timedParallelSound :: Sound T Pulse+timedParallelSound =+  parallel $ mconcat $+    replicate 5 [ 0.5 |-> simplePulse,+      1 |-> simplePulse,+      1.5 |-> simplePulse,+      0.7 |-> simplePulse,+      2 |-> simplePulse,+      1.5 |-> simplePulse+    ]++unfoldPulse :: Sound T Pulse+unfoldPulse = 5 |-> unfoldlSoundPulse (\s -> (s, succ s)) 0++unfoldNormally :: Sound T Pulse+unfoldNormally = 5 |-> unfoldlSound (\s -> (s, succ s)) 0
+ cabal.project view
@@ -0,0 +1,3 @@+packages: .+tests: True+benchmarks: True
+ example/Example1.hs view
@@ -0,0 +1,61 @@+import Data.Coerce (coerce)+import LambdaSound++main :: IO ()+main = play 44100 0.4 $ 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
+ example/Example2.hs view
@@ -0,0 +1,91 @@+import LambdaSound++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++sound :: Sound T Pulse+sound =+  simpleReverb 0.15 $+    (melody1 >>> melody2 >>> melody3)+      <> reduce 1.3 (background1 >>> background2 >>> background3)++melody1 :: Sound T Pulse+melody1 =+  sequentially+    [ lEn $ melodyNote g4,+      lEn $ melodyNote f4,+      lEn $ 0.5 |-> melodyNote g4,+      lEn $ 0.5 |-> melodyNote e4,+      lEn $ melodyNote c4+    ]++melody2 :: Sound T Pulse+melody2 =+  sequentially+    [ lEn $ melodyNote g4,+      lEn $ melodyNote f4,+      lEn $ 0.5 |-> melodyNote g4,+      lEn $ 0.5 |-> melodyNote e4,+      lEn (0.5 |-> melodyNote c4)+        <> lEn (melodyNote g4)+        <> (0.5 |-> silence >>> lEn (0.5 |-> melodyNote c5))+    ]++melody3 :: Sound T Pulse+melody3 =+  parallel+    [ amplify 1.5 (pEn $ 2 |-> (melodyNote g4 <> melodyNote c5 <> melodyNote e5)),+      sequentially+        [ 1 |-> silence,+          lEn (0.5 |-> melodyNote g4),+          lEn (0.5 |-> melodyNote e4),+          lEn (0.5 |-> melodyNote g4),+          lEn (0.5 |-> melodyNote e4),+          lEn (1 |-> melodyNote c4) <> lEn (1 |-> melodyNote g3)+        ]+    ]++background1 :: Sound T Pulse+background1 =+  sequentially $+    fmap+      (lEn . setDuration 0.5 . backgroundNote)+      [c3, g3, c4, g3]+      ++ [ parallel $ lEn . backgroundNote <$> [g3, c4],+           lEn $ 0.5 |-> backgroundNote a3,+           lEn $ 0.5 |-> backgroundNote b3+         ]++background2 :: Sound T Pulse+background2 =+  sequentially $+    fmap+      (lEn . setDuration 0.5 . backgroundNote)+      [c3, g3, c4, g3]+      ++ [ parallel $ lEn . backgroundNote <$> [g3, c4],+           parallel $ lEn . backgroundNote <$> [c3, e3, g3]+         ]++background3 :: Sound T Pulse+background3 =+  sequentially $+    fmap+      (lEn . setDuration 0.5 . backgroundNote)+      [b2, d3, e3, g3, g3, e3]+      ++ [parallel [lEn $ backgroundNote c3]]+++lEn :: Sound 'T Pulse -> Sound 'T Pulse+lEn = applyEnvelope (Envelope 0.1 0.3 0.2 0.4)++pEn :: Sound 'T Pulse -> Sound 'T Pulse+pEn = applyEnvelope (Envelope 0.08 0.8 0.4 0.2)++melodyNote :: Semitone -> Sound T Pulse+melodyNote st = setDuration 1 $ reduce 2 (asNote (harmonic sineWave) st) + asNote squareWave st++backgroundNote :: Semitone -> Sound T Pulse+backgroundNote st = setDuration 1 $ asNote triangleWave st + reduce 2 (asNote (harmonic sineWave) st)
+ lambdasound.cabal view
@@ -0,0 +1,143 @@+cabal-version:      3.0+name:               lambdasound+version:            1.0.0+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 +                    operate on the samples of a sound. However, there are also higher-level combinators +                    for various tasks, e.g. to facilitate sequential and parallel playing of sounds or to change the duration of a sound.+license:            MIT+license-file:       LICENSE+author:             Simon Reitinger+maintainer:         simre4775@gmail.com+copyright:          2023 Simon Reitinger+category:           Sound+build-type:         Simple+extra-doc-files:    CHANGELOG.md+homepage:           https://github.com/Simre1/lambdasound+bug-reports:        https://github.com/Simre1/lambdasound/issues++extra-source-files:+    README.md+    CHANGELOG.md+    cabal.project +common warnings+    ghc-options: -Wall++library+    import:           warnings+    exposed-modules:  +        LambdaSound,+        LambdaSound.Sound,+        LambdaSound.Samples,+        LambdaSound.Effect,+        LambdaSound.Play,+        LambdaSound.Note,+        LambdaSound.Cache,+        LambdaSound.Plot,+        LambdaSound.Sampling,+        LambdaSound.Create,+        LambdaSound.Convolution,+        LambdaSound.Filter+    other-modules:+        LambdaSound.Sound.ComputeSound,+        LambdaSound.Sound.Types,+        Data.SomeStableName+    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,+        vector >= 0.13.0 && < 0.14,+        transformers >= 0.5.6 && < 0.6,+        directory >= 1.3.7 && < 1.4,+        filepath >= 1.4.2 && < 1.5,+        hashable >= 1.4.3 && < 1.5,+        text >= 2.0.2 && < 2.1,+        hashtables >= 1.3.1 && < 1.4,+        massiv >= 1.0.4 && < 1.1,+        random >= 1.2.1 && < 1.3,+        proteaaudio-sdl >= 0.9.3 && < 1.1,+        wave >= 0.2.0 && < 0.3,+        zlib >= 0.6.3 && < 0.7+    hs-source-dirs:   src+    default-extensions:+        DuplicateRecordFields,+        OverloadedRecordDot,+        NoFieldSelectors,+        DataKinds,+        TypeFamilies+    default-language: GHC2021+    ghc-options: -O2++executable example1+    import:           warnings+    main-is:          Example1.hs+    build-depends:+        base ^>=4.17.0.0,+        lambdasound+    default-extensions:+        DataKinds+    hs-source-dirs:   example+    default-language: GHC2021++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 lambdasound-profile+    import:           warnings+    main-is:          Main.hs+    build-depends:+        base ^>=4.17.0.0,+        lambdasound+    default-extensions:+        DataKinds+    hs-source-dirs:   profile+    default-language: GHC2021+    ghc-options: -O2++test-suite lambdasound-test+    import:           warnings+    default-language: GHC2021+    type:             exitcode-stdio-1.0+    hs-source-dirs:   test+    main-is:          Main.hs+    default-extensions:+        DataKinds+    build-depends:+        base >= 4.17.0.0 && < 5,+        lambdasound,+        tasty >= 1.4 && < 1.5,+        tasty-hunit >= 0.10.1 && < 0.11,+        falsify >= 0.1.1 && < 0.2,+        massiv >= 1.0.4 && < 1.1++benchmark lambdasound-bench+    import:           warnings+    default-language: GHC2021+    type:             exitcode-stdio-1.0+    hs-source-dirs:   bench+    main-is:          Main.hs+    default-extensions:+        DataKinds+    build-depends:+        base >= 4.17.0.0 && < 5,+        lambdasound,+        tasty >= 1.4 && < 1.5,+        tasty-bench >= 0.3.5 && < 0.4,+        vector >= 0.13.0 && < 0.14+    ghc-options: -O2++source-repository head+  type:     git+  location: https://github.com/Simre1/lambdasound
+ profile/Main.hs view
@@ -0,0 +1,37 @@+module Main where++import LambdaSound++main :: IO ()+main = do+  !floats <- sampleSound 44100 $ repeatSound 20 song+  pure ()++song :: Sound T Pulse+song = melody <> reduce 1.5 background++background :: Sound T Pulse+background =+  repeatSound 4 $+    setDuration 2 $+      sequentially+        [ setDuration 1 $ note c3,+          repeatSound 3 $ parallel $ note <$> [e3, g3]+        ]++melody :: Sound T Pulse+melody =+  let mel =+        repeatSound 3 $+          setDuration 2 $+            sequentially+              [ note c4,+                note e4,+                note g4,+                note e4+              ]+      end = setDuration 2 $ note c4+   in mel >>> end++note :: Semitone -> Sound T Pulse+note st = setDuration 1 $ easeInOut 4 $ asNote (harmonic sineWave) st
+ src/Data/SomeStableName.hs view
@@ -0,0 +1,20 @@+module Data.SomeStableName where++import Data.Hashable+import GHC.StableName+import Control.Monad.IO.Class++data SomeStableName = forall a. SomeStableName (StableName a)++instance Eq SomeStableName where+  (SomeStableName sn1) == (SomeStableName sn2) = sn1 `eqStableName` sn2++instance Hashable SomeStableName where+  hashWithSalt salt (SomeStableName sn) = salt * hashStableName sn+  hash (SomeStableName sn) = hashStableName sn++makeSomeStableName :: MonadIO m => a -> m SomeStableName+makeSomeStableName = liftIO . fmap SomeStableName . makeStableName++instance Show SomeStableName where+  show (SomeStableName sn) = "SomeStableName (" ++ show (hashStableName sn) ++ ")"
+ src/LambdaSound.hs view
@@ -0,0 +1,53 @@+-- |+-- Library users should implement this module (@import LambdaSound@).+--+-- This module packages all the functions from the other modules and reexports them.+-- A good starting place to explore the documentation is the *LambdaSound.Sound* module which+-- exports all the datatypes and many of the useful combinators you will use.+module LambdaSound+  ( -- * Sounds+    module Sound,++    -- * Create sounds+    module Create,++    -- * Play sounds+    module Play,++    -- * Notes+    module Note,++    -- * Effects+    module Effect,++    -- * Convolution+    module Convolution,++    -- * Sound samples+    module Sample,++    -- * Filter sounds+    module Filter,++    -- * Plot sounds+    module Plot,++    -- * Sample sounds,+    module Sampling,++    -- * Cache sounds+    module Cache,+  )+where++import LambdaSound.Cache as Cache+import LambdaSound.Convolution as Convolution+import LambdaSound.Create as Create+import LambdaSound.Effect as Effect+import LambdaSound.Filter as Filter+import LambdaSound.Note as Note+import LambdaSound.Play as Play+import LambdaSound.Plot as Plot+import LambdaSound.Samples as Sample+import LambdaSound.Sampling as Sampling+import LambdaSound.Sound as Sound
+ src/LambdaSound/Cache.hs view
@@ -0,0 +1,60 @@+module LambdaSound.Cache (cache) where++import Codec.Compression.GZip (compress, decompress)+import Control.Monad.IO.Class (MonadIO (..))+import Data.ByteString (fromStrict, toStrict)+import Data.ByteString.Lazy qualified as BL+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+import LambdaSound.Sound.ComputeSound+import LambdaSound.Sound.Types+import System.Directory+import System.FilePath (joinPath)++-- | Caches a sound. If the sound is cached, then+-- the sound gets read from the XDG data directory and does not have to+-- be computed again.+-- It might load a cached sound which is not the same+-- as the computed one, but this should be very unlikely+cache :: Sound d Pulse -> Sound d Pulse+cache (TimedSound d msc) = TimedSound d $ cacheComputation msc+cache (InfiniteSound msc) = InfiniteSound $ cacheComputation msc++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++  let filePath = joinPath [directoryPath, show $ si.samples]++  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+        )++computeCacheKey :: ComputeSound Pulse -> IO Word64+computeCacheKey cs = do+  let sr = makeSamplingInfo 50 1+  floats <- sampleComputeSound sr cs+  pure $ fromIntegral $ hash $ M.toList $ M.map (* 1000) floats
+ src/LambdaSound/Convolution.hs view
@@ -0,0 +1,59 @@+module LambdaSound.Convolution+  (  Kernel (..),+    convolveSamples,+    convolvePercentage,+    convolveDuration,+  )+where++import LambdaSound.Sound++import Data.Massiv.Array qualified as M+import Data.Coerce (coerce)++-- | A Kernel for convolution+data Kernel p = Kernel+  { coefficients :: p -> Float,+    size :: p,+    offset :: p+  }++convolve :: (Int -> Kernel Int) -> Sound d Pulse -> Sound d Pulse+convolve makeKernel = modifyWholeSound $ \wholeSound ->+  let (Kernel coefficients size offset) = makeKernel n+      n = M.unSz $ M.size wholeSound+      stencil = M.makeStencil (M.Sz1 size) offset $ \getV ->+        M.sum $ M.imap (\i -> (*) $ getV (i - offset)) computedCoefficients+      computedCoefficients =+        M.compute @M.S $+          if size <= 1+            then M.singleton 0.5+            else M.generate M.Seq (M.Sz1 size) $ \i ->+              coerce @_ @Pulse $ coefficients i+   in M.mapStencil M.Reflect stencil wholeSound++-- | Convolve a 'Sound' where the 'Kernel' size is+-- determined by 'Percentage's of the sound.+convolvePercentage :: Kernel Percentage -> Sound d Pulse -> Sound d Pulse+convolvePercentage (Kernel coefficients sizeP offsetP) = convolve $ \n ->+  let size = ceiling $ sizeP * fromIntegral n+   in Kernel+        { coefficients = \i -> coefficients (fromIntegral i / fromIntegral (size - 1)),+          size = size,+          offset = round $ offsetP * fromIntegral n+        }++-- | Convolve a 'Sound' where the 'Kernel' size is+-- determined by a 'Duration'.+convolveDuration :: Kernel Duration -> Sound T Pulse -> Sound T Pulse+convolveDuration (Kernel coefficients sizeD offsetD) sound@(TimedSound d _) =+  convolvePercentage+    (Kernel (coefficients . (* d) . coerce) (coerce $ sizeD / d) (coerce $ offsetD / d))+    sound++-- | Convolve a 'Sound' where the 'Kernel' size is+-- determined by the amount of samples. You have to keep in mind+-- that different sample rates will result in a different number of samples+-- for the same sound.+convolveSamples :: Kernel Int -> Sound T Pulse -> Sound T Pulse+convolveSamples kernel = convolve (const kernel)
+ src/LambdaSound/Create.hs view
@@ -0,0 +1,112 @@+module LambdaSound.Create+  ( -- *** Basic sounds+    time,+    progress,+    sampleIndex,+    constant,+    silence,++    -- *** Iterating+    iterateSound,+    iterateSoundPulse,++    -- *** Unfolding+    unfoldlSound,+    unfoldlSoundPulse,+    unfoldrSound,+    unfoldrSoundPulse,+    iUnfoldlSound,+    iUnfoldlSoundPulse,+    iUnfoldrSound,+    iUnfoldrSoundPulse,+  )+where++import Data.Coerce (coerce)+import Data.Massiv.Array qualified as M+import LambdaSound.Sound++-- | A 'Sound' with @0@ volume+silence :: Sound I Pulse+silence = constant 0++-- | A constant 'Sound'+constant :: a -> Sound I a+constant a = makeSound $ const (const a)++-- | Iterate over the samples to create the sound.+-- +-- The 'Pulse' version is faster then the non-'Pulse' version+iterateSoundPulse :: (Pulse -> Pulse) -> Pulse -> Sound I Pulse+iterateSoundPulse f s = fillWholeSound $ \si ->+  M.iterateN (M.Sz1 si.samples) f s++-- | Iterate over the samples to create the sound.+iterateSound :: (a -> a) -> a -> Sound I a+iterateSound f s = makeSoundVector $ \si ->+  M.delay $ M.compute @M.B $ M.iterateN (M.Sz1 si.samples) f s++-- | Unfold the samples of a sound from the start to the end+--+--  The 'Pulse' version is faster then the non-'Pulse' version+unfoldlSoundPulse :: (s -> (s, Pulse)) -> s -> Sound I Pulse+unfoldlSoundPulse f s = fillWholeSound $ \si ->+  M.unfoldlS_ (M.Sz1 si.samples) f s++-- | Unfold the samples of a sound from the start to the end+unfoldlSound :: (s -> (s, a)) -> s -> Sound I a+unfoldlSound f s = makeSoundVector $ \si ->+  M.delay $ M.compute @M.B $ M.unfoldlS_ (M.Sz1 si.samples) f s++-- | Unfold the samples of a sound from the end to start+--+-- The 'Pulse' version is faster then the non-'Pulse' version+unfoldrSoundPulse :: (s -> (Pulse, s)) -> s -> Sound I Pulse+unfoldrSoundPulse f s = fillWholeSound $ \si ->+  M.unfoldrS_ (M.Sz1 si.samples) f s++-- | Unfold the samples of a sound from the end to start+unfoldrSound :: (s -> (a, s)) -> s -> Sound I a+unfoldrSound f s = makeSoundVector $ \si ->+  M.delay $ M.compute @M.B $ M.unfoldrS_ (M.Sz1 si.samples) f s++-- | Unfold the samples of a sound from the start to the end with the index starting at 0+--+--  The 'Pulse' version is faster then the non-'Pulse' version+iUnfoldlSoundPulse :: (Int -> s -> (s, Pulse)) -> s -> Sound I Pulse+iUnfoldlSoundPulse f s = fillWholeSound $ \si ->+  M.iunfoldlS_ (M.Sz1 si.samples) f s++-- | Unfold the samples of a sound from the start to the end with the index starting at 0+iUnfoldlSound :: (Int -> s -> (s, a)) -> s -> Sound I a+iUnfoldlSound f s = makeSoundVector $ \si ->+  M.delay $ M.compute @M.B $ M.iunfoldlS_ (M.Sz1 si.samples) f s++-- | Unfold the samples of a sound from the end to the start with the index starting at 0+--+--  The 'Pulse' version is faster then the non-'Pulse' version+iUnfoldrSoundPulse :: (s -> Int -> (Pulse, s)) -> s -> Sound I Pulse+iUnfoldrSoundPulse f s = fillWholeSound $ \si ->+  M.iunfoldrS_ (M.Sz1 si.samples) f s++-- | Unfold the samples of a sound from the end to the start with the index starting at 0+iUnfoldrSound :: (s -> Int -> (a, s)) -> s -> Sound I a+iUnfoldrSound f s = makeSoundVector $ \si ->+  M.delay $ M.compute @M.B $ M.iunfoldrS_ (M.Sz1 si.samples) f s++-- | Get the time for each sample which can be used for sinus wave calculations (e.g. 'sineWave')+time :: Sound I Time+time = makeSound $ \si index ->+  coerce $ fromIntegral index * si.period++-- | Get the 'Progress' of a 'Sound'.+-- 'Progress' of '0' means that the sound has just started.+-- 'Progress' of '1' means that the sound has finished.+-- 'Progress' greater than '1' or smaller than '0' is invalid.+progress :: Sound I Progress+progress = makeSound $ \si index ->+  fromIntegral index / fromIntegral si.samples++-- | Tells you the sample index for each sample+sampleIndex :: Sound I Int+sampleIndex = makeSound (const id)
+ src/LambdaSound/Effect.hs view
@@ -0,0 +1,57 @@+module LambdaSound.Effect where++import Data.Coerce+import LambdaSound.Create+import LambdaSound.Sound++-- | Eases the volume of the sound. The given 'Int' controls the strength of the easing.+easeInOut :: Int -> Sound d Pulse -> Sound d Pulse+easeInOut strength = zipSoundWith (\p -> (f p *)) progress+  where+    f p = coerce $ -(2 * p - 1) ** (abs (fromIntegral strength) * 2) + 1++-- | Repeats a sound such that:+--+-- > repeatSound 3 sound = sound >>> sound >>> sound+repeatSound :: Int -> Sound T Pulse -> Sound T Pulse+repeatSound n s+  | n <= 0 = mempty+  | n == 1 = s+  | even n = s' >>> s'+  | otherwise = s' >>> s' >>> s+  where+    s' = repeatSound (n `quot` 2) s++-- | Plays the sound multiple times to get a simple reverb effect. The duration specifies the length of the reverb.+simpleReverb :: Duration -> Sound T Pulse -> Sound T Pulse+simpleReverb duration sound = flip foldMap (zip [1 ..] [0, (duration / 4) .. duration]) $ \(v, d) ->+  reduce v (setDuration d silence >>> sound)++-- | ADSR envelope which specifies how the volume of a sound should behave over time+data Envelope = Envelope+  { attack :: !Duration,+    decay :: !Duration,+    release :: !Duration,+    sustain :: !Float+  }+  deriving (Eq, Show)++-- | Apply an ADSR envelope to a sound+applyEnvelope :: Envelope -> Sound T Pulse -> Sound T Pulse+applyEnvelope envelope sound =+  let attack = coerce <$> progress+      decay = fmap (\p -> coerce envelope.sustain + (1 - coerce p) ** 3 * (1 - coerce envelope.sustain)) progress+      sustain = constant (coerce envelope.sustain)+      release = fmap (\p -> coerce envelope.sustain * (1 - coerce p) ** 3) progress+      adsrCurve =+        sequentially+          [ envelope.attack |-> attack,+            envelope.decay |-> decay,+            (getDuration sound - envelope.release - envelope.decay - envelope.attack) |-> sustain,+            envelope.release |-> release+          ]+   in zipSoundWith (*) adsrCurve sound++-- | Add some harmonic frequencies+harmonic :: (Hz -> Sound I Pulse) -> Hz -> Sound I Pulse+harmonic f hz = parallel $ (\x -> reduce x $ f (coerce x * hz)) <$> take 6 [1 ..]
+ src/LambdaSound/Filter.hs view
@@ -0,0 +1,81 @@+-- | This module implements IIR filters.+--+-- See: http://shepazu.github.io/Audio-EQ-Cookbook/audio-eq-cookbook.html+module LambdaSound.Filter+  ( -- * Usage+    IIRParams (..),+    applyIIRFilter,++    -- * Design+    lowPassFilter,+    highPassFilter,+    bandPassFilter,+  )+where++import Control.Monad (forM_)+import Data.Coerce (coerce)+import Data.Massiv.Array qualified as M+import Data.Massiv.Array.Unsafe qualified as MU+import Data.Maybe (fromMaybe)+import LambdaSound.Sound++-- | IIRParams contains the filter coefficients for the forward and+-- feedback computation+data IIRParams = IIRParams+  { feedforward :: !(M.Vector M.S Float),+    feedback :: !(M.Vector M.S Float)+  }+  deriving (Show)++-- | A low-pass filter using cutoff frequency and resonance.+lowPassFilter :: Hz -> Float -> SamplingInfo -> IIRParams+lowPassFilter freq q si =+  IIRParams (M.fromList M.Seq [b0, 1 - cos w0, b0]) (M.fromList M.Seq [1 + a, -2 * cos w0, 1 - a])+  where+    b0 = (1 - cos w0) / 2+    w0 = calcW0 si.sampleRate scaledFreq+    a = calcAQ w0 q+    scaledFreq = freq / (si.sampleRate * coerce (si.period))++-- | A high-pass filter using cutoff frequency and resonance.+highPassFilter :: Hz -> Float -> SamplingInfo -> IIRParams+highPassFilter freq q si =+  IIRParams (M.fromList M.Seq [b0, -1 - cos w0, b0]) (M.fromList M.Seq [1 + a, -2 * cos w0, 1 - a])+  where+    b0 = (1 + cos w0) / 2+    w0 = calcW0 si.sampleRate scaledFreq+    a = calcAQ w0 q+    scaledFreq = freq / (si.sampleRate * coerce (si.period))++-- | A band pass filter using cutoff frequency and resonance.+bandPassFilter :: Hz -> Float -> SamplingInfo -> IIRParams+bandPassFilter freq q si =+  IIRParams (M.fromList M.Seq [a, 0, -1 * a]) (M.fromList M.Seq [1 + a, -2 * cos w0, 1 - a])+  where+    w0 = calcW0 si.sampleRate scaledFreq+    a = calcAQ w0 q+    scaledFreq = freq / (si.sampleRate * coerce (si.period))++calcW0 :: Hz -> Hz -> Float+calcW0 sampleRate freq = coerce $ 2 * pi * freq / sampleRate++calcAQ :: Float -> Float -> Float+calcAQ _ 0 = 0+calcAQ w0 q = sin w0 / (2 * q)++-- | Applies the IIR filter defined by the 'IIRParams' to the sound.+applyIIRFilter :: (SamplingInfo -> IIRParams) -> Sound d Pulse -> Sound d Pulse+applyIIRFilter makeParams sound = adoptDuration sound $ withSamplingInfo $ \si ->+  applyFilter (makeParams si) sound+  where+    applyFilter :: IIRParams -> Sound d Pulse -> Sound d Pulse+    applyFilter (IIRParams feedforward feedback') =+      let (currentCoefficient, feedback) = (coerce $ M.defaultIndex 1 feedback' 0, M.tail feedback')+       in modifyWholeSoundST $ \source dest -> do+            forM_ [0 .. pred (M.unSz $ M.sizeOfMArray dest)] $ \index -> do+              let sourceValues = M.imap (\i v -> coerce v * M.defaultIndex 0 source (index - i)) feedforward+              recursiveValues <- M.itraversePrim @M.S (\i v -> (coerce v *) . fromMaybe 0 <$> M.read dest (index - succ i)) feedback++              let currentValue = (M.sum sourceValues - M.sum recursiveValues) / currentCoefficient+              MU.unsafeWrite dest index currentValue
+ src/LambdaSound/Note.hs view
@@ -0,0 +1,113 @@+-- |+-- This module has some functions to use sound notation concepts like semitones for pitch and quarternotes for duration+module LambdaSound.Note where++import LambdaSound.Sound++-- | Semitones are tones like 'c4', 'd4' or 'c5'.+-- The semitone is used to determine the hz of the tone based on 'pitchStandard'+newtype Semitone = Semitone Int deriving (Show, Eq, Num, Ord, Enum)++-- | 440 Hz is used at the pitch standard for the tone 'a4'+pitchStandard :: Hz+pitchStandard = 440.0++-- | Converts a semitone to the appropriate frequency based on 'pitchStandard'+semitoneToHz :: Semitone -> Hz+semitoneToHz n = pitchStandard * (2 ** (fromIntegral (fromEnum n) * 1.0 / 12.0))++-- | Raise a sound by the given amount of semitones.+-- This only works for sounds which use the period length given+-- in the compute step of the sound. 'pulse' works but 'noise' does not.+-- For example:+-- > raiseSemitones 2 (asNote pulse c3) = asNote pulse d3+raiseSemitones :: Int -> Sound d Pulse -> Sound d Pulse+raiseSemitones x = raise (2 ** (fromIntegral x / 12))++-- | Diminishes a sound by the given amount of semitones+diminishSemitones :: Int -> Sound d Pulse -> Sound d Pulse+diminishSemitones x = raiseSemitones (-x)++-- | Transforms a function taking a 'Hz' to one taking a 'Semitone'.+-- Should be used with 'pulse' or 'harmonic'+asNote :: (Hz -> a) -> Semitone -> a+asNote f s = f (semitoneToHz s)++c1, d1, e1, f1, g1, a1, b1 :: Semitone+c1 = -45+d1 = -43+e1 = -41+f1 = -40+g1 = -38+a1 = -36+b1 = -34++c2, d2, e2, f2, g2, a2, b2 :: Semitone+c2 = -33+d2 = -31+e2 = -29+f2 = -28+g2 = -26+a2 = -24+b2 = -22++c3, d3, e3, f3, g3, a3, b3 :: Semitone+c3 = -21+d3 = -19+e3 = -17+f3 = -16+g3 = -14+a3 = -12+b3 = -10++c4, d4, e4, f4, g4, a4, b4 :: Semitone+c4 = -9+d4 = -7+e4 = -5+f4 = -4+g4 = -2+a4 = 0+b4 = 2++c5, d5, e5, f5, g5, a5, b5 :: Semitone+c5 = 3+d5 = 5+e5 = 7+f5 = 8+g5 = 10+a5 = 12+b5 = 14++c6, d6, e6, f6, g6, a6, b6 :: Semitone+c6 = 15+d6 = 17+e6 = 19+f6 = 20+g6 = 22+a6 = 24+b6 = 26++c7, d7, e7, f7, g7, a7, b7 :: Semitone+c7 = 27+d7 = 29+e7 = 31+f7 = 32+g7 = 34+a7 = 36+b7 = 38++-- ** Notes++-- | These are durations for the corresponding note lenghts+-- assuming 60 bpm.+--+-- If you know that a sound has 60 bpm, you can easily scale to+-- different bpm with 'scaleDuration':+-- @+-- scaleDuration (wantedBPM / 60) soundWith60BPM+-- @+wholeNote, halfNote, quarterNote, eightNote :: Duration+wholeNote = 1+halfNote = 1 / 2+quarterNote = 1 / 4+eightNote = 1 / 8
+ src/LambdaSound/Play.hs view
@@ -0,0 +1,40 @@+module LambdaSound.Play (play) where++import Control.Concurrent (threadDelay)+import Control.Monad (guard, when)+import Data.Massiv.Array qualified as M+import Data.Vector.Storable.ByteString (vectorToByteString)+import LambdaSound.Sampling+import LambdaSound.Sound+import Sound.ProteaAudio.SDL qualified as PA++-- | Play the sound with the given sample rate and the given volume.+--+-- You need to have SDL2 installed for playing!+play :: Int -> Float -> Sound T Pulse -> IO ()+play sampleRate volume sound = do+  samples <- sampleSound (realToFrac sampleRate) sound+  playSamples sampleRate volume samples++playSamples :: Int -> Float -> M.Vector M.S Pulse -> IO ()+playSamples sampleRate volume samples = do+  PA.initAudio 1 sampleRate 1024 >>= guard++  let floatBytes =+        vectorToByteString $+          M.toStorableVector+            samples++  sample <- PA.sampleFromMemoryPcm floatBytes 1 sampleRate 32 volume+  _sound <- PA.soundPlay sample 1 1 0 1++  waitPlayback++  PA.finishAudio++waitPlayback :: IO ()+waitPlayback = do+  n <- PA.soundActiveAll+  when (n > 0) $ do+    threadDelay 1000+    waitPlayback
+ src/LambdaSound/Plot.hs view
@@ -0,0 +1,52 @@+module LambdaSound.Plot (plot, plotPart) where++import Data.Massiv.Array qualified as M+import Data.Text (Text, append, pack)+import Data.Text.IO qualified as T+import LambdaSound.Sound+import LambdaSound.Sampling (sampleSound)+import Data.Coerce (coerce)+import System.Console.ANSI++-- | Plots a sound in the terminal+plot :: Sound T Pulse -> IO ()+plot sound = plotPart (0, getDuration sound) sound++-- | Plots part of a sound in the terminal+plotPart :: (Duration, Duration) -> Sound T Pulse -> IO ()+plotPart (lD, rD) sound = do +  cols <- maybe 80 snd <$> getTerminalSize+  let hz = coerce $ fromIntegral cols * (1 / (rD - lD))+      soundPart = takeSound (rD - lD) $ dropSound lD sound+  txt <- tabulateSamples 10 <$> sampleSound hz soundPart+  T.putStrLn txt++tabulateSamples :: Int -> M.Vector M.S Pulse -> Text+tabulateSamples rows samples =+  let maxSample = M.maximum' samples+      minSample = M.minimum' samples+      preparedSamples = M.compute $ M.map (\s -> (s - minSample) / (maxSample - minSample) * fromIntegral rows) samples+   in foldMap (drawRow preparedSamples) [0 .. rows]+  where+    drawRow :: M.Vector M.S Pulse -> Int -> Text+    drawRow preparedSamples r =+      append (pack "\n") $+        pack $+          M.toList $+            M.map+              ( \p ->+                  let x = p - fromIntegral r+                   in if x >= 0 && x < 1 +                        then+                          if x < (1 / 3)+                            then topDot+                            else+                              if x < (2 / 3)+                                then middleDot+                                else bottomDot+                        else ' '+              )+              preparedSamples+    topDot = '˙'+    middleDot = '·'+    bottomDot = '.'
+ src/LambdaSound/Samples.hs view
@@ -0,0 +1,57 @@+-- | This module contains some basic samples which can be combined to+-- generate interesting sounds +module LambdaSound.Samples where++import Data.Coerce+import Data.Fixed (mod')+import Data.Massiv.Array qualified as M+import Data.Massiv.Array.Unsafe qualified as MU+import LambdaSound.Sound+import System.Random as R+import LambdaSound.Create++-- | Pure sinus sound+--+-- Warm and round+sineWave :: Hz -> Sound I Pulse+sineWave hz = (\t -> sin (coerce hz * coerce t * 2 * pi)) <$> time++-- | Triangle wave+--+-- Similar to sine but colder+triangleWave :: Hz -> Sound I Pulse+triangleWave hz =+  fmap+    ( \t ->+        let x = (coerce hz * coerce t) `mod'` 1+         in if x < 0.5+              then x * 4 - 1+              else 3 - x * 4+    )+    time++-- | Sawtooth wave+--+-- Warm and sharp+sawWave :: Hz -> Sound I Pulse+sawWave hz = (\t -> (coerce hz * coerce t * 2) `mod'` 2 - 1) <$> time++-- | Produces a square wave+--+-- Cold+squareWave :: Hz -> Sound I Pulse+squareWave hz = (\t -> fromIntegral @Int $ round ((coerce hz * t) `mod'` 1) * 2 - 1) <$> time++-- | Random noise between (-1,1). The given value is used as the seed value,+-- so the same seed will result in the same noise+noise :: Int -> Sound I Pulse+noise initial =+  computeOnce+    ( \sr ->+        M.compute @M.S $+          M.unfoldrS_+            (M.Sz1 sr.samples)+            (R.uniformR (-1, 1))+            (mkStdGen initial)+    )+    (fmap Pulse . flip MU.unsafeIndex <$> sampleIndex)
+ src/LambdaSound/Sampling.hs view
@@ -0,0 +1,64 @@+-- | 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++import Codec.Audio.Wave+import Data.ByteString qualified as B+import Data.Massiv.Array qualified as M+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)+sampleSoundRaw hz (TimedSound duration msc) = do+  let sr = makeSamplingInfo hz duration+  sampleComputeSound sr msc++-- | Samples a sound with the given frequency (usually 44100 is good) with post-processing+--+-- This is recommended over 'sampleSoundRaw' if you are unsure+sampleSound :: Hz -> Sound T Pulse -> IO (M.Vector M.S Pulse)+sampleSound hz sound =+  M.compute . postProcess <$> sampleSoundRaw hz sound++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.+-- This is very important if you use the parallel combinator since+-- parallel sounds are awful without post processing.+compressDynamically :: (M.Source r Pulse) => M.Vector r Pulse -> M.Vector M.D Pulse+compressDynamically signal = M.map (scaleToMax . sigmoid) signal+  where+    scaleToMax x = (1 / sigmoid maxPulse) * x+    sigmoid x = 2 / (1 + exp (g * (-x))) - 1+    g = logBase (2 - factor) factor / (-maxPulse)+    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
+ src/LambdaSound/Sound.hs view
@@ -0,0 +1,386 @@+-- |+-- This module exports all needed datatypes and all the combinators needed to manipulate them.+module LambdaSound.Sound+  ( -- ** Sound types+    Sound (..),+    SoundDuration (..),+    Pulse (..),+    Duration (..),+    Progress (..),+    Percentage (..),+    SamplingInfo (..),+    Hz (..),+    Time (..),+    DetermineDuration,++    -- ** Make new sounds+    -- Also take a look at @LambdaSound.Create@!+    makeSound,+    makeSoundVector,+    fillWholeSound,+    fillWholeSoundST,+    computeOnce,++    -- ** Sounds in sequence+    timedSequentially,+    (>>>),+    sequentially,+    infiniteSequentially,++    -- ** Sounds in parallel+    parallel2,+    parallel,++    -- ** Volume+    amplify,+    reduce,++    -- ** Pitch+    raise,+    diminish,++    -- ** Duration+    setDuration,+    (|->),+    getDuration,+    scaleDuration,+    dropDuration,+    adoptDuration,++    -- ** Sample order+    reverseSound,+    dropSound,+    takeSound,++    -- ** Zipping+    zipSoundWith,+    zipSound,++    -- ** Change play behavior of a sound+    changeTempo,+    changeTempoM,++    -- ** Modify the samples of a sound+    modifyWholeSound,+    modifyWholeSoundST,+    withSamplingInfo,+  )+where++import Control.Monad.ST+import Data.Coerce (coerce)+import Data.Foldable (foldl')+import Data.Massiv.Array qualified as M+import Data.Massiv.Array.Unsafe qualified as MU+import LambdaSound.Sound.ComputeSound+import LambdaSound.Sound.Types+import System.IO.Unsafe (unsafePerformIO)++-- | Some 'Sound's have a different while others do not.+-- 'I'nfinite 'Sound's have no duration.+-- 'T'imed 'Sound's have a duration.+data SoundDuration = I | T++-- | Determines the duration of two sounds when they are combined+type family DetermineDuration (d1 :: SoundDuration) (d2 :: SoundDuration) where+  DetermineDuration I d = d+  DetermineDuration d I = d+  DetermineDuration T _ = T+  DetermineDuration _ T = T++data Sound (d :: SoundDuration) a where+  TimedSound ::+    !Duration ->+    ComputeSound a ->+    Sound T a+  InfiniteSound ::+    ComputeSound a ->+    Sound I a++-- data SoundType d where+--   InfiniteSoundType :: SoundType I+--   TimedSoundType :: SoundType T++-- class DetermineSoundType d where+--   determineSoundType :: SoundType d++-- instance DetermineSoundType I where+--   determineSoundType = InfiniteSoundType++-- instance DetermineSoundType T where+--   determineSoundType = TimedSoundType++getCS :: Sound d a -> ComputeSound a+getCS (InfiniteSound cs) = cs+getCS (TimedSound _ cs) = cs++mapComputation :: (ComputeSound a -> ComputeSound b) -> Sound d a -> Sound d b+mapComputation f (InfiniteSound cs) = InfiniteSound $ f cs+mapComputation f (TimedSound d cs) = TimedSound d $ f cs++instance Show (Sound d Pulse) where+  show (TimedSound d c) = showSampledCompute d c+  show (InfiniteSound c) = showSampledCompute 3 c++showSampledCompute :: Duration -> ComputeSound Pulse -> String+showSampledCompute d cs = unsafePerformIO $ do+  let si = makeSamplingInfo (coerce $ 25 / d) d+  floats <- sampleComputeSound si cs+  pure $ show $ M.toList floats++instance Semigroup (Sound d Pulse) where+  -- \| Combines two sounds in a parallel manner (see 'parallel2')+  (<>) = parallel2++instance Monoid (Sound I Pulse) where+  mempty = pure 0++instance Monoid (Sound T Pulse) where+  mempty = TimedSound 0 $ makeWithIndexFunction $ const $ const 0++instance (Num a) => Num (Sound I a) where+  (+) = zipSoundWith (+)+  (*) = zipSoundWith (*)+  (-) = zipSoundWith (-)+  abs = fmap abs+  fromInteger x = makeSound $ \_ _ -> fromInteger x+  signum = fmap signum+  negate = fmap negate++instance Functor (Sound d) where+  fmap f = mapComputation $ mapComputeSound f++instance Applicative (Sound I) where+  pure a = makeSound $ \_ _ -> a+  (<*>) = zipSoundWith ($)++-- | Append two sounds. This is only possible for sounds with a duration.+timedSequentially :: Sound T Pulse -> Sound T Pulse -> Sound T Pulse+timedSequentially (TimedSound d1 c1) (TimedSound d2 c2) =+  TimedSound (d1 + d2) $+    computeSequentially (coerce $ d1 / (d1 + d2)) c1 c2++-- | Append two infinite sounds where the 'Percentage' in the range @[0,1]@+-- specified when the first sound ends and the next begins.+infiniteSequentially :: Percentage -> Sound I Pulse -> Sound I Pulse -> Sound I Pulse+infiniteSequentially factor' (InfiniteSound c1) (InfiniteSound c2) =+  InfiniteSound $+    computeSequentially factor c1 c2+  where+    factor = max 0 $ min 1 factor'++-- | Same as 'timedSequentially'+(>>>) :: Sound T Pulse -> Sound T Pulse -> Sound T Pulse+(>>>) = timedSequentially++infixl 5 >>>++-- | Combine a list of sounds in a sequential manner.+sequentially :: [Sound T Pulse] -> Sound T Pulse+sequentially = foldl' timedSequentially mempty++-- | Combine two sounds such that they play in parallel. If one 'Sound' is longer than the other,+-- it will be played without the shorter one for its remaining time+parallel2 :: Sound d Pulse -> Sound d Pulse -> Sound d Pulse+parallel2 (InfiniteSound c1) (InfiniteSound c2) = InfiniteSound $ computeParallel c1 1 c2+parallel2 (TimedSound d1 c1) (TimedSound d2 c2) = TimedSound newDuration $ computeParallel longerC (coerce factor) shorterC+  where+    (longerC, factor, shorterC) =+      if d1 >= d2+        then (c1, d2 / newDuration, c2)+        else (c2, d1 / newDuration, c1)+    newDuration = max d1 d2++-- | Combine a lists of sounds such that they play in parallel+parallel :: (Monoid (Sound d Pulse)) => [Sound d Pulse] -> Sound d Pulse+parallel = foldl' parallel2 mempty++-- | Zip two 'Sound's. The duration of the resulting 'Sound' is equivalent+-- to the duration of the shorter 'Sound', cutting away the excess samples from the longer one.+zipSoundWith :: (a -> b -> c) -> Sound d1 a -> Sound d2 b -> Sound (DetermineDuration d1 d2) c+zipSoundWith f sound1 sound2 =+  case (sound1, sound2) of+    (TimedSound d1 _, TimedSound d2 _) ->+      let d = min d1 d2+       in case (takeSound d sound1, takeSound d sound2) of+            (TimedSound _ c1, TimedSound _ c2) -> TimedSound d $ zipWithCompute f c1 c2+    (TimedSound d c1, InfiniteSound c2) -> TimedSound d $ zipWithCompute f c1 c2+    (InfiniteSound c1, TimedSound d c2) -> TimedSound d $ zipWithCompute f c1 c2+    (InfiniteSound c1, InfiniteSound c2) -> InfiniteSound $ zipWithCompute f c1 c2++-- | Zip two 'Sound's. The duration of the resulting 'Sound' is equivalent+-- to the duration of the shorter 'Sound', cutting away the excess samples from the longer one.+zipSound :: Sound d1 (a -> b) -> Sound d2 a -> Sound (DetermineDuration d1 d2) b+zipSound = zipSoundWith ($)++-- | Amplifies the volume of the given 'Sound'+amplify :: Float -> Sound d Pulse -> Sound d Pulse+amplify x = fmap (* coerce x)++-- | Reduces the volume of the given 'Sound'+reduce :: Float -> Sound d Pulse -> Sound d Pulse+reduce x = amplify (1 / x)++-- | Raises the frequency of the 'Sound' by the given factor.+-- Only works if the sound is based on some frequency (e.g. 'sineWave' but not 'noise')+raise :: Float -> Sound d Pulse -> Sound d Pulse+raise x = mapComputation $ \(ComputeSound compute) -> ComputeSound $ \si memo -> do+  compute (si {period = coerce x * si.period}) memo++-- | Diminishes the frequency of the 'Sound' by the given factor.+-- Only works if the sound is based on some frequency (e.g. 'pulse' but not 'noise')+diminish :: Float -> Sound d Pulse -> Sound d Pulse+diminish x = raise $ 1 / x++-- | Sets the duration of the 'Sound'.+-- The resuling sound is a 'T'imed 'Sound'.+setDuration :: Duration -> Sound d a -> Sound T a+setDuration d (TimedSound _ c) = TimedSound (max d 0) c+setDuration d (InfiniteSound c) = TimedSound (max d 0) c++-- | Same as `setDuration` but in operator form.+(|->) :: Duration -> Sound d a -> Sound 'T a+(|->) = setDuration++infix 7 |->++-- | Drop the duration associated with a 'Sound' and get an infinite sound again.+-- If you have combined timed sounds with a sequence combinator and then drop+-- their 'Duration', the sounds will keep their proportional length to each other.+-- Essentially, the percentage of their play time stays the same.+dropDuration :: Sound d a -> Sound I a+dropDuration (InfiniteSound cs) = InfiniteSound cs+dropDuration (TimedSound _ cs) = InfiniteSound cs++-- | Scales the 'Duration' of a 'Sound'.+-- The following makes a sound twice as long:+--+-- > scaleDuration 2 sound+scaleDuration :: Float -> Sound T a -> Sound T a+scaleDuration x (TimedSound d c) = TimedSound (coerce x * d) c++-- | Get the duration of a 'T'imed 'Sound'+getDuration :: Sound T a -> Duration+getDuration (TimedSound d _) = d++-- | Set the 'Duration' of a 'Sound' to the same as another one 'Sound'+adoptDuration :: Sound d a -> Sound x b -> Sound d b+adoptDuration (TimedSound duration _) = setDuration duration+adoptDuration (InfiniteSound _) = dropDuration++-- | Reverses a 'Sound' similar to 'reverse' for lists+reverseSound :: Sound d a -> Sound d a+reverseSound = mapComputation $ mapDelayedResult $ \si ->+  MU.unsafeBackpermute (M.Sz1 si.samples) (\index -> pred si.samples - index)++-- | Drop parts of a sound similar to 'drop' for lists+dropSound :: Duration -> Sound T a -> Sound T a+dropSound dropD' (TimedSound originalD cs) =+  TimedSound (originalD - dropD) $+    withSamplingInfoCS $ \oldSI ->+      changeSamplingInfo (\si -> si {samples = round $ factor * fromIntegral si.samples}) $+        mapDelayedResult+          ( \newSI ->+              MU.unsafeBackpermute (M.Sz1 oldSI.samples) $ \index ->+                index + newSI.samples - oldSI.samples+          )+          cs+  where+    dropD = max 0 $ min originalD dropD'+    droppedFactor = min 1 $ dropD / originalD+    factor =+      if droppedFactor == 1+        then 0+        else 1 / (1 - droppedFactor)++-- | Take parts of a sound similar to 'take' for lists+takeSound :: Duration -> Sound T a -> Sound T a+takeSound takeD' (TimedSound originalD cs) =+  TimedSound takeD $+    withSamplingInfoCS $ \oldSI ->+      changeSamplingInfo+        ( \si ->+            si+              { samples =+                  if takeD == 0+                    then 0+                    else round $ fromIntegral @_ @Float si.samples * (1 / coerce factor)+              }+        )+        $ mapDelayedResult+          (\_ -> M.slice' 0 $ M.Sz1 oldSI.samples)+          cs+  where+    takeD = max 0 $ min takeD' originalD+    factor = takeD / originalD++-- | Change how the 'Sound' progresses. For example, you can slow it+-- down in the beginning and speed it up at the end. However, the total+-- duration stays the same.+--+-- Negative 'Progress' is treated as '0' and 'Progress' above '1' is treated as '1'+changeTempo :: (Progress -> Progress) -> Sound d a -> Sound d a+changeTempo f = mapComputation $ mapDelayedResult $ \si ->+  MU.unsafeBackpermute (M.Sz1 si.samples) $ \index ->+    min si.samples $+      round $+        f+          (fromIntegral index / fromIntegral si.samples)+          * fromIntegral si.samples++changeTempoM :: Sound I (Progress -> Progress) -> Sound d a -> Sound d a+changeTempoM (InfiniteSound msc1) =+  mapComputation $+    mergeDelayedResult+      ( \si progressVector valueVector ->+          M.makeArray M.Seq (M.Sz1 si.samples) $ \index ->+            MU.unsafeIndex valueVector $+              min si.samples $+                round $+                  MU.unsafeIndex+                    progressVector+                    index+                    (fromIntegral index / fromIntegral si.samples)+                    * fromIntegral si.samples+      )+      msc1++-- | Compute a value once and then reuse it while computing all samples+computeOnce :: (SamplingInfo -> a) -> Sound d (a -> b) -> Sound d b+computeOnce f = mapComputation $ mapDelayedResult $ \si ->+  let a = f si+   in M.map ($ a)++-- | Fill a sound with a vector of sound samples. Keep in mind that the vector has the appropriate length!+fillWholeSound :: (M.Load r M.Ix1 Pulse) => (SamplingInfo -> M.Vector r Pulse) -> Sound I Pulse+fillWholeSound f = InfiniteSound $ fillSoundInMemoryIO $ \si dest -> do+  let vector = f si+  M.computeInto dest vector++-- | Fill a sound with a vector of sound samples in a mutable fashion.+fillWholeSoundST :: (SamplingInfo -> M.MVector M.RealWorld M.S Pulse -> ST M.RealWorld ()) -> Sound I Pulse+fillWholeSoundST f = InfiniteSound $ fillSoundInMemoryIO $ fmap stToIO . f++-- | Modify all samples of a sound so that you can look into the past and future+-- of a sound (e.g. IIR filter).+modifyWholeSound :: (M.Load r M.Ix1 Pulse) => (M.Vector M.S Pulse -> M.Vector r Pulse) -> Sound d Pulse -> Sound d Pulse+modifyWholeSound f = mapComputation $ mapSoundFromMemory f++-- | Modify all samples of a sound so that you can look into the past and future+-- of a sound (e.g. IIR filter).+modifyWholeSoundST :: (M.Vector M.S Pulse -> M.MVector M.RealWorld M.S Pulse -> ST M.RealWorld ()) -> Sound d Pulse -> Sound d Pulse+modifyWholeSoundST f = mapComputation $ mapSoundFromMemoryIO $ fmap stToIO . f++-- | Access the sample rate of an infinite sound+withSamplingInfo :: (SamplingInfo -> Sound d a) -> Sound I a+withSamplingInfo f = InfiniteSound $ withSamplingInfoCS (getCS . f)++-- | Calculate sound samples based on their index.+-- Take a look at @LambdaSound.Create@ for other creation functions.+makeSound :: (SamplingInfo -> Int -> a) -> Sound I a+makeSound f = InfiniteSound $ makeWithIndexFunction f++-- | Calculate the samples of the sound as one vector+-- 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
+ src/LambdaSound/Sound/ComputeSound.hs view
@@ -0,0 +1,256 @@+module LambdaSound.Sound.ComputeSound where++import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.HashTable.IO qualified as H+import Data.Hashable+import Data.Massiv.Array qualified as M+import Data.Massiv.Array.Unsafe qualified as MU+import Data.SomeStableName (SomeStableName, makeSomeStableName)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Marshal (copyBytes)+import Foreign.Storable (Storable (..))+import GHC.Generics (Generic)+import LambdaSound.Sound.Types++makeWithIndexFunction :: (SamplingInfo -> Int -> a) -> ComputeSound a+makeWithIndexFunction f = makeDelayedResult $ \si ->+  let f' = f si+   in M.makeArray M.Seq (M.Sz1 si.samples) f'+{-# INLINE makeWithIndexFunction #-}++makeDelayedResult :: (SamplingInfo -> M.Vector M.D a) -> ComputeSound a+makeDelayedResult f = ComputeSound $ \si _ -> do+  stableF <- makeSomeStableName f+  pure (DelayedResult $ f si, ComputationInfoMakeDelayedResult stableF)+{-# INLINE makeDelayedResult #-}++changeSamplingInfo :: (SamplingInfo -> SamplingInfo) -> ComputeSound a -> ComputeSound a+changeSamplingInfo changeSI (ComputeSound compute) = ComputeSound $ \si memo -> do+  stableChangeSI <- makeSomeStableName changeSI+  (result, ci) <- compute (changeSI si) memo+  pure (result, ComputationInfoChangeSamplingInfo stableChangeSI ci)+{-# INLINE changeSamplingInfo #-}++mapDelayedResult :: (SamplingInfo -> M.Vector M.D a -> M.Vector M.D b) -> ComputeSound a -> ComputeSound b+mapDelayedResult mapVector cs = ComputeSound $ \si memo -> do+  (delayedVector, ci) <- asDelayedResult cs si memo+  stableMapVector <- makeSomeStableName mapVector+  let mapVector' = mapVector si+  pure (DelayedResult $ mapVector' delayedVector, ComputationInfoMapDelayedResult stableMapVector ci)+{-# INLINE mapDelayedResult #-}++withSamplingInfoCS :: (SamplingInfo -> ComputeSound a) -> ComputeSound a+withSamplingInfoCS f = ComputeSound $ \si memo ->+  let (ComputeSound compute) = f si+   in compute si memo+{-# INLINE withSamplingInfoCS #-}++mergeDelayedResult :: (SamplingInfo -> M.Vector M.D a -> M.Vector M.D b -> M.Vector M.D c) -> ComputeSound a -> ComputeSound b -> ComputeSound c+mergeDelayedResult merge cs1 cs2 = ComputeSound $ \si memo -> do+  stableMerge <- makeSomeStableName merge+  (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)+{-# INLINE mergeDelayedResult #-}++computeSequentially :: Percentage -> ComputeSound Pulse -> ComputeSound Pulse -> ComputeSound Pulse+computeSequentially factor c1 c2 = ComputeSound $ \si memo -> do+  let splitIndex =+        round $+          factor * fromIntegral si.samples+  (writeResult1, ci1) <- asWriteResult c1 si {samples = splitIndex} memo+  (writeResult2, ci2) <- asWriteResult c2 si {samples = si.samples - splitIndex} memo+  pure+    ( WriteResult $ \dest -> do+        writeResult1 $ MU.unsafeLinearSliceMArray 0 (M.Sz1 splitIndex) dest+        writeResult2 $ MU.unsafeLinearSliceMArray splitIndex (M.Sz1 $ si.samples - splitIndex) dest,+      ComputationInfoSequentially ci1 ci2+    )+{-# INLINE computeSequentially #-}++computeParallel :: ComputeSound Pulse -> Float -> ComputeSound Pulse -> ComputeSound Pulse+computeParallel c1 factor c2 = ComputeSound $ \si memo -> do+  let c2N = round $ factor * fromIntegral si.samples+  (delayedResult1, p1) <- asDelayedResult c1 si memo+  (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,+      ComputationInfoParallel p1 p2+    )+{-# INLINE computeParallel #-}++mapComputeSound :: (a -> b) -> ComputeSound a -> ComputeSound b+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)+{-# INLINE mapComputeSound #-}++asDelayedResult ::+  ComputeSound a ->+  SamplingInfo ->+  MemoComputeSound ->+  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)+{-# INLINE asDelayedResult #-}++asWriteResult ::+  ComputeSound Pulse ->+  SamplingInfo ->+  MemoComputeSound ->+  IO (M.MVector M.RealWorld M.S Pulse -> IO (), ComputationInfo)+asWriteResult (ComputeSound compute) si memo = do+  (result, ci) <- compute si memo+  case result of+    WriteResult writeResult -> pure (writeResult, ci)+    DelayedResult vector -> do+      let memoInfo = MemoInfo si ci+      pure+        ( \dest -> do+            memoized <- lookupMemoizedComputeSound memo memoInfo+            case memoized of+              Just memoSource ->+                copyArrayIntoMArray memoSource dest+              Nothing -> do+                M.computeInto dest vector+                destArray <- MU.unsafeFreeze M.Seq dest+                memoizeComputeSound memo memoInfo destArray,+          ci+        )+{-# INLINE asWriteResult #-}++zipWithCompute :: (a -> b -> c) -> ComputeSound a -> ComputeSound b -> ComputeSound c+zipWithCompute f cs1 cs2 = ComputeSound $ \si memo -> do+  (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)+{-# INLINE zipWithCompute #-}++mapSoundFromMemory :: (M.Load r M.Ix1 Pulse) => (M.Vector M.S Pulse -> M.Vector r Pulse) -> ComputeSound Pulse -> ComputeSound Pulse+mapSoundFromMemory f cs = ComputeSound $ \si memo -> do+  (writeSamples, ci) <- asWriteResult cs si memo+  stableF <- makeSomeStableName f+  pure+    ( WriteResult $ \dest -> do+        wholeSoundMArray <- MU.unsafeMallocMArray (M.Sz1 si.samples)+        writeSamples wholeSoundMArray+        wholeSoundArray <- MU.unsafeFreeze M.Seq wholeSoundMArray+        M.computeInto dest $ f wholeSoundArray,+      ComputationInfoMapMemory stableF ci+    )+{-# INLINE mapSoundFromMemory #-}++mapSoundFromMemoryIO :: (M.Vector M.S Pulse -> M.MVector M.RealWorld M.S Pulse -> IO ()) -> ComputeSound Pulse -> ComputeSound Pulse+mapSoundFromMemoryIO f cs = ComputeSound $ \si memo -> do+  (writeSamples, ci) <- asWriteResult cs si memo+  stableF <- makeSomeStableName f+  pure+    ( WriteResult $ \dest -> do+        wholeSoundMArray <- MU.unsafeMallocMArray (M.Sz1 si.samples)+        writeSamples wholeSoundMArray+        wholeSoundArray <- MU.unsafeFreeze M.Seq wholeSoundMArray+        f wholeSoundArray dest,+      ComputationInfoMapMemory stableF ci+    )+{-# INLINE mapSoundFromMemoryIO #-}++fillSoundInMemoryIO :: (SamplingInfo -> M.MVector M.RealWorld M.S Pulse -> IO ()) -> ComputeSound Pulse+fillSoundInMemoryIO f = ComputeSound $ \si _ -> do+  stableF <- makeSomeStableName f+  let f' = f si+  pure+    ( WriteResult $ \dest -> do+        f' dest,+      ComputationInfoFillMemory stableF+    )+{-# INLINE fillSoundInMemoryIO #-}++pulseSize :: Int+pulseSize = sizeOf (undefined :: Pulse)+{-# INLINE pulseSize #-}++sampleComputeSound :: SamplingInfo -> ComputeSound Pulse -> IO (M.Vector M.S Pulse)+sampleComputeSound si cs = do+  hashTable <- H.new+  destArray <- MU.unsafeMallocMArray $ M.Sz1 si.samples+  (writeResult, _) <- asWriteResult cs si (MemoComputeSound hashTable)+  writeResult destArray+  MU.unsafeFreeze M.Seq destArray+{-# INLINE sampleComputeSound #-}++newtype MemoComputeSound = MemoComputeSound (H.BasicHashTable MemoInfo (M.Vector M.S Pulse))++data MemoInfo = MemoInfo+  { samplingInfo :: !SamplingInfo,+    computationInfo :: !ComputationInfo+  }+  deriving (Eq, Generic)++instance Hashable MemoInfo++lookupMemoizedComputeSound :: MemoComputeSound -> MemoInfo -> IO (Maybe (M.Vector M.S Pulse))+lookupMemoizedComputeSound (MemoComputeSound memoTable) memoInfo = do+  H.lookup memoTable memoInfo+{-# INLINE lookupMemoizedComputeSound #-}++memoizeComputeSound :: MemoComputeSound -> MemoInfo -> M.Vector M.S Pulse -> IO ()+memoizeComputeSound (MemoComputeSound hashTable) memoInfo vec = do+  H.insert hashTable memoInfo vec+{-# INLINE memoizeComputeSound #-}++newtype ComputeSound a = ComputeSound+  { compute ::+      SamplingInfo ->+      MemoComputeSound ->+      IO (SoundResult a, ComputationInfo)+  }++data SoundResult a where+  WriteResult :: (M.MVector M.RealWorld M.S Pulse -> IO ()) -> SoundResult Pulse+  DelayedResult :: M.Vector M.D a -> SoundResult a++data ComputationInfo+  = ComputationInfoZip SomeStableName ComputationInfo ComputationInfo+  | ComputationInfoMap SomeStableName ComputationInfo+  | ComputationInfoSequentially ComputationInfo ComputationInfo+  | ComputationInfoParallel ComputationInfo ComputationInfo+  | ComputationInfoMakeDelayedResult SomeStableName+  | ComputationInfoMapDelayedResult SomeStableName ComputationInfo+  | ComputationInfoMergeDelayedResult SomeStableName ComputationInfo ComputationInfo+  | ComputationInfoMapMemory SomeStableName ComputationInfo+  | ComputationInfoFillMemory SomeStableName+  | ComputationInfoChangeSamplingInfo SomeStableName ComputationInfo+  deriving (Eq, Generic, Show)++instance Hashable ComputationInfo++copyArrayIntoMArray :: M.Vector M.S Pulse -> M.MVector M.RealWorld M.S Pulse -> IO ()+copyArrayIntoMArray source dest =+  let (sourceFPtr, _) = MU.unsafeArrayToForeignPtr source+      (destFPtr, _) = MU.unsafeMArrayToForeignPtr dest+   in liftIO $ withForeignPtr sourceFPtr $ \sourcePtr ->+        withForeignPtr destFPtr $ \destPtr ->+          copyBytes destPtr sourcePtr (M.unSz (M.size source) * pulseSize)+{-# INLINE copyArrayIntoMArray #-}++copyMArrayIntoMArray :: M.MVector M.RealWorld M.S Pulse -> M.MVector M.RealWorld M.S Pulse -> IO ()+copyMArrayIntoMArray source dest =+  let (sourceFPtr, _) = MU.unsafeMArrayToForeignPtr source+      (destFPtr, _) = MU.unsafeMArrayToForeignPtr dest+   in liftIO $ withForeignPtr sourceFPtr $ \sourcePtr ->+        withForeignPtr destFPtr $ \destPtr ->+          copyBytes destPtr sourcePtr (M.unSz (M.sizeOfMArray source) * pulseSize)+{-# INLINE copyMArrayIntoMArray #-}
+ src/LambdaSound/Sound/Types.hs view
@@ -0,0 +1,44 @@+module LambdaSound.Sound.Types where++import Control.DeepSeq (NFData)+import Data.Hashable (Hashable)+import Foreign.Storable (Storable)+import GHC.Generics (Generic)+import Data.Coerce (coerce)++-- | An audio sample+newtype Pulse = Pulse Float deriving (Show, Eq, Floating, Num, Fractional, Ord, Real, RealFrac, NFData, Storable, Hashable, Enum)++-- | The duration of a 'Sound'+newtype Duration = Duration Float deriving (Show, Eq, Floating, Num, Fractional, Ord, Real, RealFrac, NFData, Storable, Hashable, Enum)++-- | The progress of a 'Sound'. A sound progresses from '0' to '1'+-- while it plays.+newtype Progress = Progress Float deriving (Show, Eq, Floating, Num, Fractional, Ord, Real, RealFrac, NFData, Storable, Hashable, Enum)++-- | The percentage of a 'Sound'. '0.3' corresponds to 30% of a 'Sound'.+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)++-- | 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' +newtype Time = Time Float deriving (Show, Eq, Floating, Num, Fractional, Ord, Real, RealFrac, NFData, Storable, Hashable, Enum)++-- | Gives information about how many samples are needed during computation+data SamplingInfo = SamplingInfo+  { period :: !Float,+    sampleRate :: Hz,+    samples :: Int+  }+  deriving (Generic, Show, Eq)++instance Hashable Hz++instance Hashable SamplingInfo where++makeSamplingInfo :: Hz -> Duration -> SamplingInfo+makeSamplingInfo hz duration =+  let period = coerce $ 1 / hz+   in SamplingInfo period hz (round $ coerce duration / period)
+ test/Main.hs view
@@ -0,0 +1,124 @@+module Main (main) where++import Control.Monad (join, unless)+import Control.Monad.IO.Class (liftIO)+import Data.List.NonEmpty+import Data.Massiv.Array qualified as M+import LambdaSound+import Test.Falsify.Generator qualified as Gen+import Test.Tasty+import Test.Tasty.Falsify+import System.IO.Unsafe (unsafePerformIO)++main :: IO ()+main =+  defaultMain $+    testGroup+      "LambdaSound tests"+      [ testProperty "reverse" reverseProperty,+        testProperty "associative sequence" associativeSequence,+        testProperty "associative parallel" associativeParallel,+        testProperty "distributivity of parallel and sequence" distributivityParallelSequence,+        testProperty "takeSound" takeSoundProperty,+        testProperty "dropSound" dropSoundProperty,+        testProperty "take/drop" dropTakeSoundDuality,+        testProperty "cache does not change sound" cacheDoesNotChangeSound +      ]++genSound :: Gen (Sound T Pulse)+genSound = do+  let basicSound =+        Gen.elem $+          setDuration 1 (constant 1)+            :| [ setDuration 1 (sineWave 440),+                 setDuration 1 (harmonic sineWave 100),+                 setDuration 1 (noise 42)+               ]+  join $+    Gen.elem $+      ((<>) <$> basicSound <*> basicSound)+        :| [ (>>>) <$> basicSound <*> basicSound,+             takeSound 0.5 <$> basicSound,+             -- dropSound 0.3 <$> basicSound,+             changeTempo (** 1.2) <$> basicSound,+             amplify 2 <$> basicSound,+             reduce 2 <$> basicSound,+             raise 3 <$> basicSound+           ]++reverseProperty :: Property ()+reverseProperty = do+  sound <- genWith (\_ -> Just "Sound") genSound+  assertEquality "reverseSound failing" $+    reverseSound (reverseSound sound)+      `eqSound` sound++associativeSequence :: Property ()+associativeSequence = do+  sound1 <- gen genSound+  sound2 <- gen genSound+  sound3 <- gen genSound+  assertEquality "sequence not associative" $ (sound1 >>> (sound2 >>> sound3)) `eqSound` ((sound1 >>> sound2) >>> sound3)++associativeParallel :: Property ()+associativeParallel = do+  sound1 <- gen genSound+  sound2 <- gen genSound+  sound3 <- gen genSound+  assertEquality "parallel not associative" $ (sound1 <> (sound2 <> sound3)) `almostEqSound` ((sound1 <> sound2) <> sound3)++distributivityParallelSequence :: Property ()+distributivityParallelSequence = do+  sound1 <- setDuration 1 <$> gen genSound+  sound2 <- setDuration 1 <$> gen genSound+  sound3 <- setDuration 1 <$> gen genSound+  sound4 <- setDuration 1 <$> gen genSound+  assertEquality "parallel not associative" $+    ((sound1 >>> sound2) <> (sound3 >>> sound4))+      `almostEqSound` ((sound1 <> sound3) >>> (sound2 <> sound4))++takeSoundProperty :: Property ()+takeSoundProperty = do+  sound1 <- setDuration 1 <$> gen genSound+  sound2 <- setDuration 1 <$> gen genSound+  assertEquality "takeSound failed" $ takeSound 1 (sound1 >>> sound2) `eqSound` sound1++dropSoundProperty :: Property ()+dropSoundProperty = do+  sound1 <- setDuration 1 <$> gen genSound+  sound2 <- setDuration 1 <$> gen genSound+  assertEquality "dropSound failed" $ dropSound 1 (sound1 >>> sound2) `eqSound` sound2++dropTakeSoundDuality :: Property ()+dropTakeSoundDuality = do+  sound1 <- setDuration 1 <$> gen genSound+  sound2 <- setDuration 1 <$> gen genSound+  assertEquality "drop/take duality failed" $+    dropSound 1 (sound1 >>> sound2)+      `eqSound` reverseSound (takeSound 1 (reverseSound $ sound1 >>> sound2))++cacheDoesNotChangeSound :: Property ()+cacheDoesNotChangeSound= do+  sound <- setDuration 1 <$> gen genSound+  assertEquality "cache changed sound" $+    cache sound+      `eqSound` sound++assertEquality :: String -> IO Bool -> Property ()+assertEquality failText check = do+  let areEqual = unsafePerformIO $ liftIO check+  unless areEqual (testFailed failText)++eqSound :: Sound T Pulse -> Sound T Pulse -> IO Bool+eqSound s1 s2 = (==) <$> sampleSound (Hz 100) s1 <*> sampleSound (Hz 100) s2++almostEqSound :: Sound T Pulse -> Sound T Pulse -> IO Bool+almostEqSound s1 s2 = do+  x <- sampleSound 100 s1+  y <- sampleSound 100 s2+  let res = M.all (\a -> abs a < epsilon) $ M.zipWith (-) x y+  unless res $+    print (x,y)+  pure res+  where+    epsilon = 5e-6