{-# LANGUAGE RebindableSyntax #-}
{- |
Play audio signals via ALSA.
The module could also be called @Output@,
because with a @file@ sink, data can also be written to disk.
-}
module Synthesizer.ALSA.Storable.Play (
   -- * auxiliary functions
   Device,
   defaultDevice,
   defaultChunkSize,
   makeSink,
   write,
   writeLazy,
   -- * play functions
   auto,
   autoAndRecord,
   autoAndRecordMany,
   monoToInt16,
   stereoToInt16,
   ) where

import qualified Sound.ALSA.PCM as ALSA

import qualified Synthesizer.Frame.Stereo as Stereo
import qualified Synthesizer.Basic.Binary as BinSmp

import qualified Sound.Sox.Frame         as SoxFrame
import qualified Sound.Sox.Write         as SoxWrite
import qualified Sound.Sox.Option.Format as SoxOption

import Foreign.Storable (Storable, )
import Foreign.Marshal.Array (advancePtr, )
import Foreign.Ptr (Ptr, minusPtr, )
import Data.Int (Int16, )
import qualified System.IO as IO
import qualified System.Exit as Exit

-- import qualified Synthesizer.State.Signal     as SigS

import qualified Synthesizer.Storable.Signal     as SigSt
import qualified Data.StorableVector.Lazy        as SVL
import qualified Data.StorableVector.Base        as SVB

import qualified Algebra.RealRing as RealRing

import qualified Data.Traversable as Trav
import qualified Data.Foldable as Fold

import NumericPrelude.Numeric
import NumericPrelude.Base


{- |
A suggested default chunk size.
It is not used by the functions in this module.
-}
{-
Better move to Storable.Server.Common or Dimensional.Server.Common?
-}
defaultChunkSize :: SigSt.ChunkSize
defaultChunkSize :: ChunkSize
defaultChunkSize = Int -> ChunkSize
SigSt.chunkSize Int
512
{-
At some epochs this chunk size leads to buffer underruns.
I cannot reproduce this:
Some months it works this way on Suse but not on Ubuntu or vice versa.
Other months it works the other way round.
defaultChunkSize = SigSt.chunkSize 256
-}


type Device = String

defaultDevice :: Device
defaultDevice :: Device
defaultDevice = Device
"default"


{- |
Useful values for the output device are

* @\"default\"@ for mixing with the output of other applications.

* @\"plughw:0,0\"@ for accessing sound output in an exclusive way.

* @\"tee:default,'output.raw',raw\"@ for playing and simultaneously writing raw data to disk.

* @\"tee:default,'output.wav',wav\"@ for playing and writing to WAVE file format.
  Note that the length cannot be written,
  when the program is terminated,
  leaving the file in an invalid format.
-}
makeSink ::
   (ALSA.SampleFmt y, RealRing.C t) =>
   Device {- ^ ALSA output device -} ->
   t {- ^ period (buffer) size expressed in seconds -} ->
   ALSA.SampleFreq {- ^ sample rate -} ->
   ALSA.SoundSink ALSA.Pcm y
makeSink :: Device -> t -> Int -> SoundSink Pcm y
makeSink Device
device t
periodTime Int
rate =
   Device -> SoundFmt y -> SoundBufferTime -> SoundSink Pcm y
forall y.
SampleFmt y =>
Device -> SoundFmt y -> SoundBufferTime -> SoundSink Pcm y
ALSA.alsaSoundSinkTime Device
device
      (SoundFmt :: forall y. Int -> SoundFmt y
ALSA.SoundFmt {
         sampleFreq :: Int
ALSA.sampleFreq = Int
rate
      }) (SoundBufferTime -> SoundSink Pcm y)
-> SoundBufferTime -> SoundSink Pcm y
forall a b. (a -> b) -> a -> b
$
   Int -> Int -> SoundBufferTime
ALSA.SoundBufferTime
      (t -> Int
forall a b. (C a, C b) => a -> b
round (t
5000000t -> t -> t
forall a. C a => a -> a -> a
*t
periodTime))
      (t -> Int
forall a b. (C a, C b) => a -> b
round (t
1000000t -> t -> t
forall a. C a => a -> a -> a
*t
periodTime))

{-
alsaOpen: only few buffer underruns with
       let buffer_time = 200000 -- 0.20s
           period_time =  40000 -- 0.04s

However the delay is still perceivable.

Latency for keyboard playback might be better with:
       let buffer_time =  50000 -- 0.05s
           period_time =  10000 -- 0.01s
but we get too much underruns,
without actually achieving the required latency.
-}
{-# INLINE auto #-}
auto ::
   (ALSA.SampleFmt y) =>
   ALSA.SoundSink handle y ->
   SigSt.T y -> IO ()
auto :: SoundSink handle y -> T y -> IO ()
auto SoundSink handle y
sink T y
ys =
   SoundSink handle y -> (handle y -> IO ()) -> IO ()
forall (handle :: * -> *) y a.
SoundSink handle y -> (handle y -> IO a) -> IO a
ALSA.withSoundSink SoundSink handle y
sink ((handle y -> IO ()) -> IO ()) -> (handle y -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \handle y
to ->
   SoundSink handle y -> handle y -> T y -> IO ()
forall y (handle :: * -> *).
Storable y =>
SoundSink handle y -> handle y -> Vector y -> IO ()
writeLazy SoundSink handle y
sink handle y
to T y
ys

{-# INLINE writeLazy #-}
writeLazy ::
   (Storable y) =>
   ALSA.SoundSink handle y -> handle y ->
   SVL.Vector y -> IO ()
writeLazy :: SoundSink handle y -> handle y -> Vector y -> IO ()
writeLazy SoundSink handle y
sink handle y
to Vector y
ys =
   (Vector y -> IO ()) -> [Vector y] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SoundSink handle y -> handle y -> Vector y -> IO ()
forall y (handle :: * -> *).
Storable y =>
SoundSink handle y -> handle y -> Vector y -> IO ()
write SoundSink handle y
sink handle y
to) (Vector y -> [Vector y]
forall a. Vector a -> [Vector a]
SVL.chunks Vector y
ys)

{-# INLINE write #-}
write ::
   (Storable y) =>
   ALSA.SoundSink handle y -> handle y ->
   SVB.Vector y -> IO ()
write :: SoundSink handle y -> handle y -> Vector y -> IO ()
write SoundSink handle y
sink handle y
to Vector y
c =
   Vector y -> (Ptr y -> Int -> IO ()) -> IO ()
forall a b.
Storable a =>
Vector a -> (Ptr a -> Int -> IO b) -> IO b
SVB.withStartPtr Vector y
c ((Ptr y -> Int -> IO ()) -> IO ())
-> (Ptr y -> Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr y
ptr Int
size ->
   SoundSink handle y -> handle y -> Ptr y -> Int -> IO ()
forall (handle :: * -> *) y.
SoundSink handle y -> handle y -> Ptr y -> Int -> IO ()
ALSA.soundSinkWrite SoundSink handle y
sink handle y
to Ptr y
ptr Int
size


-- cf. Alsa.hs
{-# INLINE arraySize #-}
arraySize :: Storable y => Ptr y -> Int -> Int
arraySize :: Ptr y -> Int -> Int
arraySize Ptr y
p Int
n = Ptr y -> Int -> Ptr y
forall a. Storable a => Ptr a -> Int -> Ptr a
advancePtr Ptr y
p Int
n Ptr y -> Ptr y -> Int
forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Ptr y
p

{- |
Play a signal and write it to disk via SoX simultaneously.
Consider using 'auto' with @tee@ device.
-}
{-# INLINE autoAndRecord #-}
autoAndRecord ::
   (ALSA.SampleFmt y, SoxFrame.C y) =>
   FilePath ->
   ALSA.SoundFmt y ->
   ALSA.SoundSink handle y ->
   SigSt.T y -> IO Exit.ExitCode
autoAndRecord :: Device -> SoundFmt y -> SoundSink handle y -> T y -> IO ExitCode
autoAndRecord Device
fileName SoundFmt y
fmt SoundSink handle y
sink =
   let rate :: Int
rate = SoundFmt y -> Int
forall y. SoundFmt y -> Int
ALSA.sampleFreq SoundFmt y
fmt
   in  (\Handle -> T y -> IO ()
act ->
          (Handle -> T y -> IO ())
-> T -> Device -> Int -> T y -> IO ExitCode
forall y (sig :: * -> *).
C y =>
(Handle -> sig y -> IO ())
-> T -> Device -> Int -> sig y -> IO ExitCode
SoxWrite.simple Handle -> T y -> IO ()
act T
SoxOption.none Device
fileName Int
rate) ((Handle -> T y -> IO ()) -> T y -> IO ExitCode)
-> (Handle -> T y -> IO ()) -> T y -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ \Handle
h T y
ys ->
       SoundSink handle y -> (handle y -> IO ()) -> IO ()
forall (handle :: * -> *) y a.
SoundSink handle y -> (handle y -> IO a) -> IO a
ALSA.withSoundSink SoundSink handle y
sink ((handle y -> IO ()) -> IO ()) -> (handle y -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \handle y
to ->
       ((Vector y -> IO ()) -> [Vector y] -> IO ())
-> [Vector y] -> (Vector y -> IO ()) -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Vector y -> IO ()) -> [Vector y] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (T y -> [Vector y]
forall a. Vector a -> [Vector a]
SVL.chunks T y
ys) ((Vector y -> IO ()) -> IO ()) -> (Vector y -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Vector y
c ->
       Vector y -> (Ptr y -> Int -> IO ()) -> IO ()
forall a b.
Storable a =>
Vector a -> (Ptr a -> Int -> IO b) -> IO b
SVB.withStartPtr Vector y
c ((Ptr y -> Int -> IO ()) -> IO ())
-> (Ptr y -> Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr y
ptr Int
size ->
       SoundSink handle y -> handle y -> Ptr y -> Int -> IO ()
forall (handle :: * -> *) y.
SoundSink handle y -> handle y -> Ptr y -> Int -> IO ()
ALSA.soundSinkWrite SoundSink handle y
sink handle y
to Ptr y
ptr Int
size IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
       Handle -> Ptr y -> Int -> IO ()
forall a. Handle -> Ptr a -> Int -> IO ()
IO.hPutBuf Handle
h Ptr y
ptr (Ptr y -> Int -> Int
forall y. Storable y => Ptr y -> Int -> Int
arraySize Ptr y
ptr Int
size)


{- |
Play a signal and write it to multiple files.
The Functor @f@ may be @Maybe@ for no or one file to write,
or @[]@ for many files to write.
-}
{-# INLINE autoAndRecordMany #-}
autoAndRecordMany ::
   (ALSA.SampleFmt y, SoxFrame.C y,
    Trav.Traversable f) =>
   f FilePath ->
   ALSA.SoundFmt y ->
   ALSA.SoundSink handle y ->
   SigSt.T y -> IO (f Exit.ExitCode)
autoAndRecordMany :: f Device
-> SoundFmt y -> SoundSink handle y -> T y -> IO (f ExitCode)
autoAndRecordMany f Device
fileNames SoundFmt y
fmt SoundSink handle y
sink =
   let rate :: Int
rate = SoundFmt y -> Int
forall y. SoundFmt y -> Int
ALSA.sampleFreq SoundFmt y
fmt
   in  (\f Handle -> T y -> IO ()
act ->
          (f Handle -> T y -> IO ())
-> T -> T -> f Device -> Int -> T y -> IO (f ExitCode)
forall y (f :: * -> *) (sig :: * -> *).
(C y, Traversable f) =>
(f Handle -> sig y -> IO ())
-> T -> T -> f Device -> Int -> sig y -> IO (f ExitCode)
SoxWrite.manyExtended f Handle -> T y -> IO ()
act T
SoxOption.none T
SoxOption.none f Device
fileNames Int
rate) ((f Handle -> T y -> IO ()) -> T y -> IO (f ExitCode))
-> (f Handle -> T y -> IO ()) -> T y -> IO (f ExitCode)
forall a b. (a -> b) -> a -> b
$ \f Handle
hs T y
ys ->
       SoundSink handle y -> (handle y -> IO ()) -> IO ()
forall (handle :: * -> *) y a.
SoundSink handle y -> (handle y -> IO a) -> IO a
ALSA.withSoundSink SoundSink handle y
sink ((handle y -> IO ()) -> IO ()) -> (handle y -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \handle y
to ->
       ((Vector y -> IO ()) -> [Vector y] -> IO ())
-> [Vector y] -> (Vector y -> IO ()) -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Vector y -> IO ()) -> [Vector y] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (T y -> [Vector y]
forall a. Vector a -> [Vector a]
SVL.chunks T y
ys) ((Vector y -> IO ()) -> IO ()) -> (Vector y -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Vector y
c ->
       Vector y -> (Ptr y -> Int -> IO ()) -> IO ()
forall a b.
Storable a =>
Vector a -> (Ptr a -> Int -> IO b) -> IO b
SVB.withStartPtr Vector y
c ((Ptr y -> Int -> IO ()) -> IO ())
-> (Ptr y -> Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr y
ptr Int
size ->
       SoundSink handle y -> handle y -> Ptr y -> Int -> IO ()
forall (handle :: * -> *) y.
SoundSink handle y -> handle y -> Ptr y -> Int -> IO ()
ALSA.soundSinkWrite SoundSink handle y
sink handle y
to Ptr y
ptr Int
size IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
       (Handle -> IO ()) -> f Handle -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
Fold.traverse_ (\Handle
h -> Handle -> Ptr y -> Int -> IO ()
forall a. Handle -> Ptr a -> Int -> IO ()
IO.hPutBuf Handle
h Ptr y
ptr (Ptr y -> Int -> Int
forall y. Storable y => Ptr y -> Int -> Int
arraySize Ptr y
ptr Int
size)) f Handle
hs


{-# INLINE monoToInt16 #-}
monoToInt16 ::
   (Storable y, RealRing.C y) =>
   ALSA.SoundSink handle Int16 ->
   SigSt.T y -> IO ()
monoToInt16 :: SoundSink handle Int16 -> T y -> IO ()
monoToInt16 SoundSink handle Int16
sink T y
xs =
   SoundSink handle Int16 -> T Int16 -> IO ()
forall y (handle :: * -> *).
SampleFmt y =>
SoundSink handle y -> T y -> IO ()
auto SoundSink handle Int16
sink ((y -> Int16) -> T y -> T Int16
forall x y.
(Storable x, Storable y) =>
(x -> y) -> Vector x -> Vector y
SigSt.map y -> Int16
forall a. C a => a -> Int16
BinSmp.int16FromCanonical T y
xs)

{-# INLINE stereoToInt16 #-}
stereoToInt16 ::
   (Storable y, RealRing.C y) =>
   ALSA.SoundSink handle (Stereo.T Int16) ->
   SigSt.T (Stereo.T y) -> IO ()
stereoToInt16 :: SoundSink handle (T Int16) -> T (T y) -> IO ()
stereoToInt16 SoundSink handle (T Int16)
sink T (T y)
xs =
   SoundSink handle (T Int16) -> T (T Int16) -> IO ()
forall y (handle :: * -> *).
SampleFmt y =>
SoundSink handle y -> T y -> IO ()
auto SoundSink handle (T Int16)
sink ((T y -> T Int16) -> T (T y) -> T (T Int16)
forall x y.
(Storable x, Storable y) =>
(x -> y) -> Vector x -> Vector y
SigSt.map ((y -> Int16) -> T y -> T Int16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap y -> Int16
forall a. C a => a -> Int16
BinSmp.int16FromCanonical) T (T y)
xs)