{-# LANGUAGE Arrows #-}
module LiveCoding.Pulse where
import Control.Arrow as X
import Control.Concurrent
import Control.Monad (forever)
import Control.Monad.Fix
import Data.Monoid (getSum, Sum(Sum))
import Control.Monad.Trans.Class (MonadTrans(lift))
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Writer.Strict
import Sound.Pulse.Simple
import LiveCoding
type PulseT m = WriterT (Sum Float) m
type PulseCell m a b = Cell (PulseT m) a b
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
sampleRate :: Num a => a
sampleRate :: a
sampleRate = a
48000
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
}
pulseWrapC
:: Int
-> PulseCell IO a b
-> 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
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')
}
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
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
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
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
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, ())
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)
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))
o :: Float -> Float
o :: Float -> Float
o = (Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
2)
oB :: Float -> Float
oB :: Float -> Float
oB = (Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2)