synthesizer-0.0.3: src/BinarySample.hs

{-# OPTIONS -fno-implicit-prelude #-}
module BinarySample
   (C(..),
    signalToBinary, signalToBinaryMono, signalToBinaryStereo,
    writeInt16Stream, readInt16Stream,
    writeLEInt16Stream, readLEInt16Stream,
    int16ToNum, putInt16Stream,
    numToInt16Packed, int16PackedToNum,
    floatToInt16Packed, doubleToInt16Packed,
    ) where

import Foreign (Int16, Ptr, alloca, sizeOf, poke, peek)
import System.IO (openBinaryFile, IOMode(WriteMode,ReadMode), hClose, Handle, hPutBuf, hGetBuf)
import Control.Exception (bracket)
import Control.Monad (liftM)

import qualified Algebra.Field     as Field
import qualified Algebra.RealField as RealField
import qualified Algebra.Ring      as Ring

import Synthesizer.Utility (clip)

import Data.Char(ord)

import GHC.Float (float2Int, double2Int)

import qualified Prelude as P98

import PreludeBase
import NumericPrelude




class C a where
   toInt16 :: a -> [Int]
   numChannels :: a -> Int

instance C Float where
--   toInt16 = (:[]) . numToInt16
   toInt16 x =
      [float2Int (if x<0
                    then scale16 x - 0.5
                    else scale16 x + 0.5)]
   numChannels _ = 1

instance C Double where
--   toInt16 = (:[]) . numToInt16
   toInt16 x =
      [double2Int (if x<0
                     then scale16 x - 0.5
                     else scale16 x + 0.5)]
   numChannels _ = 1

instance (C a, C b) => C (a,b) where
   toInt16 (x0,x1) = toInt16 x0 ++ toInt16 x1
   numChannels ~(x0,x1) = numChannels x0 + numChannels x1



{-# INLINE scale16 #-}
scale16 :: (Ring.C a, Ord a) => a -> a
scale16 x = 32767 * clip (-1) 1 x

{-# INLINE numToInt16 #-}
numToInt16 :: (RealField.C a) => a -> Int
numToInt16 = round . scale16

{-# INLINE numToInt16Packed #-}
numToInt16Packed :: (RealField.C a) => a -> Int16
numToInt16Packed = P98.fromIntegral . numToInt16

{-# INLINE floatToInt16Packed #-}
floatToInt16Packed :: Float -> Int16
floatToInt16Packed = P98.fromIntegral . float2Int . scale16


{-
{-# INLINE scale16Double #-}
scale16Double :: (Ring.C a, Ord a) => a -> a
scale16Double x = 32767 * clip (-1) 1 x
-}

{-# INLINE doubleToInt16Packed #-}
doubleToInt16Packed :: Double -> Int16
{- Why is scale16 not inlined here? See FusionTest.mixTest3
doubleToInt16Packed = P98.fromIntegral . double2Int . scale16
-}
-- doubleToInt16Packed = P98.fromIntegral . double2Int . scale16Double
-- doubleToInt16Packed x = P98.fromIntegral (double2Int (scale16 x))
doubleToInt16Packed = P98.fromIntegral . double2Int . (32767*) . clip (-1) 1

{-# INLINE int16ToNum #-}
int16ToNum :: (Field.C a) => Int -> a
int16ToNum x = fromIntegral x / 32768

{-# INLINE int16PackedToNum #-}
int16PackedToNum :: (Field.C a) => Int16 -> a
int16PackedToNum = int16ToNum . P98.fromIntegral

-- | little endian (Intel)
{-# INLINE int16ToLEChars #-}
int16ToLEChars :: Int -> [Char]
int16ToLEChars x =
   let (hi,lo) = divMod x 256
   in  [toEnum lo, toEnum (mod hi 256)]

-- | little endian (Intel)
{-# INLINE leCharsToInt16 #-}
leCharsToInt16 :: Char -> Char -> Int
leCharsToInt16 hi lo =
   let unsigned = ord lo + 256 * ord hi
   in  mod (unsigned + 32768) 65536 - 32768


{-# INLINE signalToBinary #-}
signalToBinary :: (C v) => [v] -> [Int]
signalToBinary = concatMap toInt16

{-# INLINE signalToBinaryMono #-}
signalToBinaryMono :: (RealField.C a) => [a] -> [Int]
signalToBinaryMono = map numToInt16

{-# INLINE signalToBinaryStereo #-}
signalToBinaryStereo :: (RealField.C a) => [(a,a)] -> [Int]
signalToBinaryStereo =
   concatMap (\(l,r) -> [numToInt16 l, numToInt16 r])


{-# INLINE binaryToIntsMono16 #-}
binaryToIntsMono16 :: [Char] -> [Int]
binaryToIntsMono16 sig =
   case sig of
      (lo:hi:xs) ->
         leCharsToInt16 hi lo : binaryToIntsMono16 xs
      (_:[]) ->
         error "binaryToIntsMono16: 16 bit sample files must have even length"
      [] -> []



{- * I\/O -}

{- |
Write a little endian 16 bit integer stream
via String data and 'writeFile'.
-}
writeLEInt16Stream :: FilePath -> [Int] -> IO ()
writeLEInt16Stream fileName =
   writeFile fileName . concatMap int16ToLEChars

{- |
Uses endianess of the machine, like Sox does.
-}
writeInt16Stream :: FilePath -> [Int] -> IO ()
writeInt16Stream fileName stream =
   bracket (openBinaryFile fileName WriteMode) hClose
      (flip putInt16Stream stream)

putInt16Stream :: Handle -> [Int] -> IO ()
putInt16Stream h stream =
   alloca $
      \p -> mapM_ (putInt16 h p . P98.fromIntegral) stream

putInt16 :: Handle -> Ptr Int16 -> Int16 -> IO ()
putInt16 h p n =
   poke p n >> hPutBuf h p (sizeOf n)


{- |
The end of the list is undefined,
if the file has odd length.
It would be better if it throws an exception.
-}
readLEInt16Stream :: FilePath -> IO [Int]
readLEInt16Stream fileName =
   fmap binaryToIntsMono16 (readFile fileName)

{- |
The end of the list is undefined,
if the file has odd length.
It would be better if it throws an exception.
-}
readInt16Stream :: FilePath -> IO [Int]
readInt16Stream fileName =
   bracket (openBinaryFile fileName ReadMode) hClose
      getInt16Stream

{- |
In contrast to hGetContents this is strict!
-}
getInt16Stream :: Handle -> IO [Int]
getInt16Stream h =
   alloca $
      \p -> fmap (map P98.fromIntegral)
                 (unfoldM (getInt16 h p))

-- candidate for Utility
unfoldM :: Monad m => m (Maybe a) -> m [a]
unfoldM act =
   let listM = maybe (return []) (\x -> liftM (x:) listM) =<< act
   in  listM

getInt16 :: Handle -> Ptr Int16 -> IO (Maybe Int16)
getInt16 h p =
   do cnt <- hGetBuf h p (sizeOf (undefined::Int16))
      case cnt of
        0 -> return Nothing
        2 -> fmap Just (peek p)
        _ -> return (error "getInt16: only one byte found")