synthesizer-llvm-0.5: example/Synthesizer/LLVM/LNdW2011.hs
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
module Synthesizer.LLVM.LNdW2011 where
import qualified Synthesizer.LLVM.Plug.Input as PIn
import qualified Synthesizer.LLVM.Plug.Output as POut
import qualified Synthesizer.MIDI.PiecewiseConstant.ControllerSet as PCS
import qualified Synthesizer.MIDI.CausalIO.ControllerSelection as MCS
import qualified Synthesizer.MIDI.CausalIO.Process as PMIDI
import qualified Synthesizer.ALSA.CausalIO.Process as PALSA
import qualified Synthesizer.CausalIO.Process as PIO
import qualified Synthesizer.MIDI.Value as MV
import qualified Synthesizer.Zip as Zip
import Synthesizer.ALSA.EventList (ClientName(ClientName))
import qualified Sound.MIDI.Controller as Ctrl
import qualified Sound.MIDI.Message.Channel as ChannelMsg
import qualified Synthesizer.LLVM.Filter.ComplexFirstOrderPacked as BandPass
import qualified Synthesizer.LLVM.Filter.Allpass as Allpass
import qualified Synthesizer.LLVM.Filter.Butterworth as Butterworth
import qualified Synthesizer.LLVM.Filter.Chebyshev as Chebyshev
import qualified Synthesizer.LLVM.Filter.FirstOrder as Filt1
import qualified Synthesizer.LLVM.Filter.SecondOrder as Filt2
import qualified Synthesizer.LLVM.Filter.SecondOrderPacked as Filt2P
import qualified Synthesizer.LLVM.Filter.Moog as Moog
import qualified Synthesizer.LLVM.Filter.Universal as UniFilter
import qualified Synthesizer.LLVM.CausalParameterized.Controlled as CtrlP
import qualified Synthesizer.LLVM.CausalParameterized.ControlledPacked as CtrlPS
import qualified Synthesizer.LLVM.CausalParameterized.ProcessPacked as CausalPS
import qualified Synthesizer.LLVM.CausalParameterized.Process as CausalP
import qualified Synthesizer.LLVM.Causal.Process as Causal
import qualified Synthesizer.LLVM.Simple.Signal as Gen
import qualified Synthesizer.LLVM.Simple.Value as Value
import qualified Synthesizer.LLVM.Storable.Signal as SigStL
import qualified Synthesizer.LLVM.Frame.SerialVector as Serial
import qualified Synthesizer.LLVM.Frame as Frame
import qualified Synthesizer.LLVM.Wave as Wave
import qualified Synthesizer.LLVM.Parameter as Param
import qualified LLVM.Extra.ScalarOrVector as SoV
import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.Arithmetic as A
import qualified LLVM.Extra.Class as C
import LLVM.Core (Value, value, valueOf, constVector, constOf, )
import LLVM.Util.Arithmetic () -- Floating instance for TValue
import qualified LLVM.Core as LLVM
import Types.Data.Num (D4, D8, D16, d0, d1, d2, d3, d4, d5, d6, d7, d8, )
import qualified Types.Data.Num as TypeNum
import qualified Synthesizer.LLVM.Parameterized.SignalPacked as GenPS
import qualified Synthesizer.LLVM.Parameterized.Signal as GenP
import Synthesizer.LLVM.CausalParameterized.Process (($<), ($*), ($*#), ($<#), )
import Synthesizer.LLVM.Parameterized.Signal (($#), )
import qualified Synthesizer.Plain.Filter.Recursive as FiltR
import qualified Synthesizer.Plain.Filter.Recursive.FirstOrder as Filt1Core
import qualified Synthesizer.Plain.Filter.Recursive.SecondOrder as Filt2Core
import qualified Synthesizer.Causal.Spatial as Spatial
import qualified Control.Monad.Trans.State as State
import qualified Control.Arrow as Arr
import Control.Arrow (Arrow, arr, (&&&), (^<<), (^>>), )
import Control.Category ((<<<), (.), id, (>>>), )
import Control.Monad (liftM2, (<=<), )
import Control.Applicative (liftA2, pure, )
import Control.Functor.HT (void, )
import Data.Tuple.HT (mapPair, )
import Data.Traversable (traverse, )
import Foreign.Storable (Storable, )
import qualified Data.StorableVector.Lazy as SVL
import qualified Data.StorableVector as SV
import qualified Data.EventList.Relative.TimeBody as EventList
import qualified Data.EventList.Relative.BodyTime as EventListBT
import qualified Data.EventList.Relative.MixedTime as EventListMT
import qualified Data.EventList.Relative.TimeMixed as EventListTM
import qualified Data.EventList.Relative.TimeTime as EventListTT
import qualified Numeric.NonNegative.Wrapper as NonNegW
import qualified Numeric.NonNegative.Class as NonNeg
import qualified Synthesizer.LLVM.Frame.Stereo as Stereo
import qualified Synthesizer.LLVM.Frame.StereoInterleaved as StereoInt
import qualified Sound.Sox.Option.Format as SoxOption
import qualified Sound.Sox.Frame as SoxFrame
import qualified Sound.Sox.Play as SoxPlay
import qualified Sound.ALSA.PCM as ALSA
import qualified Synthesizer.ALSA.Storable.Play as Play
import Data.Word (Word32, )
-- import qualified Data.Function.HT as F
import Data.List (genericLength, )
import System.Random (randomRs, mkStdGen, )
import qualified System.IO as IO
-- import System.Exit (ExitCode, )
import qualified Algebra.NormedSpace.Euclidean as NormedEuc
import qualified Algebra.Field as Field
import qualified Algebra.Ring as Ring
import qualified Algebra.Additive as Additive
import qualified Algebra.IntegralDomain as Integral
import NumericPrelude.Numeric
import NumericPrelude.Base hiding (fst, snd, id, (.), )
import qualified NumericPrelude.Base as P
asMono :: vector Float -> vector Float
asMono = id
asStereo :: vector (Stereo.T Float) -> vector (Stereo.T Float)
asStereo = id
asMonoPacked :: vector Vector -> vector Vector
asMonoPacked = id
asMonoPacked16 :: vector (LLVM.Vector D16 Float) -> vector (LLVM.Vector D16 Float)
asMonoPacked16 = id
asWord32 :: vector Word32 -> vector Word32
asWord32 = id
asWord32Packed :: vector (LLVM.Vector D4 Word32) -> vector (LLVM.Vector D4 Word32)
asWord32Packed = id
playStereo :: Gen.T (Stereo.T (Value Float)) -> IO ()
playStereo =
playStereoStream .
Gen.renderChunky (SVL.chunkSize 100000)
playStereoStream :: SVL.Vector (Stereo.T Float) -> IO ()
playStereoStream = playStreamSox
playMono :: Gen.T (Value Float) -> IO ()
playMono =
playMonoStream .
Gen.renderChunky (SVL.chunkSize 100000)
playMonoParam :: GenP.T () (Value Float) -> IO ()
playMonoParam =
playMonoStream .
($ ()) .
($ SVL.chunkSize 100000) <=<
GenP.runChunky
playMonoPacked :: GenP.T () VectorValue -> IO ()
playMonoPacked =
playMonoStream .
SigStL.unpack .
($ ()) .
($ SVL.chunkSize 100000) <=<
GenP.runChunky
playMonoStream :: SVL.Vector Float -> IO ()
playMonoStream = playStreamSox
playStreamALSA ::
(Additive.C y, ALSA.SampleFmt y) =>
SVL.Vector y -> IO ()
playStreamALSA =
Play.auto (Play.makeSink Play.defaultDevice (0.05::Double) sampleRate)
-- reacts faster to CTRL-C
playStreamSox ::
(Storable y, SoxFrame.C y) =>
SVL.Vector y -> IO ()
playStreamSox =
void . SoxPlay.simple SVL.hPut SoxOption.none 44100
sampleRate :: Ring.C a => a
sampleRate = 44100
type Vector = Serial.Plain VectorSize Float
type VectorSize = TypeNum.D4
type VectorValue = Serial.Value VectorSize Float
vectorSize :: Int
vectorSize = TypeNum.fromIntegerT (undefined :: VectorSize)
vectorRate :: Field.C a => a
vectorRate = sampleRate / fromIntegral vectorSize
intSecond :: Ring.C a => Float -> a
intSecond t = fromInteger $ round $ t * sampleRate
second :: Field.C a => a -> a
second t = t * sampleRate
hertz :: Field.C a => a -> a
hertz f = f / sampleRate
fst :: Arrow arrow => arrow (a,b) a
fst = arr P.fst
snd :: Arrow arrow => arrow (a,b) b
snd = arr P.snd
playFromEvents ::
(ALSA.SampleFmt a, Additive.C a) =>
Double ->
Double ->
PIO.T PALSA.Events (SV.Vector a) ->
IO ()
playFromEvents latency period =
PALSA.playFromEvents
Play.defaultDevice (ClientName "Haskell-LLVM-demo")
latency period sampleRate
modulation :: IO ()
modulation = do
proc <-
CausalP.processIO
(0.95 * (CausalP.osciSimple Wave.approxSine4 $< 0))
playFromEvents 0.01 (0.015::Double)
((proc () :: PIO.T (EventListBT.T NonNegW.Int Float) (SV.Vector Float))
.
PMIDI.controllerExponential
(ChannelMsg.toChannel 0)
Ctrl.modulation
(hertz 500, hertz 2000) (hertz 1000))
vectorBlockSize :: Double
vectorBlockSize = fromIntegral $ 150*vectorSize
subsample :: (Integral.C t) => t -> t -> State.State t t
subsample step t =
State.state $ \r -> divMod (r+t) step
{-
do modify (t+)
(q,r) <- gets (flip divMod step)
put r
return q
-}
subsampleBT :: EventListBT.T NonNegW.Int a -> EventListBT.T NonNegW.Int a
subsampleBT =
flip State.evalState NonNeg.zero .
EventListBT.mapTimeM (subsample (NonNegW.fromNumberMsg "vectorSize" vectorSize))
modulationPacked :: IO ()
modulationPacked = do
proc <-
CausalP.processIO
(0.95 * (CausalPS.osciSimple Wave.approxSine4 $< 0)
.
CausalP.mapSimple Serial.upsample)
playFromEvents 0.01 (vectorBlockSize/sampleRate)
(arr SigStL.unpackStrict
.
(proc () :: PIO.T (EventListBT.T NonNegW.Int Float) (SV.Vector Vector))
.
arr subsampleBT
.
PMIDI.controllerExponential
(ChannelMsg.toChannel 0)
Ctrl.modulation
(hertz 500, hertz 2000) (hertz 1000))
bubbles :: IO ()
bubbles = do
proc <-
CausalP.processIO
(0.95 * (CausalP.osciSimple Wave.sine $< 0)
.
(fst.fst * (1 + snd.fst * snd))
.
Arr.second (CausalP.osciSimple Wave.saw $< 0))
playFromEvents 0.01 (0.015::Double)
((proc () ::
PIO.T
(Zip.T
(Zip.T
(EventListBT.T NonNegW.Int Float)
(EventListBT.T NonNegW.Int Float))
(EventListBT.T NonNegW.Int Float))
(SV.Vector Float))
.
PIO.zip
(PIO.zip
(PMIDI.controllerExponential
(ChannelMsg.toChannel 0)
Ctrl.modulation
(hertz 500, hertz 2000) (hertz 1000))
(PMIDI.controllerLinear
(ChannelMsg.toChannel 0)
Ctrl.timbre
(-1, 1) (-0.1)))
(PMIDI.controllerExponential
(ChannelMsg.toChannel 0)
Ctrl.soundVariation
(hertz 1, hertz 10) (hertz 1)))
bubblesSet :: IO ()
bubblesSet = do
proc <-
CausalP.processIOCore
(PIn.controllerSet d6)
(CausalP.arrayElement d0 *
(CausalP.osciSimple Wave.sine $< 0)
.
(CausalP.arrayElement d1
*
(1 - CausalP.arrayElement d2 *
(CausalP.osciSimple Wave.saw $< 0) .
CausalP.arrayElement d3)
*
(1 - CausalP.arrayElement d4 *
(CausalP.osciSimple Wave.saw $< 0) .
CausalP.arrayElement d5)))
POut.storableVector
playFromEvents 0.01 (0.015::Double)
((proc () :: PIO.T (PCS.T Int Float) (SV.Vector Float))
.
MCS.filter [
MCS.controllerExponential Ctrl.volume (0.001, 0.99) 0.5,
MCS.controllerExponential Ctrl.modulation (hertz 500, hertz 2000) (hertz 1000),
MCS.controllerLinear Ctrl.soundVariation (-1, 1) 0.7,
MCS.controllerExponential Ctrl.timbre (hertz 0.2, hertz 5) (hertz 1),
MCS.controllerLinear Ctrl.soundController5 (-1, 1) 0.5,
MCS.controllerExponential Ctrl.soundController7 (hertz 2, hertz 20) (hertz 10)]
.
MCS.fromChannel (ChannelMsg.toChannel 0))
subsamplePCS :: PCS.T key a -> PCS.T key a
subsamplePCS =
PCS.mapStream $
flip State.evalState NonNeg.zero .
EventListTT.mapTimeM (subsample (NonNegW.fromNumberMsg "vectorSize" $ fromIntegral vectorSize))
bubblesPacked :: IO ()
bubblesPacked = do
proc <-
CausalP.processIOCore
(PIn.controllerSet d6)
(CausalPS.arrayElement d0 *
(CausalPS.osciSimple Wave.approxSine4 $< 0)
.
(CausalPS.arrayElement d1
*
(1 - CausalPS.arrayElement d2 *
(CausalPS.osciSimple Wave.saw $< 0) .
CausalPS.arrayElement d3)
*
(1 - CausalPS.arrayElement d4 *
(CausalPS.osciSimple Wave.saw $< 0) .
CausalPS.arrayElement d5)))
POut.storableVector
playFromEvents 0.01 (vectorBlockSize/sampleRate)
(arr SigStL.unpackStrict
.
(proc () :: PIO.T (PCS.T Int Float) (SV.Vector Vector))
.
arr subsamplePCS
.
MCS.filter [
MCS.controllerExponential Ctrl.volume (0.001, 0.99) 0.5,
MCS.controllerExponential Ctrl.modulation (hertz 500, hertz 2000) (hertz 1000),
MCS.controllerLinear Ctrl.soundVariation (-1, 1) 0.7,
MCS.controllerExponential Ctrl.timbre (hertz 0.2, hertz 5) (hertz 1),
MCS.controllerLinear Ctrl.soundController5 (-1, 1) 0.5,
MCS.controllerExponential Ctrl.soundController7 (hertz 2, hertz 20) (hertz 10)]
.
MCS.fromChannel (ChannelMsg.toChannel 0))
{-
Implementation of 'moveAround' that just lifts the corresponding plain function
in the @Spatial@ module from @synthesizer-core@.
Unfortunately, this way we get a @PseudoModule v v@ constraint
that cannot be satisfied with @LLVM.Vector@s.
-}
moveAround2dLifted ::
(A.Transcendental v, A.PseudoModule v v,
A.Real v, A.RationalConstant v) =>
Value.T v -> Value.T v -> (Value.T v, Value.T v) ->
CausalP.T p (v, v) (v, v)
moveAround2dLifted att sonicDelay ear =
CausalP.mapSimple
(uncurry (liftM2 (,)) .
mapPair (Value.decons, Value.decons) .
Spatial.moveAround att sonicDelay ear .
mapPair (Value.constantValue, Value.constantValue))
moveAround2d ::
(A.Algebraic v, A.RationalConstant v) =>
Value.T v -> Value.T v -> (Value.T v, Value.T v) ->
CausalP.T p (v, v) (v, v)
moveAround2d att sonicDelay ear =
CausalP.mapSimple $ Value.flattenFunction $
(\dist -> (sonicDelay*dist, 1/(att+dist)^2)) .
euclideanNorm2d . subtract ear
euclideanNorm2d ::
(A.Algebraic a) =>
(Value.T a, Value.T a) -> Value.T a
euclideanNorm2d (x,y) =
Value.sqrt $ Value.square x + Value.square y
mapFunc ::
(Value.Flatten a, Value.Flatten b) =>
(a -> b) ->
CausalP.T p (Value.Registers a) (Value.Registers b)
mapFunc f =
CausalP.mapSimple (Value.flattenFunction f)
flyChannel ::
(Value.T (Value Float), Value.T (Value Float)) ->
CausalP.T p (Value Float, (Value Float, Value Float)) (Value Float)
flyChannel ear =
((snd ^>> moveAround2d 1 0.1 ear >>> Arr.first (negate id))
&&&
(Arr.second
(2 * ((CausalP.differentiate $# (0::Float, 0::Float))
>>>
mapFunc euclideanNorm2d))
>>>
CausalP.mix))
>>>
arr (\((phase,volume), speed) -> (volume, (phase,speed)))
>>>
Arr.second (CausalP.osciSimple Wave.saw)
>>>
(CausalP.envelope * 10)
fly :: IO ()
fly = do
let slow =
Filt1.lowpassCausalP $<#
Filt1Core.parameter (1/sampleRate::Float)
let fast =
Filt1.lowpassCausalP $<#
Filt1Core.parameter (30/sampleRate::Float)
proc <-
CausalP.processIOCore
(PIn.controllerSet d5)
((CausalP.arrayElement d0 &&&
(liftA2 (,)
(CausalP.arrayElement d2)
(liftA2 (,)
((CausalP.arrayElement d3 >>> slow)
+
CausalP.arrayElement d1 *
(CausalP.fromSignal (GenP.noise 366210 0.3) >>> fast >>> fast))
((CausalP.arrayElement d4 >>> slow)
+
CausalP.arrayElement d1 *
(CausalP.fromSignal (GenP.noise 234298 0.3) >>> fast >>> fast)))
>>>
liftA2 Stereo.cons
(flyChannel (-1,0))
(flyChannel ( 1,0))))
>>>
CausalP.envelopeStereo)
POut.storableVector
playFromEvents 0.01 (0.015::Double)
((proc () :: PIO.T (PCS.T Int Float) (SV.Vector (Stereo.T Float)))
.
MCS.filter [
MCS.controllerExponential Ctrl.volume (0.001, 0.99) 0.2,
MCS.controllerLinear Ctrl.modulation (0, 5) 2,
MCS.pitchBend 2 (hertz 250),
MCS.controllerLinear Ctrl.vectorX (-10, 10) 0,
MCS.controllerLinear Ctrl.vectorY (-10, 10) 0]
.
MCS.fromChannel (ChannelMsg.toChannel 0))
flyChannelPacked ::
(Value.T VectorValue, Value.T VectorValue) ->
CausalP.T p (VectorValue, (VectorValue, VectorValue)) VectorValue
flyChannelPacked ear =
((snd ^>> moveAround2d 1 0.1 ear >>> Arr.first (negate id))
&&&
(Arr.second
(2 * ((CausalPS.differentiate $# (0::Float, 0::Float))
>>>
mapFunc euclideanNorm2d))
>>>
CausalP.mix))
>>>
arr (\((phase,volume), speed) -> (volume, (phase,speed)))
>>>
Arr.second (CausalPS.osciSimple Wave.saw)
>>>
CausalP.envelope
>>>
CausalPS.amplify 10
flyPacked :: IO ()
flyPacked = do
let slow =
Filt1.lowpassCausalPackedP $<#
Filt1Core.parameter (1/sampleRate::Float)
let fast =
Filt1.lowpassCausalPackedP $<#
Filt1Core.parameter (30/sampleRate::Float)
proc <-
CausalP.processIOCore
(PIn.controllerSet d5)
((CausalPS.arrayElement d0 &&&
(liftA2 (,)
(CausalPS.arrayElement d2)
(liftA2 (,)
((CausalPS.arrayElement d3 >>> slow)
+
CausalPS.arrayElement d1 *
(CausalP.fromSignal (GenPS.noise 366210 0.3) >>> fast >>> fast))
((CausalPS.arrayElement d4 >>> slow)
+
CausalPS.arrayElement d1 *
(CausalP.fromSignal (GenPS.noise 234298 0.3) >>> fast >>> fast)))
>>>
liftA2 Stereo.cons
(flyChannelPacked (-1,0))
(flyChannelPacked ( 1,0))))
>>>
CausalP.envelopeStereo
>>>
CausalP.mapSimple StereoInt.interleave)
POut.storableVector
playFromEvents 0.01 (vectorBlockSize/sampleRate)
(arr SigStL.unpackStereoStrict
.
(proc () :: PIO.T (PCS.T Int Float) (SV.Vector (StereoInt.T VectorSize Float)))
.
arr subsamplePCS
.
MCS.filter [
MCS.controllerExponential Ctrl.volume (0.001, 0.99) 0.2,
MCS.controllerLinear Ctrl.modulation (0, 5) 2,
MCS.pitchBend 2 (hertz 250),
MCS.controllerLinear Ctrl.vectorX (-10, 10) 0,
MCS.controllerLinear Ctrl.vectorY (-10, 10) 0]
.
MCS.fromChannel (ChannelMsg.toChannel 0))