{-# 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 ins im =
case lookup ins im of
Just i -> i
Nothing -> error $ "Instrument " ++ show ins ++
" 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 imap (MEvent {eTime, eInst, ePitch, eDur, eVol, eParams}) nid =
let instr = lookupInstr eInst imap
tOn = fromRational eTime
tDur = fromRational eDur :: Double
sf = instr eDur ePitch eVol eParams
in [(tOn, NoteOn nid sf), (tOn + tDur, NoteOff nid)]
toEvtSF :: Clock p => [MEvent] -> InstrMap a -> Signal p () [Evt a]
toEvtSF pf imap =
let evts = sortBy (comparing fst) $ concat $
zipWith (eventToEvtPair imap) pf [0..]
in proc _ -> do
rec
t <- integral -< 1
es <- delay evts -< next
let (evs, next) = span ((<= t) . fst) es
outA -< evs
modSF :: M.IntMap a -> [Evt a] -> M.IntMap a
modSF = foldl' mod
where mod m (_, NoteOn nid sf) = M.insert nid sf m
mod m (_, NoteOff nid) = M.delete nid 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 col esig mod =
proc _ -> do
evts <- esig -< ()
rec
sfcol <- delay col -< mod sfcol' evts
let rs = fmap (\s -> runSF (strip s) ()) sfcol :: col (a, SF () a)
(as, sfcol' :: col (Signal p () a)) = (fmap fst rs, fmap (ArrowP . snd) rs)
outA -< as
renderSF :: (Clock p, ToMusic1 a, AudioSample b) =>
Music a
-> InstrMap (Signal p () b)
-> (Double, Signal p () b)
renderSF m im =
let (pf, d) = perform1Dur $ toMusic1 m
evtsf = toEvtSF pf im
allsf = pSwitch M.empty evtsf modSF
sf = allsf >>> arr (foldl' mix zero . M.elems)
in (fromRational d, sf)