Audio.hs

-----------------------------------------------------------------------------
-- |
-- Module      : Data.Audio
-- Copyright   : George Giorgidze
-- License     : BSD3
-- 
-- Maintainer  : George Giorgidze <http://cs.nott.ac.uk/~ggg/>
-- Stability   : Experimental
-- Portability : Portable
--
-- General purpose data type for representing an audio data.
--
-----------------------------------------------------------------------------

{-# LANGUAGE FlexibleContexts, UndecidableInstances  #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Data.Audio (
   Sample
 , Audio (..)
 , SampleData
 , SampleMode(..)
 , sampleType
 , sampleNumber
 , convert
 , parseSampleData
 , buildSampleData
 , Audible
 , toSample
 , fromSample
 ) where

import Data.Arbitrary
import Data.ByteString.Parser
import Data.ByteString.Builder

import Data.Word
import Data.Int
import Data.Array.Diff
import Data.List
import Data.Monoid
import Test.QuickCheck

type Sample = Double

class Audible a where
  toSample :: a -> Sample
  fromSample :: Sample -> a
  
-- It is required that sampleNummer `mod` channelNumber == 0
data Audio a = Audio {
    sampleRate :: Int
  , channelNumber :: Int
  , sampleData :: SampleData a
  }

instance (Eq a, IArray DiffUArray a) => Eq (Audio a) where
  a1 == a2 = and [
      sampleRate a1 == sampleRate a2
    , channelNumber a1 == channelNumber a2
    , assocs (sampleData a1) == assocs (sampleData a2)]

instance (Eq e, Ix i, IArray (IOToDiffArray a) e) => Eq (IOToDiffArray a i e) where
  a1 == a2 = assocs a1 == assocs a2

type SampleData a = DiffUArray Int a

instance (Show a, IArray DiffUArray a) => Show (Audio a) where
  show a = "Sample Rate: " ++ (show $ sampleRate a) ++ "\n" ++
           "Channel Number: " ++ (show $ channelNumber a) ++ "\n" ++
           "Sample Data Array Bounds: " ++ (show $ bounds $ sampleData a)


instance (Arbitrary a, IArray DiffUArray a)
  => Arbitrary (Audio a)
  where
  arbitrary = do
    sr <- choose (1, 44100 * 8)
    cn <- choose (1, 64)
    sn <- choose (1, 1024) >>= return . (fromIntegral cn *)
    sd <- arrayGen sn
    return $! Audio sr cn sd
  coarbitrary = undefined

sampleNumber :: (IArray DiffUArray a) => SampleData a -> Int
sampleNumber sd = (snd $ bounds sd) + 1

sampleType :: (IArray DiffUArray a) => SampleData a -> a
sampleType sd = undefined `asTypeOf` (sd ! 0)

convert :: (Audible a, Audible b, IArray DiffUArray a, IArray DiffUArray b) => SampleData a -> SampleData b
convert sd = amap (fromSample . toSample) sd


-- It is very important to implement this parser efficiently
-- It seems that DiffUArray leaks memmory.
-- When I am profilling, profiler shows that function retains memmory which is
-- a same size as an array created by parser.
-- However when I am running compiled binary almoust twice as much memmory is
-- consumed from the system, this behaviour seems very strange to me.
-- Updating an array every time when sample is parsed
-- results in a poor preformance that is why currently I am using
-- list buffer and apdating array with 64 samples at once.
parseSampleData :: (IArray DiffUArray a) => Int -> Parser a -> Parser (SampleData a)
parseSampleData sn p = pAux 0 (array (0, sn - 1) []) []
  where
  pAux i acc buf | (i == sn) = return $! acc // buf
  pAux i acc buf | mod i 64 == 0 = do
    s <- p
    let acc' = seq s $ acc // ((i,s) : buf) in seq acc' $ pAux (i + 1) acc' []
  pAux i acc buf = do
    s <- p
    seq s $ pAux (i + 1) acc ((i,s) : buf)

buildSampleData :: (IArray DiffUArray a) => (a -> Builder) -> SampleData a -> Builder
buildSampleData b sd = mconcat $ map b $ elems sd  

instance Audible Int8 where
  toSample a = (fromIntegral a) / (2 ** 7)
  fromSample s = round $ s * (2 ** 7)
instance Audible Int16 where
  toSample a = (fromIntegral a) / (2 ** 15)
  fromSample s = round $ s * (2 ** 15)
instance Audible Int32 where
  toSample a = (fromIntegral a) / (2 ** 31)
  fromSample s = round $ s * (2 ** 31)
instance Audible Int64 where
  toSample a = (fromIntegral a) / (2 ** 63)
  fromSample s = round $ s * (2 ** 63)
instance Audible Word8 where
  toSample a = (fromIntegral a) / (2 ** 7) - 1.0
  fromSample s = round $ (s + 1.0) * (2 ** 7)
instance Audible Word16 where
  toSample a = (fromIntegral a) / (2 ** 15) - 1.0
  fromSample s = round $ (s + 1.0) * (2 ** 15)
instance Audible Word32 where
  toSample a = (fromIntegral a) / (2 ** 31) - 1.0
  fromSample s = round $ (s + 1.0) * (2 ** 31)
instance Audible Word64 where
  toSample a = (fromIntegral a) / (2 ** 63) - 1.0
  fromSample s = round $ (s + 1.0) * (2 ** 63)

instance Audible Float where
  toSample = realToFrac 
  fromSample = realToFrac

instance Audible Double where
  toSample = id
  fromSample = id
  
data SampleMode = NoLoop | ContLoop | PressLoop
  deriving (Eq, Show)
  
instance Arbitrary SampleMode where
  arbitrary = oneof [return NoLoop, return ContLoop, return PressLoop]
  coarbitrary = undefined