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 x =
[float2Int (if x<0
then scale16 x 0.5
else scale16 x + 0.5)]
numChannels _ = 1
instance C Double where
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
scale16 :: (Ring.C a, Ord a) => a -> a
scale16 x = 32767 * clip (1) 1 x
numToInt16 :: (RealField.C a) => a -> Int
numToInt16 = round . scale16
numToInt16Packed :: (RealField.C a) => a -> Int16
numToInt16Packed = P98.fromIntegral . numToInt16
floatToInt16Packed :: Float -> Int16
floatToInt16Packed = P98.fromIntegral . float2Int . scale16
doubleToInt16Packed :: Double -> Int16
doubleToInt16Packed = P98.fromIntegral . double2Int . (32767*) . clip (1) 1
int16ToNum :: (Field.C a) => Int -> a
int16ToNum x = fromIntegral x / 32768
int16PackedToNum :: (Field.C a) => Int16 -> a
int16PackedToNum = int16ToNum . P98.fromIntegral
int16ToLEChars :: Int -> [Char]
int16ToLEChars x =
let (hi,lo) = divMod x 256
in [toEnum lo, toEnum (mod hi 256)]
leCharsToInt16 :: Char -> Char -> Int
leCharsToInt16 hi lo =
let unsigned = ord lo + 256 * ord hi
in mod (unsigned + 32768) 65536 32768
signalToBinary :: (C v) => [v] -> [Int]
signalToBinary = concatMap toInt16
signalToBinaryMono :: (RealField.C a) => [a] -> [Int]
signalToBinaryMono = map numToInt16
signalToBinaryStereo :: (RealField.C a) => [(a,a)] -> [Int]
signalToBinaryStereo =
concatMap (\(l,r) -> [numToInt16 l, numToInt16 r])
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"
[] -> []
writeLEInt16Stream :: FilePath -> [Int] -> IO ()
writeLEInt16Stream fileName =
writeFile fileName . concatMap int16ToLEChars
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)
readLEInt16Stream :: FilePath -> IO [Int]
readLEInt16Stream fileName =
fmap binaryToIntsMono16 (readFile fileName)
readInt16Stream :: FilePath -> IO [Int]
readInt16Stream fileName =
bracket (openBinaryFile fileName ReadMode) hClose
getInt16Stream
getInt16Stream :: Handle -> IO [Int]
getInt16Stream h =
alloca $
\p -> fmap (map P98.fromIntegral)
(unfoldM (getInt16 h p))
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")