{-# LANGUAGE Arrows, ScopedTypeVariables, NamedFieldPuns, FlexibleContexts #-}

-- Render a Music object to a audio signal function that can be further

-- manipulated or saved to a file.  It is channel-agnostic in that it is

-- able to deal with instruments of arbitrary number of channels.


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)

-- Every instrument is a function that takes a duration, absolute

-- pitch, volume, and a list of parameters (Doubles).  What the function 

-- actually returns is implementation independent.

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."

-- Each note in a Performance is tagged with a unique NoteId, which

-- helps us keep track of the signal function associated with a note.

type NoteId = Int

-- In this particular implementation, 'a' is the signal function that

-- plays the given note.

data NoteEvt a = NoteOn  NoteId a
               | NoteOff NoteId

type Evt a = (Double, NoteEvt a) -- Timestamp in seconds, and the note event



-- Turn an Event into a NoteOn and a matching NoteOff with the same NodeId.  

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)]

-- Turn a Performance into an SF of NoteOn/NoteOffs.  

-- For each note, generate a unique id to tag the NoteOn and NoteOffs.

-- The tag is used as the key to the collection of signal functions

-- for efficient insertion/removal.

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..]
          -- Sort all NoteOn/NoteOff events by timestamp.

    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
             -- Trim events that are due off the list and output them,

             -- retaining the rest

         ArrowP SF p [Evt a] [Evt a]
forall (a :: * -> * -> *) b. Arrow a => a b b
outA -< [Evt a]
evs

-- Modify the collection upon receiving NoteEvts.  The timestamps 

-- are not used here, but they are expected to be the same.


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


-- Simplified version of a parallel switcher.  

-- Note that this is tied to the particular implementation of SF, as it

-- needs to use runSF to run all the signal functions in the collection.


pSwitch :: forall p col a. (Clock p, Functor col) =>
           col (Signal p () a)  -- Initial SF collection.

        -> Signal p () [Evt (Signal p () a)]    -- Input event stream.

        -> (col (Signal p () a) -> [Evt (Signal p () a)] -> col (Signal p () a))
           -- A Modifying function that modifies the collection of SF

           --   based on the event that is occuring.

        -> Signal p () (col a)  
           -- The resulting collection of output values obtained from

           --   running all SFs in the collection.


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
        -- perhaps this can be run at a lower rate using upsample

        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)
            -- ^ Duration of the music in seconds, 

            -- and a signal function that plays the music.


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 -- Updated 16-Dec-2015 

        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)  -- add up all samples

    in (PTime -> Double
forall a. Fractional a => PTime -> a
fromRational PTime
d, Signal p () b
sf)