{-# 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 (Sum (Sum), getSum)
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 :: 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
sampleRate :: Num a => a
sampleRate :: forall a. Num a => a
sampleRate = a
48000
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
}
pulseWrapC ::
Int ->
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
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')
}
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
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
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
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
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, ())
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)
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))
o :: Float -> Float
o :: Float -> Float
o = (forall a. Num a => a -> a -> a
* Float
2)
oB :: Float -> Float
oB :: Float -> Float
oB = (forall a. Fractional a => a -> a -> a
/ Float
2)