{-# LANGUAGE Arrows #-}

module LiveCoding.Pulse where

-- base
import Control.Arrow as X
import Control.Concurrent
import Control.Monad (forever)
import Control.Monad.Fix
import Data.Monoid (Sum (Sum), getSum)

-- transformers
import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Writer.Strict

-- pulse-simple
import Sound.Pulse.Simple

-- essence-of-live-coding
import LiveCoding

type PulseT m = WriterT (Sum Float) m

type PulseCell m a b = Cell (PulseT m) a b

-- | Compose with this cell to play a sound sample.
addSample :: Monad m => PulseCell m Float ()
addSample :: forall (m :: * -> *). Monad m => PulseCell m Float ()
addSample = forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall a. a -> Sum a
Sum forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a (m :: * -> *) b. (a -> m b) -> Cell m a b
arrM forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell

-- | Globally fix the sample rate to 48000 samples per second.
sampleRate :: Num a => a
sampleRate :: forall a. Num a => a
sampleRate = a
48000

{- | Create a pulse server backend handle.

Currently, this is always mono,
but with a future release of @pulse-simple@,
this might be configurable.
-}
pulseHandle :: Handle IO Simple
pulseHandle :: Handle IO Simple
pulseHandle =
  Handle
    { create :: IO Simple
create =
        Maybe String
-> String
-> Direction
-> Maybe String
-> String
-> SampleSpec
-> Maybe [ChannelPosition]
-> Maybe BufferAttr
-> IO Simple
simpleNew
          forall a. Maybe a
Nothing
          String
"example"
          Direction
Play
          forall a. Maybe a
Nothing
          String
"this is an example application"
          (SampleFormat -> Int -> Int -> SampleSpec
SampleSpec (Endian -> SampleFormat
F32 Endian
LittleEndian) forall a. Num a => a
sampleRate Int
1)
          forall a. Maybe a
Nothing
          forall a. Maybe a
Nothing
    , destroy :: Simple -> IO ()
destroy = Simple -> IO ()
simpleFree
    }

{- | Run a 'PulseCell' with a started pulse backend.

Currently, this is synchronous and blocking,
i.e. the resulting cell will block until the backend buffer is nearly empty.

This performs several steps of your cell at a time,
replicating the input so many times.
-}
pulseWrapC ::
  -- | Specifies how many steps of your 'PulseCell' should be performed in one step of 'pulseWrapC'.
  Int ->
  -- | Your cell that produces samples.
  PulseCell IO a b ->
  Cell (HandlingStateT IO) a [b]
pulseWrapC :: forall a b.
Int -> PulseCell IO a b -> Cell (HandlingStateT IO) a [b]
pulseWrapC Int
bufferSize PulseCell IO a b
cell = proc a
a -> do
  Simple
simple <- forall h (m :: * -> *) arbitrary.
(Typeable h, Monad m) =>
Handle m h -> Cell (HandlingStateT m) arbitrary h
handling Handle IO Simple
pulseHandle -< ()
  [(Sum Float, b)]
samplesAndBs <- forall (m :: * -> *) a b. Monad m => Cell m a b -> Cell m [a] [b]
resampleList forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: (* -> *) -> * -> *) a b.
(Monad m, MonadTrans t) =>
Cell m a b -> Cell (t m) a b
liftCell forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *) a b.
(Monoid w, Monad m) =>
Cell (WriterT w m) a b -> Cell m a (w, b)
runWriterC PulseCell IO a b
cell -< forall a. Int -> a -> [a]
replicate Int
bufferSize a
a
  let ([Sum Float]
samples, [b]
bs) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Sum Float, b)]
samplesAndBs
      samples' :: [Float]
samples' = forall a. Sum a -> a
getSum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Sum Float]
samples
  forall a (m :: * -> *) b. (a -> m b) -> Cell m a b
arrM forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Storable a => Simple -> [a] -> IO ()
simpleWrite -< [Float]
samples' seq :: forall a b. a -> b -> b
`seq` [b]
bs seq :: forall a b. a -> b -> b
`seq` (Simple
simple, [Float]
samples')
  forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< [b]
bs

{- | Returns the sum of all incoming values,
and wraps it between -1 and 1.

This is to prevent floating number imprecision when the sum gets too large.
-}
wrapSum :: (Monad m, Data a, RealFloat a) => Cell m a a
wrapSum :: forall (m :: * -> *) a.
(Monad m, Data a, RealFloat a) =>
Cell m a a
wrapSum =
  Cell
    { cellState :: a
cellState = a
0
    , cellStep :: a -> a -> m (a, a)
cellStep = \a
accum a
a ->
        let
          (Integer
_, a
accum') = forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction forall a b. (a -> b) -> a -> b
$ a
accum forall a. Num a => a -> a -> a
+ a
a
         in
          forall (m :: * -> *) a. Monad m => a -> m a
return (a
accum', a
accum')
    }

-- | Like 'wrapSum', but as an integral, assuming the PulseAudio 'sampleRate'.
wrapIntegral :: (Monad m, Data a, RealFloat a) => Cell m a a
wrapIntegral :: forall (m :: * -> *) a.
(Monad m, Data a, RealFloat a) =>
Cell m a a
wrapIntegral = forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall a. Fractional a => a -> a -> a
/ forall a. Num a => a
sampleRate) forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (m :: * -> *) a.
(Monad m, Data a, RealFloat a) =>
Cell m a a
wrapSum

{- | A sawtooth, or triangle wave, generator,
   outputting a sawtooth wave with the given input as frequency.
-}
sawtooth :: (Monad m, Data a, RealFloat a) => Cell m a a
sawtooth :: forall (m :: * -> *) a.
(Monad m, Data a, RealFloat a) =>
Cell m a a
sawtooth = forall (m :: * -> *) a.
(Monad m, Data a, RealFloat a) =>
Cell m a a
wrapIntegral

modSum :: (Monad m, Data a, Integral a) => a -> Cell m a a
modSum :: forall (m :: * -> *) a.
(Monad m, Data a, Integral a) =>
a -> Cell m a a
modSum a
denominator =
  Cell
    { cellState :: a
cellState = a
0
    , cellStep :: a -> a -> m (a, a)
cellStep = \a
accum a
a -> let accum' :: a
accum' = (a
accum forall a. Num a => a -> a -> a
+ a
a) forall a. Integral a => a -> a -> a
`mod` a
denominator in forall (m :: * -> *) a. Monad m => a -> m a
return (a
accum', a
accum')
    }

clamp :: (Ord a, Num a) => a -> a -> a -> a
clamp :: forall a. (Ord a, Num a) => a -> a -> a -> a
clamp a
lower a
upper a
a = forall a. Ord a => a -> a -> a
min a
upper forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max a
lower a
a

{- | A sine oscillator.
   Supply the frequency via the 'ReaderT' environment.
   See 'osc'' and 'oscAt'.
-}
osc :: (Data a, RealFloat a, Monad m) => Cell (ReaderT a m) () a
osc :: forall a (m :: * -> *).
(Data a, RealFloat a, Monad m) =>
Cell (ReaderT a m) () a
osc = proc ()
_ -> do
  a
f <- forall (m :: * -> *) b a. m b -> Cell m a b
constM forall (m :: * -> *) r. Monad m => ReaderT r m r
ask -< ()
  a
phase <- forall (m :: * -> *) a.
(Monad m, Data a, RealFloat a) =>
Cell m a a
wrapIntegral -< a
f
  forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< forall a. Floating a => a -> a
sin forall a b. (a -> b) -> a -> b
$ a
2 forall a. Num a => a -> a -> a
* forall a. Floating a => a
pi forall a. Num a => a -> a -> a
* a
phase

-- | A sine oscillator, at a fixed frequency.
oscAt :: (Data a, RealFloat a, Monad m) => a -> Cell m () a
oscAt :: forall a (m :: * -> *).
(Data a, RealFloat a, Monad m) =>
a -> Cell m () a
oscAt = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a b.
r -> Cell (ReaderT r m) a b -> Cell m a b
runReaderC forall a (m :: * -> *).
(Data a, RealFloat a, Monad m) =>
Cell (ReaderT a m) () a
osc

-- | A sine oscillator, at a frequency that can be specified live.
osc' :: (Data a, RealFloat a, Monad m) => Cell m a a
osc' :: forall a (m :: * -> *).
(Data a, RealFloat a, Monad m) =>
Cell m a a
osc' = proc a
a -> do
  forall (m :: * -> *) r a b.
Monad m =>
Cell (ReaderT r m) a b -> Cell m (r, a) b
runReaderC' forall a (m :: * -> *).
(Data a, RealFloat a, Monad m) =>
Cell (ReaderT a m) () a
osc -< (a
a, ())

{- | A basic musical note (western traditional notation, german nomenclature).

Assumes equal temperament and removes enharmonic equivalents,
i.e. there is only Dis (= D sharp) but not Eb (= E flat).
-}
data Note
  = A
  | Bb
  | B
  | C
  | Cis
  | D
  | Dis
  | E
  | F
  | Fis
  | G
  | Gis
  deriving (Int -> Note
Note -> Int
Note -> [Note]
Note -> Note
Note -> Note -> [Note]
Note -> Note -> Note -> [Note]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Note -> Note -> Note -> [Note]
$cenumFromThenTo :: Note -> Note -> Note -> [Note]
enumFromTo :: Note -> Note -> [Note]
$cenumFromTo :: Note -> Note -> [Note]
enumFromThen :: Note -> Note -> [Note]
$cenumFromThen :: Note -> Note -> [Note]
enumFrom :: Note -> [Note]
$cenumFrom :: Note -> [Note]
fromEnum :: Note -> Int
$cfromEnum :: Note -> Int
toEnum :: Int -> Note
$ctoEnum :: Int -> Note
pred :: Note -> Note
$cpred :: Note -> Note
succ :: Note -> Note
$csucc :: Note -> Note
Enum, Int -> Note -> ShowS
[Note] -> ShowS
Note -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Note] -> ShowS
$cshowList :: [Note] -> ShowS
show :: Note -> String
$cshow :: Note -> String
showsPrec :: Int -> Note -> ShowS
$cshowsPrec :: Int -> Note -> ShowS
Show)

{- | Calculate the frequency of a note,
   with 'A' corresponding to 220 Hz.
-}
f :: Note -> Float
f :: Note -> Float
f Note
note = Float
220 forall a. Num a => a -> a -> a
* (Float
2 forall a. Floating a => a -> a -> a
** (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Enum a => a -> Int
fromEnum Note
note) forall a. Fractional a => a -> a -> a
/ Float
12))

-- | Transpose a frequency an octave higher, i.e. multiply by 2.
o :: Float -> Float
o :: Float -> Float
o = (forall a. Num a => a -> a -> a
* Float
2)

-- | Transpose a frequency an octave lower, i.e. divide by 2.
oB :: Float -> Float
oB :: Float -> Float
oB = (forall a. Fractional a => a -> a -> a
/ Float
2)