Render.hs

module Synthesizer.Render where

import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
import Sound.MIDI.Message.Channel.Voice (Pitch, )

import qualified Data.StorableVector.ST.Strict as SVST
import qualified Data.StorableVector as SV

import Foreign.Storable (Storable, )
import Control.Monad.ST.Strict as ST

import qualified Control.Monad.Trans.State.Strict as MS

import qualified Data.Map as Map

import Control.Monad (liftM, )

import Debug.Trace (trace, )


type Time = Integer
type Size = Int
type SampleRate = Int


check :: Monad m => Bool -> String -> m () -> m ()
check b msg act =
   if not b
     then trace msg $ return ()
     else act

unsafeAddChunkToBuffer :: (Storable a, Num a) =>
   SVST.Vector s a -> Int -> SV.Vector a -> ST s ()
unsafeAddChunkToBuffer v start xs =
   let go i j =
          if j >= SV.length xs
            then return ()
            else
              SVST.unsafeModify v i (SV.index xs j +) >>
              go (i + 1) (j + 1)
   in  check (start>=0)
                ("start negative: " ++ show (start, SV.length xs)) $
       check (start <= SVST.length v)
                ("start too late: " ++ show (start, SV.length xs)) $
       check (start+SV.length xs <= SVST.length v)
                ("end too late: " ++ show (start, SV.length xs)) $
       go start 0

arrange ::
   (Storable a, Num a) =>
   Size ->
   [(Int, SV.Vector a)] ->
   SV.Vector a
arrange size evs =
   SVST.runSTVector (do
      v <- SVST.new (fromIntegral size) 0
      mapM_ (uncurry $ unsafeAddChunkToBuffer v) evs
      return v)


data OscillatorState a = OscillatorState a a Int

type State a = Map.Map Pitch (OscillatorState a)


initialState :: State a
initialState = Map.empty


stopTone ::
   Int ->
   (Maybe (Int, OscillatorState a),
    [(Int, Int, OscillatorState a)]) ->
   [(Int, Int, OscillatorState a)]
stopTone stopTime (mplaying, finished) =
   case mplaying of
      Just (startTime, osci) ->
         (startTime, stopTime-startTime, osci) : finished
      Nothing -> finished

renderTone ::
   (Storable a, Floating a) =>
   Int -> OscillatorState a ->
   (SV.Vector a, OscillatorState a)
renderTone dur state@(OscillatorState amp freq phase) =
   if dur<0
     then
       trace ("renderTone: negative duration " ++ show dur) $
       (SV.empty, state)
     else
       let gain = 0.9999
       in  (SV.zipWith (\y k -> y * sin (2*pi*fromIntegral k * freq))
               (SV.iterateN dur (gain*) amp)
               (SV.iterateN dur (1+) phase),
            OscillatorState (amp*gain^dur) freq (phase+dur))

processEvents ::
   (Storable a, Floating a, Monad m) =>
   Size ->
   SampleRate ->
   [(Time, VoiceMsg.T)] ->
   MS.StateT (State a) m [(Int, SV.Vector a)]
processEvents size rate input = do
   oscis0 <- MS.get
   let pendingOscis =
          fmap
             (\(mplaying, finished) ->
                let mplayingNew =
                       fmap
                          (\(start,s0) ->
                             case renderTone (fromIntegral size - start) s0 of
                                (chunk, s1) -> ((start,chunk), s1))
                          mplaying
                in  (fmap snd mplayingNew,
                     maybe id (\p -> (fst p :)) mplayingNew $
                     map
                        (\(start, dur, s) -> (start, fst $ renderTone dur s))
                        finished)) $
          foldl
             (\oscis (time,ev) ->
                case VoiceMsg.explicitNoteOff ev of
                   VoiceMsg.NoteOn pitch velocity ->
                      Map.insertWith
                         (\(newOsci, []) s ->
                            {-
                            A key may be pressed that was already pressed.
                            This should not happen, but we must be prepared for it.
                            Thus we call stopTone.
                            -}
                            (newOsci, stopTone time s))
                         pitch
                         (Just (time,
                             OscillatorState
                                (0.2 * 2 ** VoiceMsg.realFromVelocity velocity)
                                (VoiceMsg.frequencyFromPitch pitch /
                                 fromIntegral rate)
                                0),
                          [])
                         oscis
                   VoiceMsg.NoteOff pitch _velocity ->
                      Map.adjust
                         (\s ->
                            {-
                            A key may be released that was not pressed.
                            This should not happen, but we must be prepared for it.
                            Thus stopTone also handles that case.
                            -}
                            (Nothing, stopTone time s))
                         pitch
                         oscis
                   _ -> oscis)
             (fmap (\s -> (Just (0, s), [])) oscis0)
             (map (\(time,ev) -> (fromInteger time, ev)) input)
   MS.put (Map.mapMaybe fst pendingOscis)
   return (concatMap snd $ Map.elems pendingOscis)

run ::
   (Storable a, Floating a, Monad m) =>
   Size ->
   SampleRate ->
   [(Time, VoiceMsg.T)] ->
   MS.StateT (State a) m (SV.Vector a)
run size rate input =
   liftM (arrange size) $ processEvents size rate input