Speech.hs

{-# LANGUAGE NoImplicitPrelude #-}
module Synthesizer.LLVM.Server.CausalPacked.Speech where

import Synthesizer.LLVM.Server.CausalPacked.Instrument
          (Control, Frequency, frequencyControl, )
import Synthesizer.LLVM.Server.CommonPacked (Vector, VectorValue, )
import Synthesizer.LLVM.Server.Common (SampleRate, Real, frequency, )

import qualified Synthesizer.MIDI.CausalIO.Process as MIO
import qualified Synthesizer.CausalIO.Gate as Gate
import qualified Synthesizer.CausalIO.Process as PIO

import Synthesizer.LLVM.CausalParameterized.Process (($<), )
import Synthesizer.LLVM.CausalParameterized.FunctionalPlug (($&), (&|&), )
import qualified Synthesizer.LLVM.Frame.Stereo as Stereo
import qualified Synthesizer.LLVM.Frame.SerialVector as Serial
import qualified Synthesizer.LLVM.CausalParameterized.FunctionalPlug as FP
import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS
import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP
import qualified Synthesizer.LLVM.Parameterized.Signal as SigP

import qualified Synthesizer.Zip as Zip
import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg

import qualified Synthesizer.PiecewiseConstant.Signal as PC

import qualified Synthesizer.Plain.Filter.Recursive.Universal as UniFilter
import Synthesizer.Plain.Filter.Recursive (Pole(Pole))

import qualified Data.StorableVector as SV

import qualified LLVM.Core as LLVM

import Control.Arrow (Arrow, arr, (^<<), )
import Control.Category ((.), )
import Control.Applicative (liftA, liftA3, )

import NumericPrelude.Numeric
import NumericPrelude.Base hiding (id, (.), )


{-
stimmhaft
a, e, i, o, u, ä, ö, ü
l, m, n, ng

Diphtong
ai, oi, au, ui, ei

stimmlos/Zischlaute
f, h, w, s, sch, th, ch (weich), ch (kochen), r

explosiv
b, p, g, k, d, t
-}

{-
Formanten:
a -  700 Hz
i -  400 Hz, 2200 Hz
o -  600 Hz, 3000 Hz
f -  white noise
sch - highpass cutoff 1500 Hz
-}

phoneme ::
   IO (SampleRate Real -> VoiceMsg.Pitch ->
       PIO.T (Zip.T MIO.GateChunk (SV.Vector (Stereo.T Vector)))
             (SV.Vector (Stereo.T Vector)))
phoneme =
   liftA
      (\osc sr p ->
         case formants p of
            Nothing -> arr $ const SV.empty
            Just fs ->
               osc (sr, fs)
               .
               Gate.shorten)
      (CausalP.processIO
         (CausalP.stereoFromMono
             (let lowpass q f =
                     UniFilter.bandpass
                     ^<<
                     CtrlPS.process
                     $<
                     SigP.constant
                        (UniFilter.parameter . Pole q ^<< frequency f)
              in  lowpass 100 fst + lowpass 20 snd)))

formants :: VoiceMsg.Pitch -> Maybe (Real, Real)
formants p =
   case VoiceMsg.fromPitch p - 36 of
      00 -> Just ( 320,  800) -- u
      02 -> Just ( 500, 1000) -- o
      04 -> Just (1000, 1400) -- a
      05 -> Just (1500,  500) -- oe
      07 -> Just (1650,  320) -- ue
      09 -> Just (1800,  700) -- ae
      11 -> Just (2300,  500) -- e
      12 -> Just (3200,  320) -- i
      _ -> Nothing


type Input a = FP.Input (SampleRate Real) a

plugUniFilterParameter ::
   Input a (Control Real) ->
   Input a (Control Frequency) ->
   FP.T (SampleRate Real) pl a (UniFilter.Parameter (LLVM.Value Real))
plugUniFilterParameter reson freq =
   FP.plug $
   liftA3
      (\resonChunk freqChunk sr ->
         PC.zipWith
            (\ r f -> UniFilter.parameter $ Pole r f)
            resonChunk $ frequencyControl sr freqChunk)
      reson freq FP.askParameter


type FormantControl =
        Zip.T (Control Real)
           (Zip.T (Control Real) (Control Frequency))

singleFormant ::
   (Input inp (Control Real),
      (Input inp (Control Real), Input inp (Control Frequency))) ->
   Input inp (SV.Vector (Stereo.T Vector)) ->
   FP.T (SampleRate Real) pl inp (Stereo.T VectorValue)
singleFormant (amp, (reson, freq)) x =
   CausalP.envelopeStereo $&
      (CausalP.mapSimple Serial.upsample $& FP.plug amp)
      &|&
      (CausalP.stereoFromMonoControlled
           (UniFilter.bandpass ^<< CtrlPS.process) $&
         plugUniFilterParameter reson freq
         &|&
         FP.plug x)

filterFormant ::
   IO (SampleRate Real ->
       PIO.T
          (Zip.T FormantControl (SV.Vector (Stereo.T Vector)))
          (SV.Vector (Stereo.T Vector)))
filterFormant =
   liftA
      (\filt sr -> filt sr (sr, ()))
      (FP.withArgs $ \(fmt, x) -> singleFormant fmt x)

filterFormants ::
   IO (SampleRate Real ->
       PIO.T (Zip.T
                 (Zip.T FormantControl
                     (Zip.T FormantControl
                         (Zip.T FormantControl
                             (Zip.T FormantControl FormantControl))))
                 (SV.Vector (Stereo.T Vector)))
             (SV.Vector (Stereo.T Vector)))
filterFormants =
   liftA
      (\filt sr -> filt sr (sr, ()))
      (FP.withArgs $ \((fmt0, (fmt1, (fmt2, (fmt3, fmt4)))), x) ->
         foldl1 (+) $ map (flip singleFormant x) [fmt0, fmt1, fmt2, fmt3, fmt4])