synthesizer-llvm-0.3: src/Synthesizer/LLVM/ALSA/MIDI.hs

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

import qualified Synthesizer.Generic.ALSA.MIDI as Gen
import qualified Synthesizer.LLVM.ALSA.BendModulation as BM

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 qualified Data.TypeLevel.Num as TypeNum

import Foreign.Storable (Storable, )

import qualified Algebra.RealField      as RealField
import qualified Algebra.Ring           as Ring
-- 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 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 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 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 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 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, SoV.Replicate a 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 ::
   (Ring.C a, LLVM.IsConst a,
    Ring.C y, LLVM.IsConst y,
    Memory.FirstClass y ym, LLVM.IsSized y ysize, LLVM.IsSized ym ymsize,
    Storable y, Class.MakeValueTuple y (LLVM.Value y),
    SoV.Fraction y, SoV.Replicate a y) =>
   Param.T p y ->
   CausalP.T p (BM.T (LLVM.Value y)) (LLVM.Value y)
frequencyFromBendModulation speed =
   CausalP.envelope
   <<<
   second
      (CausalP.mapSimple (A.add (SoV.replicateOf 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 am, LLVM.IsSized a asize, LLVM.IsSized am amsize,
    LLVM.IsPrimitive am,
    Storable a, Class.MakeValueTuple a (LLVM.Value a),
    Vector.Real a, SoV.Replicate a (LLVM.Vector n a), TypeNum.Pos n,
    TypeNum.Mul n asize vsize, TypeNum.Pos vsize,
    TypeNum.Mul n amsize vmsize, TypeNum.Pos vmsize) =>
   Param.T p a ->
   CausalP.T p
      (BM.T (LLVM.Value a))
      (LLVM.Value (LLVM.Vector n a))
frequencyFromBendModulationPacked speed =
   CausalP.envelope
   <<<
   second
      (CausalP.mapSimple (A.add (SoV.replicateOf 1)) <<< CausalP.envelope
         $> SigPS.osciSimple Wave.approxSine2 zero speed)
   <<<
   CausalP.mapSimple
      (\(BM.Cons b m) ->
         liftM2 (,) (SoV.replicate b) (SoV.replicate m))