{-# 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 (getSum, Sum(Sum))

-- 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 :: PulseCell m Float ()
addSample = (Float -> Sum Float)
-> Cell (WriterT (Sum Float) m) Float (Sum Float)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr Float -> Sum Float
forall a. a -> Sum a
Sum Cell (WriterT (Sum Float) m) Float (Sum Float)
-> Cell (WriterT (Sum Float) m) (Sum Float) ()
-> PulseCell m Float ()
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Sum Float -> WriterT (Sum Float) m ())
-> Cell (WriterT (Sum Float) m) (Sum Float) ()
forall a (m :: * -> *) b. (a -> m b) -> Cell m a b
arrM Sum Float -> WriterT (Sum Float) m ()
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 :: 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 :: forall (m :: * -> *) h. m h -> (h -> m ()) -> Handle m h
Handle
  { create :: IO Simple
create = Maybe String
-> String
-> Direction
-> Maybe String
-> String
-> SampleSpec
-> Maybe [ChannelPosition]
-> Maybe BufferAttr
-> IO Simple
simpleNew
      Maybe String
forall a. Maybe a
Nothing
      String
"example"
      Direction
Play
      Maybe String
forall a. Maybe a
Nothing
      String
"this is an example application"
      (SampleFormat -> Int -> Int -> SampleSpec
SampleSpec (Endian -> SampleFormat
F32 Endian
LittleEndian) Int
forall a. Num a => a
sampleRate Int
1)
      Maybe [ChannelPosition]
forall a. Maybe a
Nothing
      Maybe BufferAttr
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
  :: Int
  -- ^ Specifies how many steps of your 'PulseCell' should be performed in one step of 'pulseWrapC'.
  -> PulseCell IO a b
  -- ^ Your cell that produces samples.
  -> Cell (HandlingStateT IO) a [b]
pulseWrapC :: Int -> PulseCell IO a b -> Cell (HandlingStateT IO) a [b]
pulseWrapC Int
bufferSize PulseCell IO a b
cell = proc a
a -> do
  Simple
simple <- Handle IO Simple -> Cell (HandlingStateT IO) () 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 <- Cell (HandlingStateT IO) a (Sum Float, b)
-> Cell (HandlingStateT IO) [a] [(Sum Float, b)]
forall (m :: * -> *) a b. Monad m => Cell m a b -> Cell m [a] [b]
resampleList (Cell (HandlingStateT IO) a (Sum Float, b)
 -> Cell (HandlingStateT IO) [a] [(Sum Float, b)])
-> Cell (HandlingStateT IO) a (Sum Float, b)
-> Cell (HandlingStateT IO) [a] [(Sum Float, b)]
forall a b. (a -> b) -> a -> b
$ Cell IO a (Sum Float, b)
-> Cell (HandlingStateT IO) a (Sum Float, b)
forall (m :: * -> *) (t :: (* -> *) -> * -> *) a b.
(Monad m, MonadTrans t) =>
Cell m a b -> Cell (t m) a b
liftCell (Cell IO a (Sum Float, b)
 -> Cell (HandlingStateT IO) a (Sum Float, b))
-> Cell IO a (Sum Float, b)
-> Cell (HandlingStateT IO) a (Sum Float, b)
forall a b. (a -> b) -> a -> b
$ PulseCell IO a b -> Cell IO a (Sum Float, 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 -< Int -> a -> [a]
forall a. Int -> a -> [a]
replicate Int
bufferSize a
a
  let ([Sum Float]
samples, [b]
bs) = [(Sum Float, b)] -> ([Sum Float], [b])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Sum Float, b)]
samplesAndBs
      samples' :: [Float]
samples' = Sum Float -> Float
forall a. Sum a -> a
getSum (Sum Float -> Float) -> [Sum Float] -> [Float]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Sum Float]
samples
  ((Simple, [Float]) -> StateT (HandlingState IO) IO ())
-> Cell (HandlingStateT IO) (Simple, [Float]) ()
forall a (m :: * -> *) b. (a -> m b) -> Cell m a b
arrM (((Simple, [Float]) -> StateT (HandlingState IO) IO ())
 -> Cell (HandlingStateT IO) (Simple, [Float]) ())
-> ((Simple, [Float]) -> StateT (HandlingState IO) IO ())
-> Cell (HandlingStateT IO) (Simple, [Float]) ()
forall a b. (a -> b) -> a -> b
$ IO () -> StateT (HandlingState IO) IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> StateT (HandlingState IO) IO ())
-> ((Simple, [Float]) -> IO ())
-> (Simple, [Float])
-> StateT (HandlingState IO) IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Simple -> [Float] -> IO ()) -> (Simple, [Float]) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Simple -> [Float] -> IO ()
forall a. Storable a => Simple -> [a] -> IO ()
simpleWrite -< [Float]
samples' [Float] -> (Simple, [Float]) -> (Simple, [Float])
`seq` [b]
bs [b] -> (Simple, [Float]) -> (Simple, [Float])
`seq` (Simple
simple, [Float]
samples')
  Cell (HandlingStateT IO) [b] [b]
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 :: Cell m a a
wrapSum = Cell :: forall (m :: * -> *) a b s.
Data s =>
s -> (s -> a -> m (b, s)) -> Cell m a b
Cell
  { cellState :: a
cellState = a
0
  , cellStep :: a -> a -> m (a, a)
cellStep  = \a
accum a
a ->
    let
        (Integer
_, a
accum') = a -> (Integer, a)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction (a -> (Integer, a)) -> a -> (Integer, a)
forall a b. (a -> b) -> a -> b
$ a
accum a -> a -> a
forall a. Num a => a -> a -> a
+ a
a
    in (a, a) -> m (a, a)
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 :: Cell m a a
wrapIntegral = (a -> a) -> Cell m a a
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
forall a. Num a => a
sampleRate) Cell m a a -> Cell m a a -> Cell m a a
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Cell m a a
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 :: Cell m a a
sawtooth = Cell m a a
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 :: a -> Cell m a a
modSum a
denominator = Cell :: forall (m :: * -> *) a b s.
Data s =>
s -> (s -> a -> m (b, s)) -> Cell m a b
Cell
  { cellState :: a
cellState = a
0
  , cellStep :: a -> a -> m (a, a)
cellStep  = \a
accum a
a -> let accum' :: a
accum' = (a
accum a -> a -> a
forall a. Num a => a -> a -> a
+ a
a) a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
denominator in (a, a) -> m (a, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
accum', a
accum')
  }

clamp :: (Ord a, Num a) => a -> a -> a -> a
clamp :: a -> a -> a -> a
clamp a
lower a
upper a
a = a -> a -> a
forall a. Ord a => a -> a -> a
min a
upper (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a -> a -> a
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 :: Cell (ReaderT a m) () a
osc = proc ()
_ -> do
  a
f <- ReaderT a m a -> Cell (ReaderT a m) () a
forall (m :: * -> *) b a. m b -> Cell m a b
constM ReaderT a m a
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask -< ()
  a
phase <- Cell (ReaderT a m) a a
forall (m :: * -> *) a.
(Monad m, Data a, RealFloat a) =>
Cell m a a
wrapIntegral -< a
f
  Cell (ReaderT a m) a a
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< a -> a
forall a. Floating a => a -> a
sin (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a
2 a -> a -> a
forall a. Num a => a -> a -> a
* a
forall a. Floating a => a
pi a -> a -> a
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 :: a -> Cell m () a
oscAt = (a -> Cell (ReaderT a m) () a -> Cell m () a)
-> Cell (ReaderT a m) () a -> a -> Cell m () a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> Cell (ReaderT a m) () a -> Cell m () a
forall r (m :: * -> *) a b.
r -> Cell (ReaderT r m) a b -> Cell m a b
runReaderC Cell (ReaderT a m) () a
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' :: Cell m a a
osc' = proc a
a -> do
  Cell (ReaderT a m) () a -> Cell m (a, ()) a
forall (m :: * -> *) r a b.
Monad m =>
Cell (ReaderT r m) a b -> Cell m (r, a) b
runReaderC' Cell (ReaderT a m) () a
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]
(Note -> Note)
-> (Note -> Note)
-> (Int -> Note)
-> (Note -> Int)
-> (Note -> [Note])
-> (Note -> Note -> [Note])
-> (Note -> Note -> [Note])
-> (Note -> Note -> Note -> [Note])
-> Enum 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
(Int -> Note -> ShowS)
-> (Note -> String) -> ([Note] -> ShowS) -> Show Note
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 Float -> Float -> Float
forall a. Num a => a -> a -> a
* (Float
2 Float -> Float -> Float
forall a. Floating a => a -> a -> a
** (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Note -> Int
forall a. Enum a => a -> Int
fromEnum Note
note) Float -> Float -> Float
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 = (Float -> Float -> Float
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 = (Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2)