{-# 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.Array.IO (MArray, IOUArray, newArray_, writeArray)
import Data.Array.Unsafe (unsafeFreeze, unsafeThaw)
import Codec.Internal.Arbitrary
import Codec.ByteString.Parser
import Codec.ByteString.Builder
import Test.QuickCheck
import System.IO.Unsafe
import Data.Array.Unboxed
import Data.Word
import Data.Int
import Data.Monoid
type Sample = Double
type SampleData a = UArray Int a
class Audible a where
toSample :: a -> Sample
fromSample :: Sample -> a
data Audio a = Audio {
sampleRate :: Int
, channelNumber :: Int
, sampleData :: SampleData a
}
instance (Eq a, IArray UArray a) => Eq (Audio a) where
a1 == a2 = and [
sampleRate a1 == sampleRate a2
, channelNumber a1 == channelNumber a2
, assocs (sampleData a1) == assocs (sampleData a2)]
instance (Show a, IArray UArray 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 UArray a) => Arbitrary (Audio a) where
arbitrary = do
sr <- choose (1, 44100 * 8)
cn <- choose (1, 8)
sn <- choose (1, 128) >>= return . (fromIntegral cn *)
sd <- arrayGen sn
return (Audio sr cn sd)
sampleNumber :: (IArray UArray a) => SampleData a -> Int
sampleNumber sd = (snd (bounds sd)) + 1
sampleType :: (IArray UArray a) => SampleData a -> a
sampleType sd = undefined `asTypeOf` (sd ! 0)
convert :: (Audible a, Audible b, IArray UArray a, IArray UArray b) => SampleData a -> SampleData b
convert sd = amap (fromSample . toSample) sd
parseSampleData :: (MArray IOUArray a IO, IArray UArray a) => Int -> Parser a -> Parser (SampleData a)
parseSampleData sn p = pAux 0 unsafeNewArray
where
pAux i acc | (i == sn) = seq i $ seq acc $ return acc
pAux i acc | otherwise = seq i $ seq acc $ do
s <- p
seq s (pAux (i + 1) (unsafeWriteArray acc i s))
unsafeFreezeAux :: (MArray IOUArray a IO, IArray UArray a) => IOUArray Int a -> IO (SampleData a)
unsafeFreezeAux = unsafeFreeze
unsafeNewArray = unsafePerformIO (newArray_ (0, sn - 1) >>= unsafeFreezeAux )
unsafeWriteArray a i e = unsafePerformIO (do a' <- unsafeThaw a; writeArray a' i e; unsafeFreezeAux a';)
buildSampleData :: (IArray UArray a) => (a -> Builder) -> SampleData a -> Builder
buildSampleData b = mconcat . map b . elems
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]