Common.hs

{-# LANGUAGE TypeFamilies #-}
module Synthesizer.LLVM.Server.Common (
   Real,
   SampleRate(SampleRate),
   Instrument,
   frequency, time, number, control, signal, parameter,
   frequencyConst, timeConst,
   ($/),

   chopEvents,
   piecewiseConstant,
   transposeModulation,
   amplitudeFromVelocity,

   controllerAttack, controllerDetune, controllerTimbre0, controllerTimbre1,
   controllerFilterCutoff, controllerFilterResonance,
   controllerVolume,
   ) where

import qualified Sound.MIDI.Controller as Ctrl
import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg

import qualified Synthesizer.MIDI.Storable as MidiSt
import qualified Synthesizer.PiecewiseConstant.Signal as PC
import qualified Synthesizer.LLVM.MIDI.BendModulation as BM

import qualified Synthesizer.LLVM.Parameterized.Signal as SigP
import qualified Synthesizer.LLVM.Parameter as Param

import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.Class as Class

import qualified Synthesizer.Storable.Signal as SigSt

import qualified Data.EventList.Relative.TimeTime as EventListTT

import qualified Numeric.NonNegative.Class   as NonNeg

import Foreign.Storable (Storable, )

import Control.Arrow (arr, (^<<), )

import Prelude hiding (Real, )



newtype SampleRate a = SampleRate a
   deriving (Show)

instance Functor SampleRate where
   fmap f (SampleRate sr) = SampleRate (f sr)


type Real = Float

type Instrument a sig = SampleRate a -> MidiSt.Instrument a sig


frequency :: (p -> Real) -> Param.T (SampleRate Real, p) Real
frequency param =
   arr (\(SampleRate sampleRate, p) -> param p / sampleRate)

time :: (p -> Real) -> Param.T (SampleRate Real, p) Real
time param =
   arr (\(SampleRate sampleRate, p) -> param p * sampleRate)

number :: (p -> Real) -> Param.T (SampleRate Real, p) Real
number param = arr (param . snd)

control :: (p -> PC.T Real) -> Param.T (SampleRate Real, p) (PC.T Real)
control param = arr (param . snd)

signal :: (p -> SigSt.T a) -> Param.T (SampleRate Real, p) (SigSt.T a)
signal param = arr (param . snd)

parameter :: (p -> a) -> Param.T (SampleRate Real, p) a
parameter param = arr (param . snd)


frequencyConst :: Real -> Param.T (SampleRate Real, p) Real
frequencyConst param =
   arr (\(SampleRate sampleRate, _p) -> param / sampleRate)

timeConst :: Real -> Param.T (SampleRate Real, p) Real
timeConst param =
   arr (\(SampleRate sampleRate, _p) -> param * sampleRate)



($/) :: (Functor f) => f (a -> b) -> a -> f b
f $/ x = fmap ($x) f


-- might be moved to event-list package
chopEvents ::
   (NonNeg.C time, Num time) =>
   time ->
   EventListTT.T time body ->
   [EventListTT.T time body]
chopEvents chunkSize =
   let go evs =
          let (chunk,rest) = EventListTT.splitAtTime chunkSize evs
          in  if EventListTT.duration chunk == 0
                then []
                else chunk : go rest
   in  go


piecewiseConstant ::
   (Storable a,
    Class.MakeValueTuple a, Class.ValueTuple a ~ al,
    Memory.C al) =>
   Param.T p (PC.T a) -> SigP.T p al
piecewiseConstant pc =
   SigP.piecewiseConstant
      (PC.subdivideLongStrict ^<< pc)

transposeModulation ::
   (Functor stream) =>
   SampleRate Real ->
   Real ->
   stream (BM.T Real) ->
   stream (BM.T Real)
transposeModulation (SampleRate sampleRate) freq =
   fmap (BM.shift (freq/sampleRate))


{-# INLINE amplitudeFromVelocity #-}
amplitudeFromVelocity :: Real -> Real
amplitudeFromVelocity vel = 4**vel


controllerAttack, controllerDetune, controllerTimbre0, controllerTimbre1,
   controllerFilterCutoff, controllerFilterResonance,
   controllerVolume :: VoiceMsg.Controller
controllerAttack = Ctrl.attackTime
controllerDetune = Ctrl.chorusDepth   -- Ctrl.effect3Depth
controllerTimbre0 = Ctrl.soundVariation
controllerTimbre1 = Ctrl.timbre
controllerFilterCutoff = Ctrl.effect4Depth
controllerFilterResonance = Ctrl.effect5Depth
controllerVolume = Ctrl.volume