{-# LANGUAGE NoImplicitPrelude #-} {-# 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.PiecewiseConstant.ALSA.MIDIControllerSet as PCS import qualified Synthesizer.CausalIO.ALSA.MIDIControllerSelection as MCS import qualified Synthesizer.CausalIO.ALSA.Process as PALSA import qualified Synthesizer.CausalIO.Process as PIO import qualified Synthesizer.MIDIValue as MV import qualified Synthesizer.Zip as Zip import Synthesizer.EventList.ALSA.MIDI (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 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 Data.TypeLevel.Num (D4, D8, D16, d0, d1, d2, d3, d4, d5, d6, d7, d8, ) import qualified Data.TypeLevel.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.Arrow as Arr import Control.Arrow (Arrow, arr, (&&&), (^<<), ) import Control.Category ((<<<), (.), id, (>>>), ) import Control.Monad ((<=<), ) import Control.Applicative (liftA2, pure, ) 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 Control.Monad.Trans.State as State 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.Storable.ALSA.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 () (Value Vector) -> 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 = fmap (const ()) . SoxPlay.simple SVL.hPut SoxOption.none 44100 sampleRate :: Ring.C a => a sampleRate = 44100 type Vector = LLVM.Vector VectorSize Float type VectorSize = TypeNum.D4 vectorSize :: Int vectorSize = TypeNum.toInt (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)) . PALSA.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 SoV.replicate) playFromEvents 0.01 (vectorBlockSize/sampleRate) (arr SigStL.unpackStrict . (proc () :: PIO.T (EventListBT.T NonNegW.Int Float) (SV.Vector Vector)) . arr subsampleBT . PALSA.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 (PALSA.controllerExponential (ChannelMsg.toChannel 0) Ctrl.modulation (hertz 500, hertz 2000) (hertz 1000)) (PALSA.controllerLinear (ChannelMsg.toChannel 0) Ctrl.timbre (-1, 1) (-0.1))) (PALSA.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)) moveAround2dFloat :: Float -> Float -> (Float, Float) -> CausalP.T p (Value Float, Value Float) (Value Float, Value Float) moveAround2dFloat att sonicDelay (earX,earY) = CausalP.mapSimple (Value.flatten . Spatial.moveAround (Value.constant att) (Value.constant sonicDelay) (Value.constant earX, Value.constant earY) . Value.unfold) moveAround2d :: (Ring.C a, LLVM.IsConst a, SoV.Replicate a v, LLVM.IsFloating v) => a -> a -> (a, a) -> CausalP.T p (Value v, Value v) (Value v, Value v) moveAround2d att sonicDelay (earX,earY) = -- (\dist -> (sonicDelay*dist, 1/(att+dist)^2)) . Euc.norm . subtract ear CausalP.mapSimple $ \(objX,objY) -> do dist <- euclideanNorm2d =<< liftA2 (,) (A.sub objX (SoV.replicateOf earX)) (A.sub objY (SoV.replicateOf earY)) delay <- A.mul dist (SoV.replicateOf sonicDelay) volume <- A.fdiv (SoV.replicateOf Ring.one) =<< A.square =<< A.add dist (SoV.replicateOf att) return (delay, volume) euclideanNorm2d :: (LLVM.IsFloating a) => (Value a, Value a) -> LLVM.CodeGenFunction r (Value a) euclideanNorm2d (x,y) = do x2 <- A.square x y2 <- A.square y A.sqrt =<< A.add x2 y2 flyChannel :: (Float, Float) -> CausalP.T p (Value Float, Value Float) (Value Float) flyChannel ear = ((moveAround2d 1 0.1 ear >>> Arr.first (negate id)) &&& (250/sampleRate + 2 * (CausalP.mapSimple euclideanNorm2d <<< (CausalP.differentiate $# (0::Float, 0::Float))))) >>> arr (\((phase,volume), speed) -> (volume, (phase,speed))) >>> Arr.second (CausalP.osciSimple Wave.saw) >>> CausalP.envelope >>> CausalP.amplify 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 d4) ((CausalP.arrayElement d0 &&& (liftA2 (,) ((CausalP.arrayElement d2 >>> slow) + CausalP.arrayElement d1 * (CausalP.fromSignal (GenP.noise 366210 0.3) >>> fast >>> fast)) ((CausalP.arrayElement d3 >>> 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 (hertz 500, hertz 2000) (hertz 1000), -} MCS.controllerLinear Ctrl.vectorX (-10, 10) 0, MCS.controllerLinear Ctrl.vectorY (-10, 10) 0] . MCS.fromChannel (ChannelMsg.toChannel 0)) flyChannelPacked :: (Float, Float) -> CausalP.T p (Value Vector, Value Vector) (Value Vector) flyChannelPacked ear = ((moveAround2d 1 0.1 ear >>> Arr.first (negate id)) &&& (250/sampleRate + 2 * (CausalP.mapSimple euclideanNorm2d <<< (CausalPS.differentiate $# (0::Float, 0::Float))))) >>> 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 d4) ((CausalPS.arrayElement d0 &&& (liftA2 (,) ((CausalPS.arrayElement d2 >>> slow) + CausalPS.arrayElement d1 * (CausalP.fromSignal (GenPS.noise 366210 0.3) >>> fast >>> fast)) ((CausalPS.arrayElement d3 >>> 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 (hertz 500, hertz 2000) (hertz 1000), -} MCS.controllerLinear Ctrl.vectorX (-10, 10) 0, MCS.controllerLinear Ctrl.vectorY (-10, 10) 0] . MCS.fromChannel (ChannelMsg.toChannel 0))