module Sound.PlSynth
( withPlSynth
, PlSynthT(..)
, emptyPlSynthT
, pattern SIN
, pattern SAW
, pattern SQR
, pattern TRI
, PlSynthSoundT(..)
, writeSound
, withSound
, PlSynthSongT(..)
, writeSong
, withSong
, withSongTracks
, newSong
, freeSongTracks
, newTrack
, freeTrack
) where
import Prelude hiding (sequence)
import Sound.PlSynth.FFI
import Data.Int (Int16)
import Data.Word (Word8, Word32)
import Control.Exception (bracket)
import Data.List (isSuffixOf)
import Foreign (Ptr, allocaArray, allocaBytes, castPtr, free, newArray, peekArray, sizeOf, with)
import Foreign.C.String (withCString)
import System.IO (IOMode(..), hPutBuf, withBinaryFile)
withPlSynth :: IO a -> IO a
withPlSynth :: forall a. IO a -> IO a
withPlSynth IO a
action = do
Int -> (Ptr CFloat -> IO a) -> IO a
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
plSynthTabSize \Ptr CFloat
synthTab -> do
Ptr CFloat -> IO ()
plSynthInit Ptr CFloat
synthTab
IO a
action
withSound
:: PlSynthSoundT
-> ( Ptr Word8
-> Int
-> IO a
)
-> IO a
withSound :: forall a. PlSynthSoundT -> (Ptr Word8 -> Int -> IO a) -> IO a
withSound PlSynthSoundT
sound Ptr Word8 -> Int -> IO a
action =
PlSynthSoundT -> (Ptr PlSynthSoundT -> IO a) -> IO a
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with PlSynthSoundT
sound \Ptr PlSynthSoundT
soundPtr -> do
Int
numSamples <- Ptr PlSynthSoundT -> IO Int
plSynthSoundLen Ptr PlSynthSoundT
soundPtr
Int -> (Ptr Int16 -> IO a) -> IO a
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray (Int
numSamples Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) \Ptr Int16
sampleBuffer -> do
Int
len <- Ptr PlSynthSoundT -> Ptr Int16 -> IO Int
plSynthSound Ptr PlSynthSoundT
soundPtr Ptr Int16
sampleBuffer
let numBytes :: Int
numBytes = Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int16 -> Int
forall a. Storable a => a -> Int
sizeOf (Int16
forall a. HasCallStack => a
undefined :: Int16)
Ptr Word8 -> Int -> IO a
action (Ptr Int16 -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr Int16
sampleBuffer) Int
numBytes
writeSound :: FilePath -> PlSynthSoundT -> IO ()
writeSound :: [Char] -> PlSynthSoundT -> IO ()
writeSound [Char]
fp PlSynthSoundT
sound =
PlSynthSoundT -> (Ptr Word8 -> Int -> IO ()) -> IO ()
forall a. PlSynthSoundT -> (Ptr Word8 -> Int -> IO a) -> IO a
withSound PlSynthSoundT
sound \Ptr Word8
ptr Int
len ->
if [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf [Char]
".wav" [Char]
fp then
[Char] -> (CString -> IO ()) -> IO ()
forall a. [Char] -> (CString -> IO a) -> IO a
withCString [Char]
fp \CString
fpPtr -> do
let numSamples :: Int
numSamples = Int
len Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int16 -> Int
forall a. Storable a => a -> Int
sizeOf (Int16
forall a. HasCallStack => a
undefined :: Int16)
CString -> Ptr Int16 -> Int -> Int16 -> Int -> IO ()
plSynthWavWrite CString
fpPtr (Ptr Word8 -> Ptr Int16
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr) Int
numSamples Int16
2 Int
44100
else
[Char] -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile [Char]
fp IOMode
WriteMode \Handle
h ->
Handle -> Ptr Word8 -> Int -> IO ()
forall a. Handle -> Ptr a -> Int -> IO ()
hPutBuf Handle
h Ptr Word8
ptr Int
len
withSong :: PlSynthSongT -> (Ptr Word8 -> Int -> IO a) -> IO a
withSong :: forall a. PlSynthSongT -> (Ptr Word8 -> Int -> IO a) -> IO a
withSong PlSynthSongT
song Ptr Word8 -> Int -> IO a
action =
PlSynthSongT -> (Ptr PlSynthSongT -> IO a) -> IO a
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with PlSynthSongT
song \Ptr PlSynthSongT
songPtr -> do
Int
numSamples <- Ptr PlSynthSongT -> IO Int
plSynthSongLen Ptr PlSynthSongT
songPtr
Int -> (Ptr Int16 -> IO a) -> IO a
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray (Int
numSamples Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) \Ptr Int16
sampleBuffer -> do
Int
len <- Int -> (Ptr Int16 -> IO Int) -> IO Int
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray (Int
numSamples Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) ((Ptr Int16 -> IO Int) -> IO Int)
-> (Ptr Int16 -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ Ptr PlSynthSongT -> Ptr Int16 -> Ptr Int16 -> IO Int
plSynthSong Ptr PlSynthSongT
songPtr Ptr Int16
sampleBuffer
let numBytes :: Int
numBytes = Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int16 -> Int
forall a. Storable a => a -> Int
sizeOf (Int16
forall a. HasCallStack => a
undefined :: Int16)
Ptr Word8 -> Int -> IO a
action (Ptr Int16 -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr Int16
sampleBuffer) Int
numBytes
writeSong :: FilePath -> PlSynthSongT -> IO ()
writeSong :: [Char] -> PlSynthSongT -> IO ()
writeSong [Char]
fp PlSynthSongT
song =
PlSynthSongT -> (Ptr Word8 -> Int -> IO ()) -> IO ()
forall a. PlSynthSongT -> (Ptr Word8 -> Int -> IO a) -> IO a
withSong PlSynthSongT
song \Ptr Word8
ptr Int
len ->
if [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf [Char]
".wav" [Char]
fp then
[Char] -> (CString -> IO ()) -> IO ()
forall a. [Char] -> (CString -> IO a) -> IO a
withCString [Char]
fp \CString
fpPtr -> do
let numSamples :: Int
numSamples = Int
len Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int16 -> Int
forall a. Storable a => a -> Int
sizeOf (Int16
forall a. HasCallStack => a
undefined :: Int16)
CString -> Ptr Int16 -> Int -> Int16 -> Int -> IO ()
plSynthWavWrite CString
fpPtr (Ptr Word8 -> Ptr Int16
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr) Int
numSamples Int16
2 Int
44100
else
[Char] -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile [Char]
fp IOMode
WriteMode \Handle
h ->
Handle -> Ptr Word8 -> Int -> IO ()
forall a. Handle -> Ptr a -> Int -> IO ()
hPutBuf Handle
h Ptr Word8
ptr Int
len
withSongTracks
:: Word32
-> [([Word8], [[Word8]], PlSynthT)]
-> (PlSynthSongT -> IO a)
-> IO a
withSongTracks :: forall a.
Word32
-> [([Word8], [[Word8]], PlSynthT)]
-> (PlSynthSongT -> IO a)
-> IO a
withSongTracks Word32
row_len [([Word8], [[Word8]], PlSynthT)]
tracks_ =
IO PlSynthSongT
-> (PlSynthSongT -> IO ()) -> (PlSynthSongT -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (IO [PlSynthTrackT]
newTracks IO [PlSynthTrackT]
-> ([PlSynthTrackT] -> IO PlSynthSongT) -> IO PlSynthSongT
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word32 -> [PlSynthTrackT] -> IO PlSynthSongT
newSong Word32
row_len) PlSynthSongT -> IO ()
freeSongTracks
where
newTracks :: IO [PlSynthTrackT]
newTracks =(([Word8], [[Word8]], PlSynthT) -> IO PlSynthTrackT)
-> [([Word8], [[Word8]], PlSynthT)] -> IO [PlSynthTrackT]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\([Word8]
ss, [[Word8]]
ps, PlSynthT
synth) -> [Word8] -> [[Word8]] -> PlSynthT -> IO PlSynthTrackT
newTrack [Word8]
ss [[Word8]]
ps PlSynthT
synth) [([Word8], [[Word8]], PlSynthT)]
tracks_
newSong
:: Word32
-> [PlSynthTrackT]
-> IO PlSynthSongT
newSong :: Word32 -> [PlSynthTrackT] -> IO PlSynthSongT
newSong Word32
row_len [PlSynthTrackT]
tracks' = do
let num_tracks :: Word8
num_tracks = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ [PlSynthTrackT] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PlSynthTrackT]
tracks'
Ptr PlSynthTrackT
tracks <- [PlSynthTrackT] -> IO (Ptr PlSynthTrackT)
forall a. Storable a => [a] -> IO (Ptr a)
newArray [PlSynthTrackT]
tracks'
PlSynthSongT -> IO PlSynthSongT
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PlSynthSongT{Word8
Word32
Ptr PlSynthTrackT
row_len :: Word32
num_tracks :: Word8
tracks :: Ptr PlSynthTrackT
$sel:row_len:PlSynthSongT :: Word32
$sel:num_tracks:PlSynthSongT :: Word8
$sel:tracks:PlSynthSongT :: Ptr PlSynthTrackT
..}
freeSongTracks :: PlSynthSongT -> IO ()
freeSongTracks :: PlSynthSongT -> IO ()
freeSongTracks PlSynthSongT{Word8
$sel:num_tracks:PlSynthSongT :: PlSynthSongT -> Word8
num_tracks :: Word8
num_tracks, Ptr PlSynthTrackT
$sel:tracks:PlSynthSongT :: PlSynthSongT -> Ptr PlSynthTrackT
tracks :: Ptr PlSynthTrackT
tracks} = do
Int -> Ptr PlSynthTrackT -> IO [PlSynthTrackT]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
num_tracks) Ptr PlSynthTrackT
tracks IO [PlSynthTrackT] -> ([PlSynthTrackT] -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (PlSynthTrackT -> IO ()) -> [PlSynthTrackT] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ PlSynthTrackT -> IO ()
freeTrack
Ptr PlSynthTrackT -> IO ()
forall a. Ptr a -> IO ()
free Ptr PlSynthTrackT
tracks
newTrack
:: [Word8]
-> [[Word8]]
-> PlSynthT
-> IO PlSynthTrackT
newTrack :: [Word8] -> [[Word8]] -> PlSynthT -> IO PlSynthTrackT
newTrack [Word8]
sequences [[Word8]]
patterns' PlSynthT
synth = do
Ptr Word8
sequence <- [Word8] -> IO (Ptr Word8)
forall a. Storable a => [a] -> IO (Ptr a)
newArray [Word8]
sequences
let sequence_len :: Word32
sequence_len = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ [Word8] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
sequences
Ptr PlSynthPatternT
patterns <- [PlSynthPatternT] -> IO (Ptr PlSynthPatternT)
forall a. Storable a => [a] -> IO (Ptr a)
newArray ([PlSynthPatternT] -> IO (Ptr PlSynthPatternT))
-> [PlSynthPatternT] -> IO (Ptr PlSynthPatternT)
forall a b. (a -> b) -> a -> b
$ ([Word8] -> PlSynthPatternT) -> [[Word8]] -> [PlSynthPatternT]
forall a b. (a -> b) -> [a] -> [b]
map [Word8] -> PlSynthPatternT
PlSynthPatternT [[Word8]]
patterns'
PlSynthTrackT -> IO PlSynthTrackT
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PlSynthTrackT{Word32
Ptr Word8
Ptr PlSynthPatternT
PlSynthT
synth :: PlSynthT
sequence :: Ptr Word8
sequence_len :: Word32
patterns :: Ptr PlSynthPatternT
$sel:synth:PlSynthTrackT :: PlSynthT
$sel:sequence_len:PlSynthTrackT :: Word32
$sel:sequence:PlSynthTrackT :: Ptr Word8
$sel:patterns:PlSynthTrackT :: Ptr PlSynthPatternT
..}
freeTrack :: PlSynthTrackT -> IO ()
freeTrack :: PlSynthTrackT -> IO ()
freeTrack PlSynthTrackT{Word32
Ptr Word8
Ptr PlSynthPatternT
PlSynthT
$sel:synth:PlSynthTrackT :: PlSynthTrackT -> PlSynthT
$sel:sequence_len:PlSynthTrackT :: PlSynthTrackT -> Word32
$sel:sequence:PlSynthTrackT :: PlSynthTrackT -> Ptr Word8
$sel:patterns:PlSynthTrackT :: PlSynthTrackT -> Ptr PlSynthPatternT
synth :: PlSynthT
sequence_len :: Word32
sequence :: Ptr Word8
patterns :: Ptr PlSynthPatternT
..} = do
Ptr Word8 -> IO ()
forall a. Ptr a -> IO ()
free Ptr Word8
sequence
Ptr PlSynthPatternT -> IO ()
forall a. Ptr a -> IO ()
free Ptr PlSynthPatternT
patterns