{-# 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.Parameter (($#), ) 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) . Causal.map 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, v ~ A.Scalar v, A.PseudoModule 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 = Causal.map (uncurry $ Value.unlift2 $ curry $ Spatial.moveAround att sonicDelay ear) 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 = Causal.map $ 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 = Causal.map (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.lowpassCausal $<# Filt1Core.parameter (1/sampleRate::Float) let fast = Filt1.lowpassCausal $<# 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.lowpassCausalPacked $<# Filt1Core.parameter (1/sampleRate::Float) let fast = Filt1.lowpassCausalPacked $<# 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 >>> Causal.map 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))