{- | Convenience wrappers for pl_synth C API.

The generator is always using the 44100 s16le stereo format.

The generator is using static pointers inside and is NOT thread-safe.
-}

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)

-- | Initialize generator using a temporary buffer.
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

-- | Generate sound samples in a temporary buffer.
--
-- Copy the pointer contents before using.
withSound
  :: PlSynthSoundT
  -> ( Ptr Word8 -- Sample buffer
    -> Int -- Length of buffer in bytes
    -> 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

-- | Generate samples and write into a file.
--
-- If file extension is @.wav@, then the file would be WAV-wrapped.
-- Otherwise, raw PCM data would be dumped.
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
        -- recover number of samples from bytes actually used for generation
        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

-- | Generate song samples in a temporary buffer.
--
-- Copy the pointer contents before using.
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

-- | Generate song samples and write into a file.
--
-- If file extension is @.wav@, then the file would be WAV-wrapped.
-- Otherwise, raw PCM data would be dumped.
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

-- | Prepare temporary buffers from track definitions.
withSongTracks
  :: Word32
  -> [([Word8], [[Word8]], PlSynthT)] -- ^ args for 'newTrack': sequence, patterns, synth
  -> (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_ =
  -- should be a nested bracket, but whatever
  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 -- ^ row length
  -> [PlSynthTrackT] -- ^ track buffers
  -> 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
..}

-- | Free song buffers AND all of its tracks.
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] -- ^ Sequences (1-based pattern numbers to play, 0 - silent sequence)
  -> [[Word8]] -- ^ Patterns (at most 32 note numbers to play, 0 to skip)
  -> PlSynthT -- ^ An instrument to play
  -> 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