definitive-sound-1.0: Data/Music.hs

module Data.Music (
  Note(..),Wave(..),
  frequency,gain,wave,duration,playTune,
  defaultFmt,
  -- * Notes
  la,si,do',re,mi,fa,sol,sharp,flat,high,low
  ) where

import Algebra hiding (splitAt,take,drop)
import Algebra.Time
import Data.Tree
import Sound.ALSA.PCM
import Data.IORef
import Foreign.Marshal.Array
import Data.Containers
import Data.Containers.Sequence
import Foreign.Marshal.Array (copyArray)

data Wave = Wave { _frequency :: Seconds, _gain :: Double }
            deriving Show
data Note = Note Wave Seconds
          deriving Show
type Melody = Forest Note

frequency :: Lens' Wave Seconds
frequency = lens _frequency (\w t -> w { _frequency = t})
gain :: Lens' Wave Double
gain = lens _gain (\w t -> w { _gain = t})
wave :: Lens' Note Wave
wave = lens (\(Note w _) -> w) (\(Note _ t) w -> Note w t)
duration :: Lens' Note Seconds
duration = lens (\(Note _ d) -> d) (\(Note w _) d -> Note w d)

factor = 2**(1/12)
la, si, do', re,mi,fa,sol :: Seconds -> Note
(la:_:si:do':_:re:_:mi:fa:_:sol:_) =
  f<$>iterate (*factor) 1
  where f m = Note (Wave (440*m) 40)

sharp :: Note -> Note
sharp = wave.frequency %~ (*factor)
flat :: Note -> Note
flat = wave.frequency %~ (/factor)
high :: Note -> Note
high = wave.frequency %~ (*2)
low :: Note -> Note
low = wave.frequency %~ (/2)

playTune :: SoundFmt Seconds -> [Note] -> IO ()
playTune f mel = copySound (tuneSource f mel) (alsaSoundSink "plughw" f) (sampleFreq f*2)

period = cached $ \density -> take (round density) [sin (pi*2*x)*0.75 | x <- iterate (+recip density) 0]^.slice

newtype TH t = TH (IORef (Slices t))
tuneSource :: SoundFmt Seconds -> [Note] -> SoundSource TH Seconds
tuneSource (SoundFmt sfreq) mel = SoundSource {
  soundSourceOpen = open,
  soundSourceClose = close,
  soundSourceStart = start,
  soundSourceStop = stop,
  soundSourceRead = readn
  }
  where open = TH<$>newIORef (toSamples mel)
        close _ = return ()
        start _ = return ()
        stop _ = return ()
        toSamples = foldMap note2Samples
          where note2Samples (Note (Wave freq _) t) =
                  take (round (t*freq*density)) (repeat (period density)^._Slices)
                  where density = fromIntegral sfreq/freq
        readn (TH r) p s = do
          rem <- readIORef r
          let (h,t) = splitAt s rem
              size = if empty (t^.._Slices) then breadth h else s
          unsafeWith (h^..slices) $ \p' -> (p `copyArray` p') size
          writeIORef r t
          return size

defaultFmt = SoundFmt 48000