{-# LANGUAGE Arrows, ScopedTypeVariables, NamedFieldPuns, FlexibleContexts #-}
module Euterpea.IO.Audio.Render (
Instr, InstrMap, renderSF,
) where
import Control.Arrow
import Control.Arrow.Operations
import Control.Arrow.ArrowP
import Control.SF.SF
import Euterpea.Music
import Euterpea.IO.MIDI.MEvent
import Euterpea.IO.Audio.Basics
import Euterpea.IO.Audio.Types
import Data.List
import qualified Data.IntMap as M
import Data.Ord (comparing)
type Instr a = Dur -> AbsPitch -> Volume -> [Double] -> a
type InstrMap a = [(InstrumentName, Instr a)]
lookupInstr :: InstrumentName -> InstrMap a -> Instr a
lookupInstr :: forall a. InstrumentName -> InstrMap a -> Instr a
lookupInstr InstrumentName
ins InstrMap a
im =
case InstrumentName -> InstrMap a -> Maybe (Instr a)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup InstrumentName
ins InstrMap a
im of
Just Instr a
i -> Instr a
i
Maybe (Instr a)
Nothing -> [Char] -> Instr a
forall a. HasCallStack => [Char] -> a
error ([Char] -> Instr a) -> [Char] -> Instr a
forall a b. (a -> b) -> a -> b
$ [Char]
"Instrument " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ InstrumentName -> [Char]
forall a. Show a => a -> [Char]
show InstrumentName
ins [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
[Char]
" does not have a matching Instr in the supplied InstrMap."
type NoteId = Int
data NoteEvt a = NoteOn NoteId a
| NoteOff NoteId
type Evt a = (Double, NoteEvt a)
eventToEvtPair :: InstrMap a -> MEvent -> Int -> [Evt a]
eventToEvtPair :: forall a. InstrMap a -> MEvent -> Int -> [Evt a]
eventToEvtPair InstrMap a
imap (MEvent {PTime
eTime :: PTime
eTime :: MEvent -> PTime
eTime, InstrumentName
eInst :: InstrumentName
eInst :: MEvent -> InstrumentName
eInst, Int
ePitch :: Int
ePitch :: MEvent -> Int
ePitch, PTime
eDur :: PTime
eDur :: MEvent -> PTime
eDur, Int
eVol :: Int
eVol :: MEvent -> Int
eVol, [Double]
eParams :: [Double]
eParams :: MEvent -> [Double]
eParams}) Int
nid =
let instr :: Instr a
instr = InstrumentName -> InstrMap a -> Instr a
forall a. InstrumentName -> InstrMap a -> Instr a
lookupInstr InstrumentName
eInst InstrMap a
imap
tOn :: Double
tOn = PTime -> Double
forall a. Fractional a => PTime -> a
fromRational PTime
eTime
tDur :: Double
tDur = PTime -> Double
forall a. Fractional a => PTime -> a
fromRational PTime
eDur :: Double
sf :: a
sf = Instr a
instr PTime
eDur Int
ePitch Int
eVol [Double]
eParams
in [(Double
tOn, Int -> a -> NoteEvt a
forall a. Int -> a -> NoteEvt a
NoteOn Int
nid a
sf), (Double
tOn Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
tDur, Int -> NoteEvt a
forall a. Int -> NoteEvt a
NoteOff Int
nid)]
toEvtSF :: Clock p => [MEvent] -> InstrMap a -> Signal p () [Evt a]
toEvtSF :: forall p a.
Clock p =>
[MEvent] -> InstrMap a -> Signal p () [Evt a]
toEvtSF [MEvent]
pf InstrMap a
imap =
let evts :: [Evt a]
evts = (Evt a -> Evt a -> Ordering) -> [Evt a] -> [Evt a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Evt a -> Double) -> Evt a -> Evt a -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Evt a -> Double
forall a b. (a, b) -> a
fst) ([Evt a] -> [Evt a]) -> [Evt a] -> [Evt a]
forall a b. (a -> b) -> a -> b
$ [[Evt a]] -> [Evt a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Evt a]] -> [Evt a]) -> [[Evt a]] -> [Evt a]
forall a b. (a -> b) -> a -> b
$
(MEvent -> Int -> [Evt a]) -> [MEvent] -> [Int] -> [[Evt a]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (InstrMap a -> MEvent -> Int -> [Evt a]
forall a. InstrMap a -> MEvent -> Int -> [Evt a]
eventToEvtPair InstrMap a
imap) [MEvent]
pf [Int
0..]
in proc ()
_ -> do
rec
Double
t <- ArrowP SF p Double Double
forall (a :: * -> * -> *) p.
(ArrowCircuit a, Clock p) =>
ArrowP a p Double Double
integral -< Double
1
[Evt a]
es <- [Evt a] -> ArrowP SF p [Evt a] [Evt a]
forall b. b -> ArrowP SF p b b
forall (a :: * -> * -> *) b. ArrowCircuit a => b -> a b b
delay [Evt a]
evts -< [Evt a]
next
let ([Evt a]
evs, [Evt a]
next) = (Evt a -> Bool) -> [Evt a] -> ([Evt a], [Evt a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
t) (Double -> Bool) -> (Evt a -> Double) -> Evt a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Evt a -> Double
forall a b. (a, b) -> a
fst) [Evt a]
es
ArrowP SF p [Evt a] [Evt a]
forall (a :: * -> * -> *) b. Arrow a => a b b
outA -< [Evt a]
evs
modSF :: M.IntMap a -> [Evt a] -> M.IntMap a
modSF :: forall a. IntMap a -> [Evt a] -> IntMap a
modSF = (IntMap a -> Evt a -> IntMap a) -> IntMap a -> [Evt a] -> IntMap a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' IntMap a -> Evt a -> IntMap a
forall {a} {a}. IntMap a -> (a, NoteEvt a) -> IntMap a
mod
where mod :: IntMap a -> (a, NoteEvt a) -> IntMap a
mod IntMap a
m (a
_, NoteOn Int
nid a
sf) = Int -> a -> IntMap a -> IntMap a
forall a. Int -> a -> IntMap a -> IntMap a
M.insert Int
nid a
sf IntMap a
m
mod IntMap a
m (a
_, NoteOff Int
nid) = Int -> IntMap a -> IntMap a
forall a. Int -> IntMap a -> IntMap a
M.delete Int
nid IntMap a
m
pSwitch :: forall p col a. (Clock p, Functor col) =>
col (Signal p () a)
-> Signal p () [Evt (Signal p () a)]
-> (col (Signal p () a) -> [Evt (Signal p () a)] -> col (Signal p () a))
-> Signal p () (col a)
pSwitch :: forall p (col :: * -> *) a.
(Clock p, Functor col) =>
col (Signal p () a)
-> Signal p () [Evt (Signal p () a)]
-> (col (Signal p () a)
-> [Evt (Signal p () a)] -> col (Signal p () a))
-> Signal p () (col a)
pSwitch col (Signal p () a)
col Signal p () [Evt (Signal p () a)]
esig col (Signal p () a) -> [Evt (Signal p () a)] -> col (Signal p () a)
mod =
proc ()
_ -> do
[Evt (Signal p () a)]
evts <- Signal p () [Evt (Signal p () a)]
esig -< ()
rec
col (Signal p () a)
sfcol <- col (Signal p () a)
-> ArrowP SF p (col (Signal p () a)) (col (Signal p () a))
forall b. b -> ArrowP SF p b b
forall (a :: * -> * -> *) b. ArrowCircuit a => b -> a b b
delay col (Signal p () a)
col -< col (Signal p () a) -> [Evt (Signal p () a)] -> col (Signal p () a)
mod col (Signal p () a)
sfcol' [Evt (Signal p () a)]
evts
let rs :: col (a, SF () a)
rs = (Signal p () a -> (a, SF () a))
-> col (Signal p () a) -> col (a, SF () a)
forall a b. (a -> b) -> col a -> col b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Signal p () a
s -> SF () a -> () -> (a, SF () a)
forall a b. SF a b -> a -> (b, SF a b)
runSF (Signal p () a -> SF () a
forall (a :: * -> * -> *) p b c. ArrowP a p b c -> a b c
strip Signal p () a
s) ()) col (Signal p () a)
sfcol :: col (a, SF () a)
(col a
as, col (Signal p () a)
sfcol' :: col (Signal p () a)) = (((a, SF () a) -> a) -> col (a, SF () a) -> col a
forall a b. (a -> b) -> col a -> col b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, SF () a) -> a
forall a b. (a, b) -> a
fst col (a, SF () a)
rs, ((a, SF () a) -> Signal p () a)
-> col (a, SF () a) -> col (Signal p () a)
forall a b. (a -> b) -> col a -> col b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SF () a -> Signal p () a
forall (a :: * -> * -> *) p b c. a b c -> ArrowP a p b c
ArrowP (SF () a -> Signal p () a)
-> ((a, SF () a) -> SF () a) -> (a, SF () a) -> Signal p () a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, SF () a) -> SF () a
forall a b. (a, b) -> b
snd) col (a, SF () a)
rs)
ArrowP SF p (col a) (col a)
forall (a :: * -> * -> *) b. Arrow a => a b b
outA -< col a
as
renderSF :: (Clock p, ToMusic1 a, AudioSample b) =>
Music a
-> InstrMap (Signal p () b)
-> (Double, Signal p () b)
renderSF :: forall p a b.
(Clock p, ToMusic1 a, AudioSample b) =>
Music a -> InstrMap (Signal p () b) -> (Double, Signal p () b)
renderSF Music a
m InstrMap (Signal p () b)
im =
let ([MEvent]
pf, PTime
d) = Music1 -> ([MEvent], PTime)
perform1Dur (Music1 -> ([MEvent], PTime)) -> Music1 -> ([MEvent], PTime)
forall a b. (a -> b) -> a -> b
$ Music a -> Music1
forall a. ToMusic1 a => Music a -> Music1
toMusic1 Music a
m
evtsf :: Signal p () [Evt (Signal p () b)]
evtsf = [MEvent]
-> InstrMap (Signal p () b) -> Signal p () [Evt (Signal p () b)]
forall p a.
Clock p =>
[MEvent] -> InstrMap a -> Signal p () [Evt a]
toEvtSF [MEvent]
pf InstrMap (Signal p () b)
im
allsf :: Signal p () (IntMap b)
allsf = IntMap (Signal p () b)
-> Signal p () [Evt (Signal p () b)]
-> (IntMap (Signal p () b)
-> [Evt (Signal p () b)] -> IntMap (Signal p () b))
-> Signal p () (IntMap b)
forall p (col :: * -> *) a.
(Clock p, Functor col) =>
col (Signal p () a)
-> Signal p () [Evt (Signal p () a)]
-> (col (Signal p () a)
-> [Evt (Signal p () a)] -> col (Signal p () a))
-> Signal p () (col a)
pSwitch IntMap (Signal p () b)
forall a. IntMap a
M.empty Signal p () [Evt (Signal p () b)]
evtsf IntMap (Signal p () b)
-> [Evt (Signal p () b)] -> IntMap (Signal p () b)
forall a. IntMap a -> [Evt a] -> IntMap a
modSF
sf :: Signal p () b
sf = Signal p () (IntMap b)
allsf Signal p () (IntMap b) -> ArrowP SF p (IntMap b) b -> Signal p () b
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (IntMap b -> b) -> ArrowP SF p (IntMap b) b
forall b c. (b -> c) -> ArrowP SF p b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((b -> b -> b) -> b -> [b] -> b
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' b -> b -> b
forall a. AudioSample a => a -> a -> a
mix b
forall a. AudioSample a => a
zero ([b] -> b) -> (IntMap b -> [b]) -> IntMap b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap b -> [b]
forall a. IntMap a -> [a]
M.elems)
in (PTime -> Double
forall a. Fractional a => PTime -> a
fromRational PTime
d, Signal p () b
sf)