MIDI.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{- |
Convert MIDI events of a MIDI controller to a control signal.
-}
module Synthesizer.LLVM.MIDI (
   module Synthesizer.LLVM.MIDI,
   Gen.applyModulation,
   ) where

import qualified Synthesizer.MIDI.Generic as Gen
import qualified Synthesizer.LLVM.MIDI.BendModulation as BM
import qualified Synthesizer.LLVM.Frame.SerialVector as Serial

import Synthesizer.LLVM.CausalParameterized.Process (($>), )
import qualified Synthesizer.LLVM.Parameterized.SignalPacked as SigPS
import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP
import qualified Synthesizer.LLVM.Parameterized.Signal as SigP
import qualified Synthesizer.LLVM.Parameter as Param
import qualified Synthesizer.LLVM.Wave as Wave

import qualified LLVM.Extra.ScalarOrVector as SoV
import qualified LLVM.Extra.Vector as Vector
import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.Arithmetic as A
import qualified LLVM.Extra.Class as Class
import qualified LLVM.Core as LLVM
import LLVM.Core (IsSized, SizeOf, )

import qualified Types.Data.Bool as TypeBool
import qualified Types.Data.Num as TypeNum
import Types.Data.Num.Ops ((:*:), )

import Foreign.Storable (Storable, )

import qualified Algebra.RealField      as RealField
import qualified Algebra.Additive       as Additive

import Control.Arrow (second, (<<<), (<<^), )
import Control.Monad ({- liftM, -} liftM2, )

-- import NumericPrelude.Base
import NumericPrelude.Numeric
import Prelude ()


{-
{-# INLINE piecewiseConstantInit #-}
piecewiseConstantInit ::
   (Storable y, Class.MakeValueTuple y, Class.ValueTuple y ~ yl,
    Memory.C yl ym, LLVM.IsSized ym ys) =>
   y -> EventListTT.T LazyTime y -> SigP.T p yl
piecewiseConstantInit initial evs =
   SigP.piecewiseConstant $#
   (PC.subdivideInt $
    EventListMT.consBody initial evs)


{-# INLINE controllerLinear #-}
controllerLinear ::
   (Field.C y, Storable y, Class.MakeValueTuple y, Class.ValueTuple y ~ yl,
    Memory.C yl ym, LLVM.IsSized ym ys) =>
   Channel -> Controller ->
   (y,y) -> y ->
   Filter (SigP.T p yl)
controllerLinear chan ctrl bnd initial =
   liftM (piecewiseConstantInit initial .
          EventListTT.mapBody (MV.controllerLinear bnd)) $
   getControllerEvents chan ctrl


{-# INLINE controllerExponential #-}
controllerExponential ::
   (Trans.C y, Storable y, Class.MakeValueTuple y, Class.ValueTuple y ~ yl,
    Memory.C yl ym, LLVM.IsSized ym ys) =>
   Channel -> Controller ->
   (y,y) -> y ->
   Filter (SigP.T p yl)
controllerExponential chan ctrl bnd initial =
   liftM (piecewiseConstantInit initial .
          EventListTT.mapBody (MV.controllerExponential bnd)) $
   getControllerEvents chan ctrl


{- |
@pitchBend channel range center@:
emits frequencies on an exponential scale from
@center/range@ to @center*range@.
-}
{-# INLINE pitchBend #-}
pitchBend ::
   (Trans.C y, Storable y, Class.MakeValueTuple y, Class.ValueTuple y ~ yl,
    Memory.C yl ym, LLVM.IsSized ym ys) =>
   Channel ->
   y -> y ->
   Filter (SigP.T p yl)
pitchBend chan range center =
   liftM (piecewiseConstantInit center .
          EventListTT.mapBody (MV.pitchBend range center)) $
   getSlice (maybePitchBend chan)
--   getPitchBendEvents chan

{-# INLINE channelPressure #-}
channelPressure ::
   (Trans.C y, Storable y, Class.MakeValueTuple y, Class.ValueTuple y ~ yl,
    Memory.C yl ym, LLVM.IsSized ym ys) =>
   Channel ->
   y -> y ->
   Filter (SigP.T p yl)
channelPressure chan maxVal initVal =
   liftM (piecewiseConstantInit initVal .
          EventListTT.mapBody (MV.controllerLinear (0,maxVal))) $
   getSlice (maybeChannelPressure chan)


{-# INLINE bendWheelPressure #-}
bendWheelPressure ::
   (Ring.C a, LLVM.IsConst a,
    RealField.C y, Trans.C y,
    LLVM.IsConst y, SoV.Fraction y, a ~ SoV.Scalar y, SoV.Replicate y,
    Storable y, Class.MakeValueTuple y (LLVM.Value y), LLVM.IsSized y ys) =>
   Channel ->
   Int -> y -> y -> y ->
   Filter (SigP.T p (LLVM.Value y))
bendWheelPressure chan
     pitchRange speed wheelDepth pressDepth =
   do bend  <- pitchBend chan
                  (2^?(fromIntegral pitchRange/12) `asTypeOf` speed) 1
      fm    <- controllerLinear chan VoiceMsg.modulation (0,wheelDepth) 0
      press <- channelPressure chan pressDepth 0
      return $
         SigP.envelope bend $
         SigP.mapSimple (A.add (LLVM.valueOf 1)) $
         SigP.envelope
            (SigP.mix fm press)
            (SigP.osciSimple Wave.approxSine2 zero $# speed)
-}


frequencyFromBendModulation ::
   (Additive.C y, Storable y, Class.MakeValueTuple y, Class.ValueTuple y ~ yl,
    A.PseudoRing yl, A.Fraction yl, A.IntegerConstant yl, Memory.C yl) =>
   Param.T p y ->
   CausalP.T p (BM.T yl) yl
frequencyFromBendModulation speed =
   CausalP.envelope
   <<<
   second
      (CausalP.mapSimple (A.add (A.fromInteger' 1)) <<< CausalP.envelope
         $> SigP.osciSimple Wave.approxSine2 zero speed)
   <<^
   (\(BM.Cons b m) -> (b,m))


frequencyFromBendModulationPacked ::
   (RealField.C a, LLVM.IsConst a, LLVM.IsFloating a,
    Memory.FirstClass a, Memory.Stored a ~ am, IsSized a, IsSized am,
    LLVM.IsPrimitive am,
    Storable a, Class.MakeValueTuple a, Class.ValueTuple a ~ (LLVM.Value a),
    Vector.Real a, SoV.IntegerConstant a,
    TypeNum.PositiveT n, TypeNum.IsPositive n ~ TypeBool.True,
    TypeNum.PositiveT (n :*: SizeOf a),
    TypeNum.PositiveT (n :*: SizeOf am)) =>
   Param.T p a ->
   CausalP.T p (BM.T (LLVM.Value a)) (Serial.Value n a)
frequencyFromBendModulationPacked speed =
   CausalP.envelope
   <<<
   second
      (CausalP.mapSimple (A.add (A.fromInteger' 1)) <<< CausalP.envelope
         $> SigPS.osciSimple Wave.approxSine2 zero speed)
   <<<
   CausalP.mapSimple
      (\(BM.Cons b m) ->
         liftM2 (,) (Serial.upsample b) (Serial.upsample m))