diff --git a/csound-expression-typed.cabal b/csound-expression-typed.cabal --- a/csound-expression-typed.cabal +++ b/csound-expression-typed.cabal @@ -1,5 +1,5 @@ Name: csound-expression-typed -Version: 0.1.0.0 +Version: 0.2.0.0 Cabal-Version: >= 1.22 License: BSD3 License-file: LICENSE @@ -34,6 +34,22 @@ data/opcodes/diode.udo data/opcodes/korg35.udo data/opcodes/zero-delay-convolution.udo + data/opcodes/PitchShifterDelay.udo + data/opcodes/MultiFX/AnalogDelay.udo + data/opcodes/MultiFX/Distortion.udo + data/opcodes/MultiFX/EnvelopeFollower.udo + data/opcodes/MultiFX/Flanger.udo + data/opcodes/MultiFX/FreqShifter.udo + data/opcodes/MultiFX/LoFi.udo + data/opcodes/MultiFX/PanTrem.udo + data/opcodes/MultiFX/MonoTrem.udo + data/opcodes/MultiFX/Phaser.udo + data/opcodes/MultiFX/PitchShifter.udo + data/opcodes/MultiFX/Reverse.udo + data/opcodes/MultiFX/RingModulator.udo + data/opcodes/MultiFX/StChorus.udo + data/opcodes/MultiFX/StereoPingPongDelay.udo + data/opcodes/Utility/Delay1k.udo Homepage: https://github.com/anton-k/csound-expression-typed @@ -48,7 +64,7 @@ Ghc-Options: -Wall Build-Depends: base >= 4, base < 5, ghc-prim, containers, transformers >= 0.3, Boolean >= 0.1.0, colour >= 2.0, data-default, deepseq, - wl-pprint, csound-expression-dynamic >= 0.2.0, temporal-media >= 0.6.0, hashable + wl-pprint, csound-expression-dynamic >= 0.3.0, temporal-media >= 0.6.0, hashable Hs-Source-Dirs: src/ Exposed-Modules: Csound.Typed @@ -60,10 +76,13 @@ Csound.Typed.Gui Csound.Typed.Gui.Cab - Csound.Typed.Types.Prim + Csound.Typed.Types.Prim Csound.Typed.Types.Evt Csound.Typed.Types.Tuple Csound.Typed.Types.Lift + Csound.Typed.Types.Array + Csound.Typed.Types.MonoArg + Csound.Typed.Types.SigSpace Csound.Typed.Plugins @@ -73,9 +92,12 @@ Csound.Typed.GlobalState.GE Csound.Typed.GlobalState.SE Csound.Typed.GlobalState.Instr + Csound.Typed.GlobalState.InstrApi Csound.Typed.GlobalState.Cache Csound.Typed.GlobalState.Elements - Csound.Typed.GlobalState.Opcodes + Csound.Typed.GlobalState.Opcodes + Csound.Typed.GlobalState.Port + Csound.Typed.InnerOpcodes Csound.Typed.Types.TupleHelpers Csound.Typed.Types.MixSco @@ -88,8 +110,11 @@ Csound.Typed.Control.Sf2 Csound.Typed.Control.Osc Csound.Typed.Control.Channel - Csound.Typed.Control.Ref + Csound.Typed.Control.Ref Csound.Typed.Control.Instr + Csound.Typed.Control.InstrRef + Csound.Typed.Control.ArrayTraverse + Csound.Typed.Control.MacrosArgs Csound.Typed.Gui.Gui Csound.Typed.Gui.Widget @@ -108,6 +133,8 @@ Csound.Typed.Plugins.Audaciouseq Csound.Typed.Plugins.SolinaChorus Csound.Typed.Plugins.ZeroDelayConvolution + Csound.Typed.Plugins.Iain + Csound.Typed.Plugins.Utilities Paths_csound_expression_typed diff --git a/data/opcodes/MultiFX/AnalogDelay.udo b/data/opcodes/MultiFX/AnalogDelay.udo new file mode 100644 --- /dev/null +++ b/data/opcodes/MultiFX/AnalogDelay.udo @@ -0,0 +1,35 @@ +; AnalogDelay +; ---------------- +; A analog style delay with signal degradation and saturation options +; +; aout AnalogDelay ain,kmix,ktime,kfback,ktone +; +; Performance +; ----------- +; ain -- input audio to which the flanging effect will be applied +; kmix -- dry / wet mix of the output signal (range 0 to 1) +; ktime -- delay time of the effect in seconds +; kfback -- control of the amount of output signal fed back into the input of the effect (exceeding 1 (100%) is possible and will result in saturation clipping effects) +; ktone -- control of the amount of output signal fed back into the input of the effect (range 0 to 1) + + +opcode AnalogDelay,a,aKKKK + ain,kmix,ktime,kfback,ktone xin ;READ IN INPUT ARGUMENTS + ktone expcurve ktone,4 ;CREATE AN EXPONENTIAL REMAPPING OF ktone + ktone scale ktone,12000,100 ;RESCALE 0 - 1 VALUE + iWet ftgentmp 0,0,1024,-7,0,512,1,512,1 ;RESCALING FUNCTION FOR WET LEVEL CONTROL + iDry ftgentmp 0,0,1024,-7,1,512,1,512,0 ;RESCALING FUNCTION FOR DRY LEVEL CONTROL + kWet table kmix, iWet, 1 ;RESCALE WET LEVEL CONTROL ACCORDING TO FUNCTION TABLE iWet + kDry table kmix, iDry, 1 ;RESCALE DRY LEVEL CONTROL ACCORDING TO FUNCTION TABLE iWet + kporttime linseg 0,0.001,0.1 ;RAMPING UP PORTAMENTO TIME + kTime portk ktime, kporttime*3 ;APPLY PORTAMENTO SMOOTHING TO DELAY TIME PARAMETER + kTone portk ktone, kporttime ;APPLY PORTAMENTO SMOOTHING TO TONE PARAMETER + aTime interp kTime ;INTERPOLATE AND CREAT A-RATE VERSION OF DELAY TIME PARAMETER + aBuffer delayr 5 ;READ FROM (AND INITIALIZE) BUFFER + atap deltap3 aTime ;TAP DELAY BUFFER + atap clip atap, 0, 0dbfs*0.8 ;SIGNAL IS CLIPPED AT MAXIMUM AMPLITUDE USING BRAM DE JONG METHOD + atap tone atap, kTone ;LOW-PASS FILTER DELAY TAP WITHIN DELAY BUFFER + delayw ain+(atap*kfback) ;WRITE INPUT AUDIO AND FEEDBACK SIGNAL INTO DELAY BUFFER + aout sum ain*kDry, atap*kWet ;MIX DRY AND WET SIGNALS + xout aout ;SEND AUDIO BACK TO CALLER INSTRUMENT +endop diff --git a/data/opcodes/MultiFX/Distortion.udo b/data/opcodes/MultiFX/Distortion.udo new file mode 100644 --- /dev/null +++ b/data/opcodes/MultiFX/Distortion.udo @@ -0,0 +1,28 @@ +; Distortion +; ---------------- +; A distortion effect offering stomp-box-like controls +; +; aout Distortion ain,klevel,kdrive,ktone +; +; Performance +; ----------- +; ain -- input audio to be distorted +; klevel -- output level of the effect (range: 0 to 1) +; kdrive -- intensity of the distortion effect (range: 0 to 1) +; ktone -- tone of a lowpass filter (range: 0 to 1) + +opcode Distortion, a, aKKK + ain,klevel,kdrive,ktone xin ;READ IN INPUT ARGUMENTS + klevel scale klevel,0.8,0 ;RESCALE LEVEL CONTROL + kdrive expcurve kdrive,8 ;EXPONENTIALLY REMAP kdrive + kdrive scale kdrive,0.4,0.01 ;RESCALE kdrive + kLPF expcurve ktone,4 ;EXPONENTIALLY REMAP ktone + kLPF scale kLPF,12000,200 ;RESCALE klpf + kGainComp1 logcurve ktone,700 ;LOGARITHMIC RESCALING OF ktone TO CREAT A GAIN COMPENSATION VARIABLE FOR WHEN TONE IS LOWERED + kGainComp1 scale kGainComp1,1,5 ;RESCALE GAIN COMPENSATION VARIABLE + kpregain = (kdrive*100) ;DEFINE PREGAIN FROM kdrive + kpostgain = 0.5 * (((1-kdrive) * 0.4) + 0.6) ;DEFINE POSTGAIN FROM kdrive + aDist distort1 ain*(32768/0dbfs), kpregain, kpostgain, 0, 0 ;CREATE DISTORTION SIGNAL + aDist butlp aDist/(32768/0dbfs), kLPF ;LOWPASS FILTER DISTORTED SIGNAL + xout aDist*klevel*kGainComp1 ;SEND AUDIO BACK TO CALLER INSTRUMENT. RESCALE WITH USER LEVEL CONTROL AND GAIN COMPENSATION +endop diff --git a/data/opcodes/MultiFX/EnvelopeFollower.udo b/data/opcodes/MultiFX/EnvelopeFollower.udo new file mode 100644 --- /dev/null +++ b/data/opcodes/MultiFX/EnvelopeFollower.udo @@ -0,0 +1,29 @@ +; EnvelopeFollower +; ---------------- +; A dynamic envelope following resonant lowpass filter +; +; aout EnvelopeFollower ain,ksens,kfreq,kres +; +; Performance +; ----------- +; ain -- input audio to be filtered +; ksens -- sensitivity of the envelope follower (suggested range: 0 to 1) +; kfreq -- base frequency of the filter before modulation by the input dynamics (range: 0 to 1) +; kres -- resonance of the lowpass filter (suggested range: 0 to 0.99) + + +opcode EnvelopeFollower,a,aKKK + ain,ksens,kfreq,kres xin ;READ IN INPUT ARGUMENTS + kfreq expcurve kfreq,4 ;CREATE AN EXPONENTIAL REMAPPING OF kfreq + kfreq scale kfreq,10000,10 ;RESCALE 0 - 1 VALUE + ksens logcurve ksens,100 ;CREATE LOGARITHMIC REMAPPING OF ksens + aFollow follow2 ain, 0.01, 0.05 ;AMPLITUDE FOLLOWING AUDIO SIGNAL + kFollow downsamp aFollow ;DOWNSAMPLE TO K-RATE + kFollow expcurve kFollow/0dbfs,3 ;ADJUSTMENT OF THE RESPONSE OF DYNAMICS TO FILTER FREQUENCY MODULATION + kFrq = kfreq + (cpsoct(kFollow*ksens*150)) ;CREATE A LEFT CHANNEL MODULATING FREQUENCY BASE ON THE STATIC VALUE CREATED BY kfreq AND THE AMOUNT OF DYNAMIC ENVELOPE FOLLOWING GOVERNED BY ksens + kFrq port kFrq, 0.05 ;SMOOTH CONTROL SIGNAL USING PORTAMENTO + kFrq limit kFrq, 20,sr/2 ;LIMIT FREQUENCY RANGE TO PREVENT OUT OF RANGE FREQUENCIES + ;IF REALTIME PERFORMNCE IS AN ISSUE, USE moogvcf2 INSTEAD OF moogladder + aout moogladder ain, kFrq, kres ;REDEFINE GLOBAL AUDIO SIGNAL AS FILTERED VERSION OF ITSELF + xout aout ;SEND AUDIO BACK TO CALLER INSTRUMENT +endop diff --git a/data/opcodes/MultiFX/Flanger.udo b/data/opcodes/MultiFX/Flanger.udo new file mode 100644 --- /dev/null +++ b/data/opcodes/MultiFX/Flanger.udo @@ -0,0 +1,32 @@ +; Flanger +; ---------------- +; A flanger effect following the typical design of a so called 'stomp box' +; +; aout Flanger ain,krate,kdepth,kdelay,kfback +; +; Performance +; ----------- +; ain -- input audio to which the flanging effect will be applied +; krate -- rate control of the lfo of the effect *NOT IN HERTZ* (range 0 to 1) +; kdepth -- depth of the lfo of the effect (range 0 to 1) +; kdelay -- static delay offset of the flanging effect (range 0 to 1) +; kfback -- feedback and therefore intensity of the effect (range 0 to 1) + + +opcode Flanger,a,aKKKK + ain,krate,kdepth,kdelay,kfback xin ;READ IN INPUT ARGUMENTS + krate expcurve krate,50 ;CREATE AN EXPONENTIAL REMAPPING OF krate + krate scale krate,14,0.001 ;RESCALE VALUE + kdelay expcurve kdelay,200 ;CREATE AN EXPONENTIAL REMAPPING OF kdelay + kdelay scale kdelay,0.1,0.00015 ;RESCALE VALUE + ilfoshape ftgentmp 0, 0, 131072, 19, 0.5, 1, 180, 1 ;U-SHAPE PARABOLA FOR LFO + kporttime linseg 0, 0.001, 0.1 ;USE OF AN ENVELOPE VALUE THAT QUICKLY RAMPS UP FROM ZERON TO THE REQUIRED VALUE PREVENTS VARIABLES GLIDING TO THEIR REQUIRED VALUES EACH TIME THE INSTRUMENT IS STARTED + kdlt portk kdelay, kporttime ;PORTAMENTO IS APPLIED TO A VARIABLE. A NEW VARIABLE 'kdlt' IS CREATED. + adlt interp kdlt ;A NEW A-RATE VARIABLE 'adlt' IS CREATED BY INTERPOLATING THE K-RATE VARIABLE 'kdlt' + kdep portk kdepth*0.01, kporttime ;PORTAMENTO IS APPLIED TO A VARIABLE. A NEW VARIABLE 'kdep' IS CREATED. + amod oscili kdep, krate, ilfoshape ;OSCILLATOR THAT MAKES USE OF THE POSITIVE DOMAIN ONLY U-SHAPE PARABOLA WITH FUNCTION TABLE NUMBER ilfoshape + adlt sum adlt, amod ;STATIC DELAY TIME AND MODULATING DELAY TIME ARE SUMMED + adelsig flanger ain, adlt, kfback , 1.2 ;FLANGER SIGNAL CREATED + aout sum ain*0.5, adelsig*0.5 ;CREATE DRY/WET MIX + xout aout ;SEND AUDIO BACK TO CALLER INSTRUMENT +endop diff --git a/data/opcodes/MultiFX/FreqShifter.udo b/data/opcodes/MultiFX/FreqShifter.udo new file mode 100644 --- /dev/null +++ b/data/opcodes/MultiFX/FreqShifter.udo @@ -0,0 +1,38 @@ +; FreqShifter +; ---------------- +; A frequency shifter effect using the hilbert filter +; +; aout FreqShifter adry,kmix,kfreq,kmult,kfback +; +; Performance +; ----------- +; adry -- input audio to be frequency shifted +; kmix -- dry / wet mix of the output signal (range 0 to 1) +; kfreq -- frequency of frequency shifter effect (suggested range -1000 to 1000) +; kmult -- multiplier of frequency value for fine tuning control (suggested range -1 to 1) +; kfback -- control of the amount of output signal fed back into the input of the effect (suggested range 0 to 1) + +opcode FreqShifter,a,aKKKK + adry,kmix,kfreq,kmult,kfback xin ;READ IN INPUT ARGUMENTS + iWet ftgentmp 0,0,1024,-7,0,512,1,512,1 ;RESCALING FUNCTION FOR WET LEVEL CONTROL + iDry ftgentmp 0,0,1024,-7,1,512,1,512,0 ;RESCALING FUNCTION FOR DRY LEVEL CONTROL + isine ftgentmp 0,0,4096,10,1 ;A SINE WAVE SHAPE + kWet table kmix, iWet, 1 ;RESCALE WET LEVEL CONTROL ACCORDING TO FUNCTION TABLE giWet + kDry table kmix, iDry, 1 ;RESCALE DRY LEVEL CONTROL ACCORDING TO FUNCTION TABLE giWet + aFS init 0 ;INITILISE FEEDBACK SIGNAL (FOR FIRST K-PASS) + ain = adry + (aFS * kfback) ;ADD FEEDBACK SIGNAL TO INPUT (AMOUNT OF FEEDBACK CONTROLLED BY 'Feedback Gain' SLIDER) + areal, aimag hilbert ain ;HILBERT OPCODE OUTPUTS TWO PHASE SHIFTED SIGNALS, EACH 90 OUT OF PHASE WITH EACH OTHER + kporttime linseg 0,0.001,0.02 + kfshift portk kfreq*kmult, kporttime + ;QUADRATURE OSCILLATORS. I.E. 90 OUT OF PHASE WITH RESPECT TO EACH OTHER + ;OUTUTS OPCODE AMPLITUDE | FREQ. | FUNCTION_TABLE | INITIAL_PHASE (OPTIONAL;DEFAULTS TO ZERO) + asin oscili 1, kfshift, isine, 0 + acos oscili 1, kfshift, isine, 0.25 + ;RING MODULATE EACH SIGNAL USING THE QUADRATURE OSCILLATORS AS MODULATORS + amod1 = areal * acos + amod2 = aimag * asin + ;UPSHIFTING OUTPUT + aFS = (amod1 - amod2) + aout sum aFS*kWet, adry*kDry ;CREATE WET/DRY MIX + xout aout ;SEND AUDIO BACK TO CALLER INSTRUMENT +endop diff --git a/data/opcodes/MultiFX/LoFi.udo b/data/opcodes/MultiFX/LoFi.udo new file mode 100644 --- /dev/null +++ b/data/opcodes/MultiFX/LoFi.udo @@ -0,0 +1,23 @@ +; LoFi +; ---------------- +; 'Low Fidelity' distorting effects of bit reduction and downsampling (foldover) +; +; aout LoFi ain,kbits,kfold +; +; Performance +; ----------- +; ain -- input audio to have low fidelity distortion effects applied +; kbits -- bit depth reduction (suggested range 0 to 0.6) +; kfold -- amount of foldover (range 0 to 1) + + +opcode LoFi,a,aKK + ain,kbits,kfold xin ;READ IN INPUT ARGUMENTS + kfold expcurve kfold,500 ;CREATE AN EXPONENTIAL REMAPPING OF kfold + kfold scale kfold,1024,1 ;RESCALE 0 - 1 VALUE TO 1 - 1024 + kvalues pow 2, ((1-(kbits^0.25))*15)+1 ;RAISES 2 TO THE POWER OF kbitdepth. THE OUTPUT VALUE REPRESENTS THE NUMBER OF POSSIBLE VALUES AT THAT PARTICULAR BIT DEPTH + k16bit pow 2, 16 ;RAISES 2 TO THE POWER OF 16 + aout = (int((ain*32768*kvalues)/k16bit)/32768)*(k16bit/kvalues) ;BIT DEPTH REDUCE AUDIO SIGNAL + aout fold aout, kfold ;APPLY SAMPLING RATE FOLDOVER + xout aout ;SEND AUDIO BACK TO CALLER INSTRUMENT +endop diff --git a/data/opcodes/MultiFX/MonoTrem.udo b/data/opcodes/MultiFX/MonoTrem.udo new file mode 100644 --- /dev/null +++ b/data/opcodes/MultiFX/MonoTrem.udo @@ -0,0 +1,35 @@ + +; MonoTrem +; ---------------- +; Tremolo effect +; +; aout MonoTrem ain,krate,kdepth,kwave +; +; Performance +; ----------- +; ain -- input audio +; krate -- rate control of the lfo of the effect *NOT IN HERTZ* (range 0 to 1) +; kdepth -- depth of the lfo of the effect (range 0 to 1) +; kwave -- waveform used by the lfo (0=sine 1=triangle 2=square) + +opcode MonoTrem,a,aKKK + ain,krate,kdepth,kwave xin ;READ IN INPUT ARGUMENTS + krate expcurve krate,5 ;CREATE AN EXPONENTIAL REMAPPING OF krate + krate scale krate,50,0.1 ;RESCALE VALUE + ktrig changed kwave ;IF LFO WAVEFORM TYPE IS CHANGED GENERATE A MOMENTARY '1' (BANG) + if ktrig=1 then ;IF A 'BANG' HAS BEEN GENERATED IN THE ABOVE LINE + reinit UPDATE ;BEGIN A REINITIALIZATION PASS FROM LABEL 'UPDATE' SO THAT LFO WAVEFORM TYPE CAN BE UPDATED + endif ;END OF THIS CONDITIONAL BRANCH + UPDATE: ;LABEL CALLED UPDATE + klfo lfo kdepth, krate, i(kwave) ;CREATE AN LFO + rireturn ;RETURN FROM REINITIALIZATION PASS + klfo = (klfo*0.5)+0.5 ;RESCALE AND OFFSET LFO SO IT STAY WITHIN THE RANGE 0 - 1 ABOUT THE VALUE 0.5 + if kwave=2 then ;IF SQUARE WAVE MODULATION HAS BEEN CHOSEN... + klfo portk klfo, 0.001 ;SMOOTH THE SQUARE WAVE A TINY BIT TO PREVENT CLICKS + endif ;END OF THIS CONDITIONAL BRANCH + + klfo = klfo+(0.5-(kdepth*0.5)) ;MODIFY LFO AT ZERO DEPTH VALUE IS 1 AND AT MAX DEPTH CENTRE OF MODULATION IS 0.5 + alfo interp klfo ;INTERPOLATE K-RATE LFO AND CREATE A-RATE VARIABLE + aout = ain*(alfo^2) ;REDEFINE GLOBAL AUDIO LEFT CHANNEL SIGNAL WITH TREMELO + xout aout ;SEND AUDIO BACK TO CALLER INSTRUMENT +endop diff --git a/data/opcodes/MultiFX/PanTrem.udo b/data/opcodes/MultiFX/PanTrem.udo new file mode 100644 --- /dev/null +++ b/data/opcodes/MultiFX/PanTrem.udo @@ -0,0 +1,42 @@ +; PanTrem +; ---------------- +; Auto-panning and tremolo effects +; +; aout1,aout2 PanTrem ainL,ainR,,krate,kdepth,kmode,kwave +; +; Performance +; ----------- +; ainL -- first/left input audio +; ainR -- second/right input audio +; krate -- rate control of the lfo of the effect *NOT IN HERTZ* (range 0 to 1) +; kdepth -- depth of the lfo of the effect (range 0 to 1) +; kmode -- mode of the effect (0=auto-panning 1=tremolo) +; kwave -- waveform used by the lfo (0=sine 1=triangle 2=square) + +opcode PanTrem,aa,aaKKKK + ainL,ainR,krate,kdepth,kmode,kwave xin ;READ IN INPUT ARGUMENTS + krate expcurve krate,5 ;CREATE AN EXPONENTIAL REMAPPING OF krate + krate scale krate,50,0.1 ;RESCALE VALUE + ktrig changed kwave ;IF LFO WAVEFORM TYPE IS CHANGED GENERATE A MOMENTARY '1' (BANG) + if ktrig=1 then ;IF A 'BANG' HAS BEEN GENERATED IN THE ABOVE LINE + reinit UPDATE ;BEGIN A REINITIALIZATION PASS FROM LABEL 'UPDATE' SO THAT LFO WAVEFORM TYPE CAN BE UPDATED + endif ;END OF THIS CONDITIONAL BRANCH + UPDATE: ;LABEL CALLED UPDATE + klfo lfo kdepth, krate, i(kwave) ;CREATE AN LFO + rireturn ;RETURN FROM REINITIALIZATION PASS + klfo = (klfo*0.5)+0.5 ;RESCALE AND OFFSET LFO SO IT STAY WITHIN THE RANGE 0 - 1 ABOUT THE VALUE 0.5 + if kwave=2 then ;IF SQUARE WAVE MODULATION HAS BEEN CHOSEN... + klfo portk klfo, 0.001 ;SMOOTH THE SQUARE WAVE A TINY BIT TO PREVENT CLICKS + endif ;END OF THIS CONDITIONAL BRANCH + if kmode=0 then ;PAN ;IF PANNING MODE IS CHOSEN FROM BUTTON BANK... + alfo interp klfo ;INTERPOLATE K-RATE LFO AND CREATE A-RATE VARIABLE + aoutL = ainL*sqrt(alfo) ;REDEFINE GLOBAL AUDIO LEFT CHANNEL SIGNAL WITH AUTO-PANNING + aoutR = ainR*(1-sqrt(alfo)) ;REDEFINE GLOBAL AUDIO RIGHT CHANNEL SIGNAL WITH AUTO-PANNING + elseif kmode=1 then ;TREM ;IF TREMELO MODE IS CHOSEN FROM BUTTON BANK... + klfo = klfo+(0.5-(kdepth*0.5)) ;MODIFY LFO AT ZERO DEPTH VALUE IS 1 AND AT MAX DEPTH CENTRE OF MODULATION IS 0.5 + alfo interp klfo ;INTERPOLATE K-RATE LFO AND CREATE A-RATE VARIABLE + aoutL = ainL*(alfo^2) ;REDEFINE GLOBAL AUDIO LEFT CHANNEL SIGNAL WITH TREMELO + aoutR = ainR*(alfo^2) ;REDEFINE GLOBAL AUDIO RIGHT CHANNEL SIGNAL WITH TREMELO + endif ;END OF THIS CONDITIONAL BRANCH + xout aoutL,aoutR ;SEND AUDIO BACK TO CALLER INSTRUMENT +endop diff --git a/data/opcodes/MultiFX/Phaser.udo b/data/opcodes/MultiFX/Phaser.udo new file mode 100644 --- /dev/null +++ b/data/opcodes/MultiFX/Phaser.udo @@ -0,0 +1,22 @@ +; Phaser +; ---------------- +; An phase shifting effect that mimics the design of a so called 'stomp box' +; +; aout Phaser ain,krate,kdepth,kfreq,kfback +; +; Performance +; ----------- +; ain -- input audio to be pitch shifted +; krate -- rate of lfo of the effect (range 0 to 1) +; kdepth -- depth of lfo of the effect (range 0 to 1) +; kfreq -- centre frequency of the phase shifting effect in octaves (suggested range 6 to 11) +; kfback -- feedback and therefore intensity of the effect (range 0 to 1) + +opcode Phaser,a,aKKKK + ain,krate,kdepth,kfreq,kfback xin ;READ IN INPUT ARGUMENTS + krate expcurve krate,10 ;CREATE AN EXPONENTIAL REMAPPING OF krate + krate scale krate,14,0.01 ;RESCALE 0 - 1 VALUE TO 0.01 - 14 + klfo lfo kdepth*0.5, krate, 1 ;LFO FOR THE PHASER (TRIANGULAR SHAPE) + aout phaser1 ain, cpsoct((klfo+(kdepth*0.5)+kfreq)), 8, kfback ;PHASER1 IS APPLIED TO THE INPUT AUDIO + xout aout ;SEND AUDIO BACK TO CALLER INSTRUMENT +endop diff --git a/data/opcodes/MultiFX/PitchShifter.udo b/data/opcodes/MultiFX/PitchShifter.udo new file mode 100644 --- /dev/null +++ b/data/opcodes/MultiFX/PitchShifter.udo @@ -0,0 +1,30 @@ +; PitchShifter +; ------------ +; A pitch shifter effect based on FFT technology +; +; aout PitchShifter ain,kmix,kpitch,kfine,kfback +; +; Performance +; ----------- +; ain -- input audio to be pitch shifted +; kmix -- dry / wet mix of the output signal (range 0 to 1) +; kpitch -- pitch shifting interval in thousands of a semitone (suggested range -0.012 to 0.012) +; kfine -- fine control of pitch shifting interval in octaves (range -1/12 to 1/12) +; kfback -- control of the amount of output signal fed back into the input of the effect (suggested range 0 to 1) + +opcode PitchShifter,a,aKKKi + ain,kmix,kscal,kfback,ifftsize xin ;READ IN INPUT ARGUMENTS + iWet ftgentmp 0,0,1024,-7,0,512,1,512,1 ;RESCALING FUNCTION FOR WET LEVEL CONTROL + iDry ftgentmp 0,0,1024,-7,1,512,1,512,0 ;RESCALING FUNCTION FOR DRY LEVEL CONTROL + kWet table kmix, iWet, 1 ;RESCALE WET LEVEL CONTROL ACCORDING TO FUNCTION TABLE iWet + kDry table kmix, iDry, 1 ;RESCALE DRY LEVEL CONTROL ACCORDING TO FUNCTION TABLE iWet + aPS init 0 ;INITIALIZE aOutL FOR FIRST PERFORMANCE TIME PASS + ; kscal = octave(((kpitch*1000)/12)+kfine) ;DERIVE PITCH SCALING RATIO. NOTE THAT THE 'COARSE' PITCH DIAL BECOMES STEPPED IN SEMITONE INTERVALS + ioverlap = ifftsize / 4 + iwinsize = ifftsize + fsig1 pvsanal ain+(aPS*kfback), ifftsize,ioverlap,iwinsize,0 ;PHASE VOCODE ANALYSE LEFT CHANNEL + fsig2 pvscale fsig1, kscal ;RESCALE PITCH + aPS pvsynth fsig2 ;RESYNTHESIZE FROM FSIG + aout sum ain*kDry, aPS*kWet ;REDEFINE GLOBAL AUDIO SIGNAL FROM MIX OF DRY AND WET SIGNALS + xout aout ;SEND AUDIO BACK TO CALLER INSTRUMENT +endop diff --git a/data/opcodes/MultiFX/Reverse.udo b/data/opcodes/MultiFX/Reverse.udo new file mode 100644 --- /dev/null +++ b/data/opcodes/MultiFX/Reverse.udo @@ -0,0 +1,29 @@ +; Reverse +; ---------------- +; An effect that reverses an audio stream in chunks +; +; aout Reverse ain,ktime +; +; Performance +; ----------- +; ain -- input audio to be reversed +; ktime -- time duration of each chunk (suggested range: 0.3 to 2) + +opcode Reverse, a, aK ;nb. CAPITAL K CREATE A K-RATE VARIABLE THAT HAS A USEFUL VALUE ALSO AT I-TIME + ain,ktime xin ;READ IN INPUT ARGUMENTS + ktrig changed ktime ;IF ktime CONTROL IS MOVED GENERATE A MOMENTARY '1' IMPULSE + if ktrig=1 then ;IF A TRIGGER HAS BEEN GENERATED IN THE LINE ABOVE... + reinit UPDATE ;...BEGIN A REINITILISATION PASS FROM LABEL 'UPDATE' + endif ;END OF CONDITIONAL BRANCH + UPDATE: ;LABEL CALLED 'UPDATE' + itime = i(ktime) ;CREATE AN I-TIME VERSION OF ktime + aptr phasor 2/itime ;CREATE A MOVING PHASOR THAT WITH BE USED TO TAP THE DELAY BUFFER + aptr = aptr*itime ;SCALE PHASOR ACCORDING TO THE LENGTH OF THE DELAY TIME CHOSEN BY THE USER + ienv ftgentmp 0,0,1024,7,0,(1024*0.01),1,(1024*0.98),1,(0.01*1024),0 ;ANTI-CLICK ENVELOPE SHAPE + aenv poscil 1, 2/itime, ienv ;CREATE A CYCLING AMPLITUDE ENVELOPE THAT WILL SYNC TO THE TAP DELAY TIME PHASOR + abuffer delayr itime ;CREATE A DELAY BUFFER + atap deltap3 aptr ;READ AUDIO FROM A TAP WITHIN THE DELAY BUFFER + delayw ain ;WRITE AUDIO INTO DELAY BUFFER + rireturn ;RETURN FROM REINITIALISATION PASS + xout atap*aenv ;SEND AUDIO BACK TO CALLER INSTRUMENT. APPLY AMPLITUDE ENVELOPE TO PREVENT CLICKS. +endop diff --git a/data/opcodes/MultiFX/RingModulator.udo b/data/opcodes/MultiFX/RingModulator.udo new file mode 100644 --- /dev/null +++ b/data/opcodes/MultiFX/RingModulator.udo @@ -0,0 +1,32 @@ +; RingModulator +; ---------------- +; An ring modulating effect with an envelope follower +; +; aout RingModulator ain,kmix,kfreq,kenv +; +; Performance +; ----------- +; ain -- input audio to be pitch shifted +; kmix -- dry / wet mix of the output signal (range 0 to 1) +; kfreq -- frequency of thew ring modulator *NOT IN HERTZ* (range 0 to 1) +; kenv -- amount of dynamic envelope following modulation of frequency (range 0 to 1) + +opcode RingModulator,a,aKKK + ain,kmix,kfreq,kenv xin ;READ IN INPUT ARGUMENTS + kfreq expcurve kfreq,4 ;CREATE AN EXPONENTIAL REMAPPING OF kfreq + kfreq scale kfreq,5000,10 ;RESCALE 0 - 1 VALUE TO 10 - 5000 + iWet ftgentmp 0,0,1024,-7,0,512,1,512,1 ;RESCALING FUNCTION FOR WET LEVEL CONTROL + iDry ftgentmp 0,0,1024,-7,1,512,1,512,0 ;RESCALING FUNCTION FOR DRY LEVEL CONTROL + isine ftgentmp 0,0,4096,10,1 ;SINE WAVE + kWet table kmix, iWet, 1 ;RESCALE WET LEVEL CONTROL ACCORDING TO FUNCTION TABLE iWet + kDry table kmix, iDry, 1 ;RESCALE DRY LEVEL CONTROL ACCORDING TO FUNCTION TABLE iDry + kporttime linseg 0,0.001,0.02 ;PORTAMENTO VARIABLE + kModFrq portk kfreq, kporttime ;SMOOTH VARIABLE CHANGES + aFollow follow2 ain, 0.01, 0.1 ;AMPLITUDE FOLLOWING AUDIO SIGNAL + kFollow downsamp aFollow + kFollow logcurve kFollow/0dbfs,20 + kModFrq = kModFrq + (cpsoct(kFollow*kenv*30)) ;CREATE A LEFT CHANNEL MODULATING FREQUENCY BASE ON THE STATIC VALUE CREATED BY kfreq AND THE AMOUNT OF DYNAMIC ENVELOPE FOLLOWING GOVERNED BY kenv + aMod poscil 1, kModFrq, isine ;CREATE RING MODULATING SIGNAL + aout sum ain*kDry, ain*aMod*kWet ;MIX DRY AND WET SIGNALS + xout aout ;SEND AUDIO BACK TO CALLER INSTRUMENT +endop diff --git a/data/opcodes/MultiFX/StChorus.udo b/data/opcodes/MultiFX/StChorus.udo new file mode 100644 --- /dev/null +++ b/data/opcodes/MultiFX/StChorus.udo @@ -0,0 +1,33 @@ +; StChorus +; ---------------- +; A stereo chorus effect +; +; aout StChorus ainL,ainR,krate,kdepth,kwidth +; +; Performance +; ----------- +; ainL -- first/left input audio +; ainR -- second/right input audio +; krate -- rate control of the lfo of the effect *NOT IN HERTZ* (range 0 to 1) +; kdepth -- depth of the lfo of the effect (range 0 to 1) +; kwidth -- width of stereo widening (range 0 to 1) + + +opcode StChorus,aa,aaKKK + ainL,ainR,krate,kdepth,kwidth xin ;READ IN INPUT ARGUMENTS + krate expcurve krate,20 ;CREATE AN EXPONENTIAL REMAPPING OF krate + krate scale krate,7,0.001 ;RESCALE VALUE + ilfoshape ftgentmp 0, 0, 131072, 19, 1, 0.5, 0, 0.5 ;POSITIVE DOMAIN ONLY SINE WAVE + kporttime linseg 0,0.001,0.02 ;RAMPING UP PORTAMENTO VARIABLE + kChoDepth portk kdepth*0.01, kporttime ;SMOOTH VARIABLE CHANGES WITH PORTK + aChoDepth interp kChoDepth ;INTERPOLATE TO CREATE A-RATE VERSION OF K-RATE VARIABLE + amodL osciliktp krate, ilfoshape, 0 ;LEFT CHANNEL LFO + amodR osciliktp krate, ilfoshape, kwidth*0.5 ;THE PHASE OF THE RIGHT CHANNEL LFO IS ADJUSTABLE + amodL = (amodL*aChoDepth)+.01 ;RESCALE AND OFFSET LFO (LEFT CHANNEL) + amodR = (amodR*aChoDepth)+.01 ;RESCALE AND OFFSET LFO (RIGHT CHANNEL) + aChoL vdelay ainL, amodL*1000, 1.2*1000 ;CREATE VARYING DELAYED / CHORUSED SIGNAL (LEFT CHANNEL) + aChoR vdelay ainR, amodR*1000, 1.2*1000 ;CREATE VARYING DELAYED / CHORUSED SIGNAL (RIGHT CHANNEL) + aoutL sum aChoL*0.6, ainL*0.6 ;MIX DRY AND WET SIGNAL (LEFT CHANNEL) + aoutR sum aChoR*0.6, ainR*0.6 ;MIX DRY AND WET SIGNAL (RIGHT CHANNEL) + xout aoutL,aoutR ;SEND AUDIO BACK TO CALLER INSTRUMENT +endop diff --git a/data/opcodes/MultiFX/StereoPingPongDelay.udo b/data/opcodes/MultiFX/StereoPingPongDelay.udo new file mode 100644 --- /dev/null +++ b/data/opcodes/MultiFX/StereoPingPongDelay.udo @@ -0,0 +1,30 @@ +opcode StereoPingPongDelay, aa, aaKKKKKi + aInL, aInR, kdelayTime, kFeedback, kMix, kWidth, kDamp, iMaxDelayTime xin + + iporttime = .1 ;PORTAMENTO TIME + kporttime linseg 0, .001, iporttime ;USE OF AN ENVELOPE VALUE THAT QUICKLY RAMPS UP FROM ZERO TO THE REQUIRED VALUE. THIS PREVENTS VARIABLES GLIDING TO THEIR REQUIRED VALUES EACH TIME THE INSTRUMENT IS STARTED + kdlt portk kdelayTime, kporttime ;PORTAMENTO IS APPLIED TO THE VARIABLE 'gkdlt'. A NEW VARIABLE 'kdlt' IS CREATED. + adlt interp kdlt ;A NEW A-RATE VARIABLE 'adlt' IS CREATED BY INTERPOLATING THE K-RATE VARIABLE 'kdlt' + + ;;;LEFT CHANNEL OFFSET;;;NO FEEDBACK!!;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + abufferL_OS delayr iMaxDelayTime ;CREATE A DELAY BUFFER OF imaxdelay SECONDS DURATION + adelsigL_OS deltap3 adlt ;TAP THE DELAY LINE AT adlt SECONDS + adelsigL_OS tone adelsigL_OS, kDamp + delayw aInL ;WRITE AUDIO SOURCE INTO THE BEGINNING OF THE BUFFER + + ;;;LEFT CHANNEL DELAY;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + abufferL delayr iMaxDelayTime*2 ;CREATE A DELAY BUFFER OF 5 SECONDS DURATION (EQUIVALENT TO THE MAXIMUM DELAY TIME POSSIBLE USING THIS EXAMPLE) + adelsigL deltap3 adlt*2 ;TAP THE DELAY LINE AT gkdlt SECONDS + adelsigL tone adelsigL, kDamp + delayw adelsigL_OS + (adelsigL * kFeedback) ;WRITE AUDIO SOURCE FROM OFFSETTTING DELAY AND FEEDBACK SIGNAL INTO THE BEGINNING OF THE BUFFER + + abufferR delayr iMaxDelayTime*2 ;CREATE A DELAY BUFFER OF 5 SECONDS DURATION (EQUIVALENT TO THE MAXIMUM DELAY TIME POSSIBLE USING THIS EXAMPLE) + adelsigR deltap3 adlt*2 ;TAP THE DELAY LINE AT gkdlt SECONDS + adelsigR tone adelsigR, kDamp + delayw aInR+(adelsigR*kFeedback) ;WRITE AUDIO SOURCE AND FEEDBACK SIGNAL INTO THE BEGINNING OF THE BUFFER + + ;CREATE LEFT AND RIGHT CHANNEL MIXES + aOutL sum (adelsigL + adelsigL_OS)* kMix, aInL * (1-kMix), (1 - kWidth) * adelsigR + aOutR sum adelsigR * kMix, aInR * (1-kMix), (1 - kWidth) * adelsigL + xout aOutL, aOutR ;CREATE A MIX BETWEEN THE WET AND THE DRY SIGNALS AT THE OUTPUT +endop diff --git a/data/opcodes/PitchShifterDelay.udo b/data/opcodes/PitchShifterDelay.udo new file mode 100644 --- /dev/null +++ b/data/opcodes/PitchShifterDelay.udo @@ -0,0 +1,49 @@ +; PitchShifterDelay +; ---------------- +; A pitch shifter effect that employs delay lines +; +; aout PitchShifterDelay ain,ktrans,kdlt,kFB1,kFB2,imaxdlt +; +; Initialisation +; -------------- +; imaxdlt -- maximum delay time (kdlt should not exceed this value) +; +; Performance +; ----------- +; ain -- input audio to be pitch shifted +; ktrans -- pitch transposition (in semitones) +; kdlt -- delay time employed by the pitch shifter effect (should be within the range ksmps/sr and imaxdlt) +; kFB1 -- feedback using method 1 (output from delay taps are fed back directly into their own buffers before enveloping and mixing) +; kFB2 -- feedback using method 2 (enveloped and mixed output from both taps is fed back into both buffers) + +opcode PitchShifterDelay,a,aKKKKi + ; setksmps 1 ;UDO ksmps CAN BE SET INDEPENDENTLY OF GLOBAL ksmps + ain,ktrans,kdlt,kFB1,kFB2,imaxdlt xin + ihalfsine ftgen 0, 0, 1025, 9, 0.5, 1, 0 ;HALF SINE WINDOW FUNCTION USED FOR AMPLITUDE ENVELOPING + koctfract = ktrans/12 ;TRANSPOSITION AS FRACTION OF AN OCTAVE + kratio = octave(koctfract) ;RATIO TO PRODUCE PITCH SHIFT + krate = (kratio-1)/kdlt ;SUBTRACT 1/1 SPEED + + aphase1 phasor -krate ;MOVING PHASE 1-0 + aphase2 phasor -krate, .5 ;MOVING PHASE 1-0 - PHASE OFFSET BY 180 DEGREES (.5 RADIANS) + + agate1 tablei aphase1, ihalfsine, 1, 0, 1 ;WINDOW FUNC =HALF SINE + agate2 tablei aphase2, ihalfsine, 1, 0, 1 ;WINDOW FUNC =HALF SINE + + adlt interp kdlt ;CREATE A RATE (INTERPOLATED FROM K-RATE) VERSION OF kdlt + aout init 0 ;INITIALISE OUTPUT AUDIO SIGNAL (NEEDED FOR FEEDBACK SIGNAL (METHOD 2)) + + abuffer delayr imaxdlt ;DECLARE DELAY BUFFER + adelsig1 deltap3 aphase1 * adlt ;VARIABLE TAP + aGatedSig1 = adelsig1 * agate1 + delayw ain + (aGatedSig1*kFB1) + (aout*kFB2) ;WRITE AUDIO TO THE BEGINNING OF THE DELAY BUFFER, MIX IN FEEDBACK SIGNAL - PROPORTION DEFINED BY gkFB + + abuffer delayr imaxdlt ;DECLARE DELAY BUFFER + adelsig2 deltap3 aphase2 * adlt ;VARIABLE TAP + aGatedSig2 = adelsig2 * agate2 + delayw ain + (aGatedSig2*kFB1) + (aout*kFB2) ;WRITE AUDIO TO THE BEGINNING OF THE DELAY BUFFER, MIX IN FEEDBACK SIGNAL - PROPORTION DEFINED BY gkFB + aout = (aGatedSig1 + aGatedSig2) * 0.5 + aout dcblock2 aout ;REMOVE DC OFFSET (DC OFFSET CAN SOMETIMES BE A PROBLEM WHEN BOTH FEEDBACKS ARE COMBINED) + xout aout ;SUM AND RESCALE PITCH SHIFTER OUTPUTS (LEFT CHANNEL) +endop + diff --git a/data/opcodes/Utility/Delay1k.udo b/data/opcodes/Utility/Delay1k.udo new file mode 100644 --- /dev/null +++ b/data/opcodes/Utility/Delay1k.udo @@ -0,0 +1,6 @@ +opcode Delay1k,k,k +kmem init 0 +kin xin +xout kmem +kmem = kin +endop diff --git a/src/Csound/Typed/Control.hs b/src/Csound/Typed/Control.hs --- a/src/Csound/Typed/Control.hs +++ b/src/Csound/Typed/Control.hs @@ -22,7 +22,13 @@ -- * Events module Csound.Typed.Control.Evt, -- * Band-limited oscillators - module Csound.Typed.Control.Vco + module Csound.Typed.Control.Vco, + -- * Imperative instruments + module Csound.Typed.Control.InstrRef, + -- * Array folding and traversals + module Csound.Typed.Control.ArrayTraverse, + -- * Reads global config arguments from command line + module Csound.Typed.Control.MacrosArgs ) where import Csound.Typed.GlobalState.SE @@ -36,6 +42,9 @@ import Csound.Typed.Control.Channel import Csound.Typed.Control.Sf2 import Csound.Typed.Control.Vco +import Csound.Typed.Control.InstrRef +import Csound.Typed.Control.ArrayTraverse +import Csound.Typed.Control.MacrosArgs import Csound.Typed.Types import Csound.Typed.GlobalState @@ -67,7 +76,6 @@ vals <- fromTuple as setDurationForce dt return vals - -- | Gets new id. freshId :: SE D diff --git a/src/Csound/Typed/Control/Api.hs b/src/Csound/Typed/Control/Api.hs --- a/src/Csound/Typed/Control/Api.hs +++ b/src/Csound/Typed/Control/Api.hs @@ -7,6 +7,7 @@ import Data.Boolean import Control.Monad.Trans.Class +import Control.Applicative import qualified Csound.Dynamic as D import Csound.Dynamic(Rate(..), opcs, depT_) @@ -16,6 +17,7 @@ import Csound.Typed.Control.Ref import Csound.Typed.GlobalState import Csound.Typed.GlobalState.Opcodes(eventi, Event(..), turnoff, port, downsamp) +import Csound.Typed.InnerOpcodes import Csound.Typed.Plugins.TabQueue @@ -96,8 +98,8 @@ readRef ref where go ref x = mixRef ref =<< instr x -namedMonoMsg :: D -> D -> String -> SE (Sig, Sig) -namedMonoMsg portTime relTime name = do +namedMonoMsg ::String -> SE MonoArg +namedMonoMsg name = do refPch <- newGlobalRef 0 refVol <- newGlobalRef 0 tab <- newGlobalTab 24 @@ -111,8 +113,11 @@ writeRef refVol 0 pchKey <- readRef refPch volKey <- readRef refVol - let resStatus = ifB onFlag 1 0 - return (port' (downsamp' volKey) portTime * port' resStatus relTime, port' (downsamp' pchKey) portTime) + let kgate = ifB onFlag 1 0 + kamp = downsamp' volKey + kcps = downsamp' pchKey + trig = changed [kamp, kcps] + return $ MonoArg kamp kcps kgate trig where onNote = tabQueue2_append offNote tab (pch, vol) = tabQueue2_delete tab pch diff --git a/src/Csound/Typed/Control/ArrayTraverse.hs b/src/Csound/Typed/Control/ArrayTraverse.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Control/ArrayTraverse.hs @@ -0,0 +1,160 @@ +{-# Language ScopedTypeVariables #-} +-- | Array traversals and folds +module Csound.Typed.Control.ArrayTraverse( + foreachArr, foreachArrD, forRowArr, forColumnArr, forRowArrD, forColumnArrD, + foldArr, foldRowArr, foldColumnArr, foldRowsArrD, foldColumnsArrD +) where + +import Csound.Typed.Types +import Csound.Typed.Control.Ref +import Csound.Typed.GlobalState +import Data.Boolean +import qualified Csound.Dynamic as D + +------------------------------------------------------------------------- +-- Functional style traversals + +whileRefBegin :: SigOrD a => Ref a -> SE () +whileRefBegin (Ref vars) = fromDep_ $ D.whileRef $ head vars + +-- | Traverses all elements of the array array and applies a procedure to each element. +-- The procedure takes in a pair of index and the current value at the given index. +foreachArr :: (Tuple ix, Tuple a) => Arr ix a -> ((ix, a) -> SE ()) -> SE () +foreachArr = foreachArrBy getArrayLength + where + getArrayLength :: Int -> Arr ix a -> Sig + getArrayLength n array = lenarray array `withD` (int n) + +-- | Traverses all elements of the array at the **init rate** and applies a procedure to each element. +-- The procedure takes in a pair of index and the current value at the given index. +foreachArrD :: (Tuple ix, Tuple a) => Arr ix a -> ((ix, a) -> SE ()) -> SE () +foreachArrD = foreachArrBy getArrayLength + where + getArrayLength :: Int -> Arr ix a -> D + getArrayLength n array = lenarray array `withD` (int n) + +foreachArrBy :: forall a b ix . (OrdB b, IfB b, Num b, SigOrD b, Tuple b, Tuple ix, Tuple a) => (Int -> Arr ix a -> b) -> Arr ix a -> ((ix, a) -> SE ()) -> SE () +foreachArrBy getArrayLength array body = do + vars <- mapM newCtrlRef $ replicate arity (0 :: b) + condVars <- mapM newCtrlRef $ replicate arity (1 :: b) + recWhile vars $ zip3 [1 ..] vars condVars + where + recWhile :: [Ref b] -> [(Int, Ref b, Ref b)] -> SE () + recWhile vars xs = case xs of + [] -> do + ix <- readRef $ concatRef vars + val <- readArr array ix + body (ix, val) + (n, var, condVar) : rest -> do + whileRefBegin condVar + + recWhile vars rest + + modifyRef var (+ 1) + ix <- readRef var + writeRef condVar (ifB (ix `lessThan` getArrayLength n array) 1 0) + + fromDep_ D.whileEnd + + arity = tupleArity $ proxy array + + proxy :: Arr ix a -> ix + proxy = const undefined + + concatRef :: [Ref b] -> Ref ix + concatRef vs = Ref $ vs >>= \(Ref xs) -> xs + +-- | Traverses all elements in the given row of 2D array at the signal rate and applies a procedure to all elements. +forRowArr :: (Tuple a) => Sig -> Arr Sig2 a -> ((Sig, a) -> SE ()) -> SE () +forRowArr rowId array phi = whileRef 0 cond body + where + cond ix = return $ ix `lessThan` lenarray array `withD` 2 + + body ix = do + val <- readArr array (rowId, ix) + phi (ix, val) + return $ ix + 1 + + +-- | Traverses all elements in the given column of 2D array at the signal rate and applies a procedure to all elements. +forColumnArr :: (Tuple a) => Sig -> Arr Sig2 a -> ((Sig, a) -> SE ()) -> SE () +forColumnArr colId array phi = whileRef 0 cond body + where + cond ix = return $ ix `lessThan` lenarray array `withD` 1 + + body ix = do + val <- readArr array (ix, colId) + phi (ix, val) + return $ ix + 1 + +-- | Traverses all elements in the given row of 2D array at the init rate and applies a procedure to all elements. +forRowArrD :: Tuple a => D -> Arr D2 a -> ((D, a) -> SE ()) -> SE () +forRowArrD rowId array phi = whileRefD 0 cond body + where + cond ix = return $ ix `lessThan` lenarray array `withD` 2 + + body ix = do + val <- readArr array (rowId, ix) + phi (ix, val) + return $ ix + 1 + +-- | Traverses all elements in the given column of 2D array at the init rate and applies a procedure to all elements. +forColumnArrD :: Tuple a => D -> Arr D2 a -> ((D, a) -> SE ()) -> SE () +forColumnArrD colId array phi = whileRefD 0 cond body + where + cond ix = return $ ix `lessThan` lenarray array `withD` 1 + + body ix = do + val <- readArr array (ix, colId) + phi (ix, val) + return $ ix + 1 + +-- | Traverses an array and accumulates a value. We invoke the function with accumulator function, initial value and the array. +foldArr :: (Tuple ix, Tuple a, Tuple b) => ((ix, a) -> b -> SE b) -> b -> Arr ix a -> SE b +foldArr phi z array = do + res <- newRef z + foreachArr array (toFoldFun phi res) + readRef res + +toFoldFun :: Tuple b => (a -> b -> SE b) -> Ref b -> a -> SE () +toFoldFun phi ref a = writeRef ref =<< phi a =<< readRef ref + +-- | Traverses a row in the array and accumulates a value. We invoke the function +-- with accumulator function, initial value and the array with signal of the row number. +-- +-- > foldRowArr accum initValue rowId array +foldRowArr :: (Tuple a, Tuple b) => ((Sig, a) -> b -> SE b) -> b -> Sig -> Arr Sig2 a -> SE b +foldRowArr phi z rowId array = do + res <- newRef z + forRowArr rowId array $ toFoldFun phi res + readRef res + +-- | Traverses a column in the array and accumulates a value. We invoke the function +-- with accumulator function, initial value and the array with signal of the row number. +-- +-- > foldColumnArr accum initValue columnId array +foldColumnArr :: (Tuple a, Tuple b) => ((Sig, a) -> b -> SE b) -> b -> Sig -> Arr Sig2 a -> SE b +foldColumnArr phi z rowId array = do + res <- newRef z + forColumnArr rowId array $ toFoldFun phi res + readRef res + +-- | Traverses a row at the **init rate** in the array and accumulates a value. We invoke the function +-- with accumulator function, initial value and the array with signal of the row number. +-- +-- > foldRowArr accum initValue rowId array +foldRowsArrD :: (Tuple a, Tuple b) => ((D, a) -> b -> SE b) -> b -> D -> Arr D2 a -> SE b +foldRowsArrD phi z rowId array = do + res <- newRef z + forRowArrD rowId array $ toFoldFun phi res + readRef res + +-- | Traverses a column at the **init rate** in the array and accumulates a value. We invoke the function +-- with accumulator function, initial value and the array with signal of the row number. +-- +-- > foldColumnArr accum initValue columnId array +foldColumnsArrD :: (Tuple a, Tuple b) => ((D, a) -> b -> SE b) -> b -> D -> Arr D2 a -> SE b +foldColumnsArrD phi z rowId array = do + res <- newRef z + forColumnArrD rowId array $ toFoldFun phi res + readRef res diff --git a/src/Csound/Typed/Control/Evt.hs b/src/Csound/Typed/Control/Evt.hs --- a/src/Csound/Typed/Control/Evt.hs +++ b/src/Csound/Typed/Control/Evt.hs @@ -1,11 +1,13 @@ {-# Language FlexibleContexts #-} module Csound.Typed.Control.Evt( sched, sched_, schedBy, schedHarp, schedHarpBy, - retrigs, evtLoop, evtLoopOnce + monoSched, monoSchedUntil, monoSchedHarp, + retrigs, evtLoop, evtLoopOnce ) where import System.Mem.StableName +import Data.Monoid import Data.Boolean import Control.Applicative @@ -22,9 +24,12 @@ import Csound.Typed.GlobalState.Opcodes(primInstrId) import Csound.Typed.Control.Instr import Csound.Typed.Control.Mix(Sco) +import qualified Csound.Typed.GlobalState.InstrApi as I +import qualified Csound.Typed.GlobalState.Port as I import Csound.Typed.Control.Ref import Csound.Typed.Constants(infiniteDur) +import Csound.Typed.InnerOpcodes renderEvts :: Evt (Sco a) -> Evt [(D, D, a)] renderEvts = fmap (fmap unEvt . T.render) @@ -33,8 +38,7 @@ sched :: (Arg a, Sigs b) => (a -> SE b) -> Evt (Sco a) -> b sched instr evts = apInstr0 $ do instrId <- saveSourceInstrCachedWithLivenessWatch (funArity instr) (insExp instr) - saveEvtInstr (arityOuts $ funArity instr) instrId (renderEvts evts) - where unEvt e = (T.eventStart e, T.eventDur e, T.eventContent e) + saveEvtInstr (arityOuts $ funArity instr) instrId (renderEvts evts) -- | Triggers a procedure on the event stream. sched_ :: (Arg a) => (a -> SE ()) -> Evt (Sco a) -> SE () @@ -267,4 +271,55 @@ samLoop :: (Sigs a) => Evt Unit -> a -> a samLoop = undefined + +------------------------------------------------------------- +-- monophonic scheduling + +-- | Turns +monoSched :: Evt (Sco (D, D)) -> SE MonoArg +monoSched evts = evtPort instr evts read + where + instr ((amp, cps), p) = do + (_, _, gate) <- I.readPort p + I.writePort p (sig amp, sig cps, gate + 1) + + read :: I.Port (Sig, Sig, Sig) -> SE MonoArg + read p = do + (amp, cps, gate) <- I.readPort p + I.writePort p (amp, cps, 0) + return $ MonoArg amp cps (ifB (gate `equalsTo` 0) 0 1) (changed [amp, cps, gate]) + +runSco :: Arg a => Evt (Sco a) -> ((D,D,a) -> SE ()) -> SE () +runSco evts f = runEvt (renderEvts evts) $ mapM_ f + +-- | Plays the note until next note comes or something happens on the second event stream. +monoSchedUntil :: Evt (D, D) -> Evt a -> SE MonoArg +monoSchedUntil evts stop = do + ref <- newRef (MonoArg 0 0 0 0) + clearTrig ref + runEvt (fmap Left evts <> fmap Right stop) (go ref) + readRef ref + where + go ref = either (ons ref) (const $ offs ref) + + ons ref (amp, cps) = + writeRef ref $ MonoArg { monoAmp = sig amp, monoCps = sig cps, monoGate = 1, monoTrig = 1 } + + offs ref = modifyRef ref $ \arg -> arg { monoGate = 0 } + + clearTrig ref = modifyRef ref $ \arg -> arg { monoTrig = 0 } + +-- | Plays the note until next note comes +monoSchedHarp :: Evt (D, D) -> SE MonoArg +monoSchedHarp evts = monoSchedUntil evts mempty + + +evtPort :: (Arg a, Sigs p) => ((a, I.Port p) -> SE ()) -> Evt (Sco a) -> (I.Port p -> SE b) -> SE b +evtPort instr evts read = do + port <- I.freePort + idx <- I.newInstrLinked instr + runSco evts $ go idx port + read port + where + go idx port (start,dur,a) = I.event idx (start, dur, (a, port)) diff --git a/src/Csound/Typed/Control/Instr.hs b/src/Csound/Typed/Control/Instr.hs --- a/src/Csound/Typed/Control/Instr.hs +++ b/src/Csound/Typed/Control/Instr.hs @@ -4,13 +4,15 @@ funArity, constArity, insExp, effExp, masterExp, midiExp, unitExp, apInstr, apInstr0 -) where +) where -import Csound.Dynamic(InstrId) +import Data.Default +import Csound.Dynamic(InstrId(..)) import qualified Csound.Typed.GlobalState.Elements as C import Csound.Typed.Types import Csound.Typed.GlobalState +import Csound.Typed.GlobalState.Opcodes(primInstrId) funProxy :: (a -> f b) -> (a, b) funProxy = const (msg, msg) @@ -48,4 +50,3 @@ apInstr0 :: (Sigs b) => GE InstrId -> b apInstr0 instrId = apInstr instrId unit - diff --git a/src/Csound/Typed/Control/InstrRef.hs b/src/Csound/Typed/Control/InstrRef.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Control/InstrRef.hs @@ -0,0 +1,97 @@ +-- | Imperative csound instruments +module Csound.Typed.Control.InstrRef( + InstrRef, newInstr, scheduleEvent, turnoff2, negateInstrRef, addFracInstrRef, + newOutInstr, noteOn, noteOff +) where + +import Control.Monad +import Control.Monad.Trans.Class + +import Control.Applicative +import Data.Default +import Csound.Dynamic(InstrId(..), Rate(..), DepT, depT_, opcs) +import qualified Csound.Typed.GlobalState.Elements as C + +import Csound.Typed.Types +import Csound.Typed.GlobalState hiding (turnoff2) +import Csound.Typed.Control.Ref + +-- | Fractional part of the instrument dentifier. +data InstrFrac = InstrFrac + { instrFracValue :: D + , instrFracSize :: D + } + +-- | Instrument reference. we can invoke or stop the instrument by the identifier. +data InstrRef a = InstrRef + { instrRefMain :: D + , instrRefFrac :: Maybe InstrFrac } + +-- | Creates a new instrument and generates a unique identifier. +newInstr :: (Arg a) => (a -> SE ()) -> SE (InstrRef a) +newInstr instr = geToSe $ fmap fromInstrId $ saveInstr $ instr toArg + +-- | Schedules an event for the instrument. +-- +-- > scheduleEvent instrRef delay duration args +-- +-- The arguments for time values are set in seconds. +scheduleEvent :: (Arg a) => InstrRef a -> D -> D -> a -> SE () +scheduleEvent instrRef start end args = SE $ hideGEinDep $ fmap C.event $ C.Event <$> toGE (getInstrId instrRef) <*> toGE start <*> toGE end <*> toNote args + +getInstrId :: InstrRef a -> D +getInstrId (InstrRef value frac) = value + maybe 0 fromFrac frac + where + fromFrac (InstrFrac value size) = (value * 10 + 1) / (size * 10) + +-- | Negates the instrument identifier. This trick is used in Csound to update the instrument arguments while instrument is working. +negateInstrRef :: InstrRef a -> InstrRef a +negateInstrRef ref = ref { instrRefMain = negate $ instrRefMain ref } + +-- | Adds fractional part to the instrument reference. This trick is used in Csound to identify the notes (or specific instrument invokation). +addFracInstrRef :: D -> D -> InstrRef a -> InstrRef a +addFracInstrRef maxSize value instrRef = instrRef { instrRefFrac = Just (InstrFrac value maxSize) } + +fromInstrId :: InstrId -> InstrRef a +fromInstrId x = case x of + InstrId frac ceil -> InstrRef (int ceil) Nothing + InstrLabel _ -> error "No reference for string instrument id. (Csound.Typed.Control.Instr.hs: fromInstrId)" + +-- | Creates an insturment that produces a value. +newOutInstr :: (Arg a, Sigs b) => (a -> SE b) -> SE (InstrRef a, b) +newOutInstr f = do + ref <- newClearableGlobalRef 0 + instrId <- newInstr $ \a -> mixRef ref =<< f a + aout <- readRef ref + return (instrId, aout) + +-- | Triggers a note with fractional instrument reference. We can later stop the instrument on specific note with function @noteOff@. +noteOn :: (Arg a) => D -> D -> InstrRef a -> a -> SE () +noteOn maxSize noteId instrId args = scheduleEvent (addFracInstrRef maxSize noteId instrId) 0 (-1) args + +-- | Stops a note with fractional instrument reference. +noteOff :: (Default a, Arg a) => D -> D -> InstrRef a -> SE () +noteOff maxSize noteId instrId = scheduleEvent (negateInstrRef $ addFracInstrRef maxSize noteId instrId) 0 0.01 def + +-- | Turns off the note played on the given instrument. +-- Use fractional instrument reference to turn off specific instance. +-- +-- > turnoff2 instrRef mode releaseTime +-- +-- The mode is sum of the following values: +-- +-- * 0, 1, or 2: turn off all instances (0), oldest only (1), or newest only (2) +-- +-- * 4: only turn off notes with exactly matching (fractional) instrument number, rather than ignoring fractional part +-- +-- * 8: only turn off notes with indefinite duration (idur < 0 or MIDI) +-- +-- @releaseTime@ if non-zero, the turned off instances are allowed to release, otherwise are deactivated immediately (possibly resulting in clicks). +turnoff2 :: InstrRef a -> Sig -> Sig -> SE () +turnoff2 instrRef kmode krelease = go (sig $ getInstrId instrRef) kmode krelease + where + go :: Sig -> Sig -> Sig -> SE () + go instr mode release = SE $ join $ lift $ csdTurnoff2 <$> (toGE instr) <*> (toGE mode) <*> (toGE release) + + csdTurnoff2 :: Monad m => E -> E -> E -> DepT m () + csdTurnoff2 instrId mode release = depT_ $ opcs "turnoff2" [(Xr, [Kr, Kr, Kr])] [instrId, mode, release] diff --git a/src/Csound/Typed/Control/MacrosArgs.hs b/src/Csound/Typed/Control/MacrosArgs.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Control/MacrosArgs.hs @@ -0,0 +1,18 @@ +-- | Defines functions to read global arguments from the command line as macros with D flag. +module Csound.Typed.Control.MacrosArgs( + readMacrosString, readMacrosDouble, readMacrosInt +) where + +import qualified Csound.Dynamic as D + +import Csound.Typed.Types +import qualified Csound.Typed.GlobalState as G(readMacrosString, readMacrosDouble, readMacrosInt) + +readMacrosString :: String -> String -> Str +readMacrosString name value = fromGE $ G.readMacrosString name value + +readMacrosDouble :: String -> Double -> D +readMacrosDouble name value = fromGE $ G.readMacrosDouble name value + +readMacrosInt :: String -> Int -> D +readMacrosInt name value = fromGE $ G.readMacrosInt name value diff --git a/src/Csound/Typed/Control/Mix.hs b/src/Csound/Typed/Control/Mix.hs --- a/src/Csound/Typed/Control/Mix.hs +++ b/src/Csound/Typed/Control/Mix.hs @@ -1,13 +1,17 @@ -{-# Language FlexibleContexts #-} +{-# Language FlexibleContexts, ScopedTypeVariables #-} module Csound.Typed.Control.Mix( Mix, - sco, eff, mix, mixBy, + sco, eff, mix, mixBy, monoSco, sco_, mix_, mixBy_, Sco, CsdEventList(..), CsdEvent ) where +import Data.Boolean + import Control.Applicative import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad import Data.Traversable import System.Mem.StableName @@ -20,6 +24,7 @@ import Csound.Typed.Types.MixSco import Csound.Typed.GlobalState hiding (notes) import Csound.Typed.Control.Instr +import Csound.Typed.InnerOpcodes toCsdEventList :: Sco a -> CsdEventList a toCsdEventList = id @@ -75,6 +80,25 @@ instrId <- saveEffectInstr (funArity ef) (effExp ef) return $ Eff instrId notes (arityIns $ funArity ef) +-- | Plays a bunch of notes with the given monophonic instrument. See details on type @MonoArg@. +-- The scores contain the pairs of amplitude (0 to 1) and frequency (in Hz). +-- +-- > res = monoSco instrument scores +monoSco :: forall a . Sigs a => (MonoArg -> SE a) -> Sco (D, D) -> Sco (Mix a) +monoSco instr notes = wrapSco notes $ \events -> do + events' <- traverse toNote events + argId <- saveSourceInstrCached_ (unitExp $ fmap (const unit) $ instrMonoArg toArg) + instrId <- saveEffectInstr ((funArity instr) { arityIns = 3 }) (effExp effInstr) + return $ MonoSnd instrId argId events' + where + instrMonoArg :: ((D, D), Port Sig3) -> SE () + instrMonoArg ((amp, cps), port) = + modifyPort port $ \(_, _, notnum) -> (sig amp, sig cps, notnum + 1) + + effInstr :: Sigs a => (Sig, Sig, Sig) -> SE a + effInstr (amp, cps, notnum) = instr (MonoArg amp cps gate (changed [amp, cps, gate])) + where gate = ifB (notnum ==* 0) 0 1 + -- | Renders a scores to the sound signals. we can use it inside the other instruments. mix :: (Sigs a) => Sco (Mix a) -> a mix a = flip apInstr unit $ do diff --git a/src/Csound/Typed/Control/Osc.hs b/src/Csound/Typed/Control/Osc.hs --- a/src/Csound/Typed/Control/Osc.hs +++ b/src/Csound/Typed/Control/Osc.hs @@ -2,10 +2,12 @@ {-# Language ScopedTypeVariables #-} module Csound.Typed.Control.Osc( OscRef, OscHost, OscPort, OscAddress, OscType, - initOsc, listenOsc, sendOsc + initOsc, listenOsc, sendOsc, + OscVal, listenOscVal ) where import Data.Boolean ((==*)) +import Csound.Dynamic(Rate(..)) import Csound.Typed.Types import Csound.Typed.GlobalState hiding (oscInit, oscListen, oscSend) @@ -33,16 +35,11 @@ type OscHost = String -- | Initializes host client. The process starts to run in the background. -initOsc :: OscPort -> SE OscRef -initOsc port = do - oscRef <- fmap fromGE $ fromDep $ C.oscInit (fromIntegral port) - varRef <- newGlobalRef (0 :: D) - writeRef varRef oscRef - ihandle <- readRef varRef - return $ OscRef ihandle +initOsc :: OscPort -> OscRef +initOsc port = OscRef $ fromGE $ getOscPortHandle port -- | Listens for the OSC-messages. The first argument is OSC-reference. --- We can create it with the function @oscInit@. The next two arguments are strings. +-- We can create it with the function @initOsc@. The next two arguments are strings. -- The former specifies the path-like address to listen the messages. It can be: -- -- > /foo/bar/baz @@ -57,29 +54,33 @@ -- -- > runEvt :: Evt a -> (a -> SE ()) -> SE () listenOsc :: forall a . Tuple a => OscRef -> OscAddress -> OscType -> Evt a -listenOsc oscRef oscAddr oscType = Evt $ \bam -> do - (readCond, writeCond) <- sensorsSE (0 :: Sig) - resRef <- newRef (defTuple :: a) - writeCond =<< listen resRef - readCond >>= (\cond -> whileDo (cond ==* 1) $ do - bam =<< readRef resRef - writeCond =<< listen resRef) +listenOsc oscRef oscAddr oscType = Evt $ \bam -> do + resRef <- initOscRef oscType + cond <- listen resRef + when1 cond $ bam =<< readRef resRef where - listen :: Tuple a => Ref a -> SE Sig - listen ref = csdOscListen ref oscRef oscAddr oscType + listen :: Tuple a => Ref a -> SE BoolSig + listen ref = fmap (==* 1) $ csdOscListen ref oscRef oscAddr oscType csdOscListen :: Tuple a => Ref a -> OscRef -> OscAddress -> OscType -> SE Sig - csdOscListen resRef oscHandle addr ty = do - args <- readRef resRef - res <- fmap fromGE $ fromDep $ hideGEinDep $ do - expArgs <- fromTuple args + csdOscListen (Ref refVars) oscHandle addr ty = + fmap fromGE $ fromDep $ hideGEinDep $ do expOscHandle <- toGE $ unOscRef oscHandle expAddr <- toGE $ text addr expOscType <- toGE $ text ty - return $ C.oscListen $ expOscHandle : expAddr : expOscType : expArgs - writeRef resRef args - return res + return $ C.oscListen expOscHandle expAddr expOscType refVars + initOscRef :: OscType -> SE (Ref a) + initOscRef typeStr = fmap Ref $ newLocalVars (fmap getOscRate typeStr) (fromTuple $ (defTuple :: a)) + + getOscRate :: Char -> Rate + getOscRate x = case x of + 'a' -> Ar + 's' -> Sr + 'i' -> Kr + 'f' -> Kr + _ -> Kr + -- | Sends OSC-messages. It takes in a name of the host computer -- (empty string is alocal machine), port on which the target -- machine is listening, OSC-addres and type. The last argument @@ -96,3 +97,58 @@ expTy <- toGE $ text $ ty return $ C.oscSend $ 1 : expHost : expPort : expAddr : expTy : args + +class Tuple a => OscVal a where + getOscTypes :: a -> String + getOscRef :: a -> SE (Ref a) + +instance OscVal Sig where + getOscTypes = const "f" + getOscRef = newCtrlRef + +instance OscVal Str where + getOscTypes = const "s" + getOscRef = newRef + +instance (OscVal a, OscVal b) => OscVal (a, b) where + getOscTypes (a, b) = getOscTypes a ++ getOscTypes b + getOscRef (a, b) = do + refA <- getOscRef a + refB <- getOscRef b + return $ concatRef refA refB + +instance (OscVal a, OscVal b, OscVal c) => OscVal (a, b, c) where + getOscTypes (a, b, c) = getOscTypes a ++ getOscTypes b ++ getOscTypes c + getOscRef (a, b, c) = do + refA <- getOscRef a + refB <- getOscRef b + refC <- getOscRef c + return $ concatRef3 refA refB refC + +instance (OscVal a, OscVal b, OscVal c, OscVal d) => OscVal (a, b, c, d) where + getOscTypes (a, b, c, d) = getOscTypes a ++ getOscTypes b ++ getOscTypes c ++ getOscTypes d + getOscRef (a, b, c, d) = do + refA <- getOscRef a + refB <- getOscRef b + refC <- getOscRef c + refD <- getOscRef d + return $ concatRef4 refA refB refC refD + +instance (OscVal a, OscVal b, OscVal c, OscVal d, OscVal e) => OscVal (a, b, c, d, e) where + getOscTypes (a, b, c, d, e) = getOscTypes a ++ getOscTypes b ++ getOscTypes c ++ getOscTypes d ++ getOscTypes e + getOscRef (a, b, c, d, e) = do + refA <- getOscRef a + refB <- getOscRef b + refC <- getOscRef c + refD <- getOscRef d + refE <- getOscRef e + return $ concatRef5 refA refB refC refD refE + +-- | Listens for tuples of continuous signals read from OSC-channel. +-- +-- > listenOscVal ref address initValue +listenOscVal :: (Tuple a, OscVal a) => OscRef -> String -> a -> SE a +listenOscVal port path initVal = do + ref <- getOscRef initVal + runEvt (listenOsc port path (getOscTypes initVal)) $ \a -> writeRef ref a + readRef ref diff --git a/src/Csound/Typed/Control/Ref.hs b/src/Csound/Typed/Control/Ref.hs --- a/src/Csound/Typed/Control/Ref.hs +++ b/src/Csound/Typed/Control/Ref.hs @@ -1,20 +1,28 @@ +{-# Language ScopedTypeVariables, FlexibleContexts #-} module Csound.Typed.Control.Ref( - Ref, writeRef, readRef, newRef, mixRef, modifyRef, sensorsSE, newGlobalRef, + Ref(..), writeRef, readRef, newRef, mixRef, modifyRef, sensorsSE, newGlobalRef, + concatRef, concatRef3, concatRef4, concatRef5, newCtrlRef, newGlobalCtrlRef, - globalSensorsSE, newClearableGlobalRef, newTab, newGlobalTab + globalSensorsSE, newClearableGlobalRef, newTab, newGlobalTab, + -- conditionals + whileRef, whileRefD ) where +import Data.Boolean import Control.DeepSeq(deepseq) import Control.Monad +import Control.Applicative import Control.Monad.Trans.Class -import Csound.Dynamic hiding (newLocalVars) +import Csound.Dynamic hiding (when1, newLocalVars, writeArr, readArr, whileRef) import Csound.Typed.Types.Prim import Csound.Typed.Types.Tuple import Csound.Typed.GlobalState.SE import Csound.Typed.GlobalState.GE +import qualified Csound.Dynamic as D + -- | It describes a reference to mutable values. newtype Ref a = Ref [Var] {- @@ -44,13 +52,25 @@ -- It contains control signals (k-rate) and constants for numbers (i-rates). newCtrlRef :: Tuple a => a -> SE (Ref a) newCtrlRef t = fmap Ref $ newLocalVars (fmap toCtrlRate $ tupleRates t) (fromTuple t) - where toCtrlRate x = case x of Ar -> Kr Kr -> Ir _ -> x +concatRef :: (Tuple a, Tuple b) => Ref a -> Ref b -> Ref (a, b) +concatRef (Ref a) (Ref b) = Ref (a ++ b) + +concatRef3 :: (Tuple a, Tuple b, Tuple c) => Ref a -> Ref b -> Ref c -> Ref (a, b, c) +concatRef3 (Ref a) (Ref b) (Ref c) = Ref (a ++ b ++ c) + +concatRef4 :: (Tuple a, Tuple b, Tuple c, Tuple d) => Ref a -> Ref b -> Ref c -> Ref d -> Ref (a, b, c, d) +concatRef4 (Ref a) (Ref b) (Ref c) (Ref d) = Ref (a ++ b ++ c ++ d) + +concatRef5 :: (Tuple a, Tuple b, Tuple c, Tuple d, Tuple e) => Ref a -> Ref b -> Ref c -> Ref d -> Ref e -> Ref (a, b, c, d, e) +concatRef5 (Ref a) (Ref b) (Ref c) (Ref d) (Ref e) = Ref (a ++ b ++ c ++ d ++ e) + + -- | Adds the given signal to the value that is contained in the -- reference. mixRef :: (Num a, Tuple a) => Ref a -> a -> SE () @@ -150,3 +170,57 @@ ftgentmp :: D -> D -> D -> D -> D -> [D] -> SE Tab ftgentmp b1 b2 b3 b4 b5 b6 = fmap ( Tab . return) $ SE $ (depT =<<) $ lift $ f <$> unD b1 <*> unD b2 <*> unD b3 <*> unD b4 <*> unD b5 <*> mapM unD b6 where f a1 a2 a3 a4 a5 a6 = opcs "ftgentmp" [(Ir,(repeat Ir))] ([a1,a2,a3,a4,a5] ++ a6) + +------------------------------------------------ + +{- +whileSE :: SE BoolSig -> SE () -> SE () +whileSE mcond body = do + ref <- newCtrlRef $ (0 :: Sig) + writeCond ref + whileRefBegin ref + body + writeCond ref + whileRefEnd + where + writeCond :: Ref Sig -> SE () + writeCond ref = writeRef ref =<< fmap (\x -> ifB x 1 0) mcond + +-- ifBegin :: BoolSig -> SE () +-- ifBegin a = fromDep_ $ D.ifBegin Kr =<< lift (toGE a) + +whileRefBegin :: Ref Sig -> SE () +whileRefBegin (Ref [var]) = fromDep_ $ D.whileBegin ((D.prim $ D.PrimVar D.Kr var) ==* 1) + +whileRefEnd :: SE () +whileRefEnd = fromDep_ D.whileEnd +-} +-------------------------------------------------------------------- + +whileRef :: forall st . Tuple st => st -> (st -> SE BoolSig) -> (st -> SE st) -> SE () +whileRef initVal cond body = do + refSt <- newCtrlRef initVal + refCond <- newRef =<< condSig =<< readRef refSt + whileRefBegin refCond + writeRef refSt =<< body =<< readRef refSt + writeRef refCond =<< condSig =<< readRef refSt + fromDep_ whileEnd + where + condSig :: st -> SE Sig + condSig = fmap (\b -> ifB b 1 0) . cond + + +whileRefD :: forall st . Tuple st => st -> (st -> SE BoolD) -> (st -> SE st) -> SE () +whileRefD initVal cond body = do + refSt <- newCtrlRef initVal + refCond <- newRef =<< condSig =<< readRef refSt + whileRefBegin refCond + writeRef refSt =<< body =<< readRef refSt + writeRef refCond =<< condSig =<< readRef refSt + fromDep_ whileEnd + where + condSig :: st -> SE D + condSig = fmap (\b -> ifB b 1 0) . cond + +whileRefBegin :: SigOrD a => Ref a -> SE () +whileRefBegin (Ref vars) = fromDep_ $ D.whileRef $ head vars diff --git a/src/Csound/Typed/GlobalState.hs b/src/Csound/Typed/GlobalState.hs --- a/src/Csound/Typed/GlobalState.hs +++ b/src/Csound/Typed/GlobalState.hs @@ -4,6 +4,7 @@ module Csound.Typed.GlobalState.SE, module Csound.Typed.GlobalState.Instr, module Csound.Typed.GlobalState.Cache, + module Csound.Typed.GlobalState.Port, -- * Reexports dynamic BandLimited(..), readBandLimited, readHardSyncBandLimited, renderBandLimited, Instrs(..), IdMap(..), getInstrIds, @@ -31,3 +32,4 @@ import Csound.Typed.GlobalState.Cache import Csound.Typed.GlobalState.Elements import Csound.Typed.GlobalState.Opcodes +import Csound.Typed.GlobalState.Port diff --git a/src/Csound/Typed/GlobalState/Elements.hs b/src/Csound/Typed/GlobalState/Elements.hs --- a/src/Csound/Typed/GlobalState/Elements.hs +++ b/src/Csound/Typed/GlobalState/Elements.hs @@ -17,7 +17,8 @@ -- * Midi MidiType(..), Channel, MidiMap, MidiKey(..), saveMidiInstr, -- * Global variables - Globals(..), newPersistentGlobalVar, newClearableGlobalVar, + Globals(..), newPersistentGlobalVar, newClearableGlobalVar, + newPersistentGloabalArrVar, renderGlobals, -- * Instruments Instrs(..), saveInstr, getInstrIds, -- newInstrId, saveInstrById, saveInstr, CacheName, makeCacheName, saveCachedInstr, getInstrIds, @@ -28,11 +29,20 @@ Event(..), ChnRef(..), chnRefFromParg, chnRefAlloc, readChn, writeChn, chnUpdateUdo, subinstr, subinstr_, event_i, event, safeOut, autoOff, changed, + -- * OSC listen ports + OscListenPorts, getOscPortVar, + -- * Macros inits + MacrosInits, MacrosInit(..), initMacros, -- * Udo plugins UdoPlugin, addUdoPlugin, getUdoPluginNames, tabQueuePlugin, tabQueue2Plugin, zdfPlugin, solinaChorusPlugin, audaciouseqPlugin, adsr140Plugin, - diodePlugin, korg35Plugin, zeroDelayConvolutionPlugin + diodePlugin, korg35Plugin, zeroDelayConvolutionPlugin, + pitchShifterDelayPlugin, + analogDelayPlugin, distortionPlugin, envelopeFolollowerPlugin, flangerPlugin, freqShifterPlugin, + loFiPlugin, panTremPlugin, monoTremPlugin, phaserPlugin, pitchShifterPlugin, reversePlugin, + ringModulatorPlugin, stChorusPlugin, stereoPingPongDelayPlugin, + delay1kPlugin, ) where import Data.List @@ -80,11 +90,11 @@ type GenMap = IdMap Gen -newGen :: Gen -> State GenMap E -newGen = fmap int . saveGenId +newGen :: Gen -> State GenMap Int +newGen = saveGenId -newTabOfGens :: [Gen] -> State GenMap E -newTabOfGens = fmap int . (saveGenId . intTab =<<) . mapM saveGenId +newTabOfGens :: [Gen] -> State GenMap Int +newTabOfGens = (saveGenId . intTab =<<) . mapM saveGenId where intTab ns = Gen (length ns) (IntGenId (-2)) (fmap fromIntegral ns) Nothing saveGenId :: Ord a => a -> State (IdMap a) Int @@ -333,11 +343,14 @@ , globalsVars :: [AllocVar] } data AllocVar = AllocVar - { allocVarType :: GlobalVarType - , allocVar :: Var - , allocVarInit :: E - } + { allocVarType :: GlobalVarType + , allocVar :: Var + , allocVarInit :: E } + | AllocArrVar + { allocArrVar :: Var + , allocArrVarSizes :: [E] } + data GlobalVarType = PersistentGlobalVar | ClearableGlobalVar deriving (Eq) @@ -357,15 +370,35 @@ newClearableGlobalVar :: Rate -> E -> State Globals Var newClearableGlobalVar = newGlobalVar ClearableGlobalVar - + +newPersistentGloabalArrVar :: Rate -> [E] -> State Globals Var +newPersistentGloabalArrVar rate sizes = state $ \s -> + let newId = globalsNewId s + var = Var GlobalVar rate ('g' : show newId) + s1 = s { globalsNewId = succ newId + , globalsVars = AllocArrVar var sizes : globalsVars s } + in (var, s1) + renderGlobals :: Monad m => Globals -> (DepT m (), DepT m ()) renderGlobals a = (initAll, clear) where - initAll = mapM_ (\x -> initVar (allocVar x) (allocVarInit x)) gs - clear = mapM_ (\x -> writeVar (allocVar x) (allocVarInit x)) clearable - clearable = filter ((== ClearableGlobalVar) . allocVarType) gs + initAll = mapM_ initAlloc gs + clear = mapM_ clearAlloc clearable + clearable = filter isClearable gs gs = globalsVars a + initAlloc x = case x of + AllocVar _ var init -> initVar var init + AllocArrVar var sizes -> initArr var sizes + + clearAlloc x = case x of + AllocVar _ var init -> writeVar var init + AllocArrVar _ _ -> return () + + isClearable x = case x of + AllocVar ty _ _ -> ty == ClearableGlobalVar + _ -> False + ----------------------------------------------------------------- -- instrs @@ -491,7 +524,42 @@ -- guis +-------------------------------------------------------- +-- Osc listeners +newtype OscListenPorts = OscListenPorts { unOscListenPorts :: IM.IntMap Var } + +instance Default OscListenPorts where + def = OscListenPorts IM.empty + +getOscPortVar :: Int -> State (OscListenPorts, Globals) Var +getOscPortVar port = state $ \st@(OscListenPorts m, globals) -> case IM.lookup port m of + Just a -> (a, st) + Nothing -> onNothing port m globals + where + onNothing port m globals = (var, (OscListenPorts m1, newGlobals)) + where + (var, newGlobals) = runState (allocOscPortVar port) globals + m1 = IM.insert port var m + + +allocOscPortVar :: Int -> State Globals Var +allocOscPortVar oscPort = newGlobalVar PersistentGlobalVar Ir $ oscInit (fromIntegral oscPort) + +---------------------------------------------------------- +-- macros arguments + +type MacrosInits = M.Map String MacrosInit + +data MacrosInit + = MacrosInitDouble { macrosInitName :: String, macrosInitValueDouble :: Double } + | MacrosInitString { macrosInitName :: String, macrosInitValueString :: String } + | MacrosInitInt { macrosInitName :: String, macrosInitValueInt :: Int } + deriving (Show, Eq, Ord) + +initMacros :: MacrosInit -> State MacrosInits () +initMacros macrosInit = modify $ \xs -> M.insert (macrosInitName macrosInit) macrosInit xs + -------------------------------------------------------- -- Udo plugins @@ -518,3 +586,21 @@ diodePlugin = UdoPlugin "diode" -- diode ladder filter korg35Plugin = UdoPlugin "korg35" -- korg 35 filter zeroDelayConvolutionPlugin = UdoPlugin "zero-delay-convolution" -- zero delay convolutio by Victor Lazzarini +pitchShifterDelayPlugin = UdoPlugin "PitchShifterDelay" -- pitch shifter delay + +analogDelayPlugin = UdoPlugin "MultiFX/AnalogDelay" +distortionPlugin = UdoPlugin "MultiFX/Distortion" +envelopeFolollowerPlugin = UdoPlugin "MultiFX/EnvelopeFollower" +flangerPlugin = UdoPlugin "MultiFX/Flanger" +freqShifterPlugin = UdoPlugin "MultiFX/FreqShifter" +loFiPlugin = UdoPlugin "MultiFX/LoFi" +panTremPlugin = UdoPlugin "MultiFX/PanTrem" +monoTremPlugin = UdoPlugin "MultiFX/MonoTrem" +phaserPlugin = UdoPlugin "MultiFX/Phaser" +pitchShifterPlugin = UdoPlugin "MultiFX/PitchShifter" +reversePlugin = UdoPlugin "MultiFX/Reverse" +ringModulatorPlugin = UdoPlugin "MultiFX/RingModulator" +stChorusPlugin = UdoPlugin "MultiFX/StChorus" +stereoPingPongDelayPlugin = UdoPlugin "MultiFX/StereoPingPongDelay" + +delay1kPlugin = UdoPlugin "Utility/Delay1k" diff --git a/src/Csound/Typed/GlobalState/GE.hs b/src/Csound/Typed/GlobalState/GE.hs --- a/src/Csound/Typed/GlobalState/GE.hs +++ b/src/Csound/Typed/GlobalState/GE.hs @@ -17,6 +17,7 @@ -- * Notes addNote, -- * GEN routines + GenId, saveGen, saveTabs, getNextGlobalGenId, saveWriteGen, saveWriteTab, -- * Sf2 @@ -33,6 +34,10 @@ guiInstrExp, listenKeyEvt, Key(..), KeyEvt(..), Guis(..), getKeyEventListener, + -- * OSC + getOscPortHandle, + -- * Macros + MacrosInit(..), readMacrosDouble, readMacrosString, readMacrosInt, -- * Cabbage Guis cabbage, -- * Hrtf pan @@ -55,7 +60,8 @@ import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader -import Csound.Dynamic +import Csound.Dynamic hiding (readMacrosDouble, readMacrosString, readMacrosInt) +import qualified Csound.Dynamic as D(readMacrosDouble, readMacrosString, readMacrosInt) import Csound.Typed.GlobalState.Options import Csound.Typed.GlobalState.Cache @@ -117,10 +123,12 @@ , bandLimitedMap :: BandLimitedMap , cache :: Cache GE , guis :: Guis - , cabbageGui :: Maybe Cabbage.Lang } + , oscListenPorts :: OscListenPorts + , cabbageGui :: Maybe Cabbage.Lang + , macrosInits :: MacrosInits } instance Default History where - def = History def def def def def def def def def def def def def def def (return ()) def def def def + def = History def def def def def def def def def def def def def def def (return ()) def def def def def def data Msg = Msg data MidiAssign = MidiAssign MidiType Channel InstrId @@ -174,7 +182,7 @@ getNextGlobalGenId :: GE Int getNextGlobalGenId = onHistory globalGenCounter (\a h -> h{ globalGenCounter = a }) nextGlobalGenCounter -saveGen :: Gen -> GE E +saveGen :: Gen -> GE Int saveGen = onGenMap . newGen onGenMap = onHistory genMap (\val h -> h{ genMap = val }) @@ -188,7 +196,7 @@ onWriteGenMap = onHistory writeGenMap (\val h -> h{ writeGenMap = val }) saveTabs :: [Gen] -> GE E -saveTabs = onGenMap . newTabOfGens +saveTabs = onGenMap . fmap int . newTabOfGens onSfMap :: State SfMap a -> GE a onSfMap = onHistory sfMap (\val h -> h{ sfMap = val }) @@ -520,6 +528,14 @@ return $ Just (Instr keyEventInstrId body) ----------------------------------------------- +-- osc port listen + +getOscPortHandle :: Int -> GE E +getOscPortHandle port = onOscPorts (fmap inlineVar $ getOscPortVar port) + where + onOscPorts = onHistory (\h -> (oscListenPorts h, globals h)) (\(ports, gs) h -> h { oscListenPorts = ports, globals = gs }) + +----------------------------------------------- -- cabbage cabbage :: Cabbage.Cab -> GE () @@ -547,6 +563,24 @@ hrtfFileNames :: Int -> IO (String, String) hrtfFileNames sr = liftA2 (,) (getDataFileName (name "left" sr)) (getDataFileName (name "right" sr)) where name dir n = concat ["data/hrtf-", show n, "-", dir, ".dat"] + +----------------------------------------------- +-- read macros + +readMacrosDouble :: String -> Double -> GE E +readMacrosDouble = readMacrosBy D.readMacrosDouble MacrosInitDouble + +readMacrosString :: String -> String -> GE E +readMacrosString = readMacrosBy D.readMacrosString MacrosInitString + +readMacrosInt :: String -> Int -> GE E +readMacrosInt = readMacrosBy D.readMacrosInt MacrosInitInt + +readMacrosBy :: (String -> E) -> (String -> a -> MacrosInit) -> String -> a -> GE E +readMacrosBy reader allocator name initValue = do + onMacrosInits $ initMacros $ allocator name initValue + return $ reader name + where onMacrosInits = onHistory macrosInits (\val h -> h { macrosInits = val }) ----------------------------------------------- -- udo plugins diff --git a/src/Csound/Typed/GlobalState/InstrApi.hs b/src/Csound/Typed/GlobalState/InstrApi.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/GlobalState/InstrApi.hs @@ -0,0 +1,74 @@ +{-# Language ScopedTypeVariables #-} +module Csound.Typed.GlobalState.InstrApi( + InstrId, event, eventi, + newInstr, newInstrLinked, + turnoff, turnoff2 +) where + +import Control.Monad +import Control.Monad.Trans.Class + +import Csound.Dynamic hiding (InstrId, when1) +import Csound.Typed.GlobalState.Instr +import Csound.Typed.GlobalState.GE +import Csound.Typed.GlobalState.SE +import Csound.Typed.Types.Tuple +import Csound.Typed.Types.Prim + +import Csound.Typed.GlobalState.Port + + +import qualified Csound.Typed.GlobalState.Opcodes as Opcodes(Event(..), event, eventi, turnoff2, turnoff, initSig, activeKr) + +data InstrId a + = InstrId { unInstrId :: GE E } + | InstrLinkedId { instrLivenessPort :: PortCtrl Sig, unInstrId :: GE E } + +newInstr :: Arg a => (a -> SE ()) -> InstrId a +newInstr instr = InstrId $ fmap instrIdE $ saveInstr (instr toArg) + +event :: Arg a => InstrId a -> (D,D,a) -> SE () +event idx note = do + e <- getEvent idx note + SE $ Opcodes.event e + +eventi :: Arg a => InstrId a -> (D,D,a) -> SE () +eventi idx note = do + e <- getEvent idx note + SE $ Opcodes.eventi e + +getEvent :: Tuple a => InstrId a -> (D, D, a) -> SE Opcodes.Event +getEvent (InstrId idx) (start, dur, args) = SE $ lift $ do + i <- idx + s <- toGE start + d <- toGE dur + as <- fromTuple args + return $ Opcodes.Event i s d as +getEvent (InstrLinkedId port idx) (start, dur, arg) = do + getEvent (InstrId idx) (start, dur, (arg, port)) + +turnoff2 :: InstrId a -> SE () +turnoff2 (InstrId expr) = SE $ Opcodes.turnoff2 =<< lift expr + +turnoff :: SE () +turnoff = SE $ Opcodes.turnoff + +newInstrLinked :: forall a. Arg a => (a -> SE ()) -> SE (InstrId a) +newInstrLinked instr = do + p <- freePortCtrl + writePort p 10 + let instrId = fmap instrIdE $ saveInstr (instr' toArg) + let resInstrId = InstrLinkedId p instrId + writePort p $ (fromGE $ fmap Opcodes.activeKr instrId) + 1 + return resInstrId + where + instr' :: (a, PortCtrl Sig) -> SE () + instr' (arg, port) = do + instr arg + testLiveness port + +testLiveness :: PortCtrl Sig -> SE () +testLiveness p = do + isAlive <- readPort p + when1 (isAlive `lessThan` 0) $ turnoff + modifyPort p (\x -> x - 1) diff --git a/src/Csound/Typed/GlobalState/Opcodes.hs b/src/Csound/Typed/GlobalState/Opcodes.hs --- a/src/Csound/Typed/GlobalState/Opcodes.hs +++ b/src/Csound/Typed/GlobalState/Opcodes.hs @@ -1,7 +1,7 @@ module Csound.Typed.GlobalState.Opcodes( sprintf, -- * channel opcodes - ChnRef(..), chnRefFromParg, chnRefAlloc, readChn, writeChn, freeChn, + ChnRef(..), chnRefFromParg, chnRefAlloc, readChn, writeChn, overWriteChn, freeChn, chnName, chnget, chnset, chngetK, chnsetK, initSig, active, activeKr, readChnEvtLoop, chnUpdateUdo, masterUpdateChnAlive, servantUpdateChnAlive, masterUpdateChnRetrig, servantUpdateChnRetrig, @@ -65,6 +65,9 @@ writeChn :: Monad m => ChnRef -> [E] -> DepT m () writeChn ref sigs = zipWithM_ chnmix sigs $ chnRefNames ref + +overWriteChn :: Monad m => ChnRef -> [E] -> DepT m () +overWriteChn ref sigs = zipWithM_ chnset (chnRefNames ref) sigs clearChn :: Monad m => ChnRef -> DepT m () clearChn = mapM_ chnclear . chnRefNames @@ -76,10 +79,10 @@ where formatString = str $ 'p' : show name ++ "_" ++ "%d" masterUpdateChnAlive :: Monad m => ChnRef -> E -> DepT m () -masterUpdateChnAlive ref count = chnsetK count (chnAliveName $ chnRefId ref) +masterUpdateChnAlive ref count = chnsetK (chnAliveName $ chnRefId ref) count masterUpdateChnRetrig :: Monad m => ChnRef -> E -> DepT m () -masterUpdateChnRetrig ref count = chnsetK count (chnRetrigName $ chnRefId ref) +masterUpdateChnRetrig ref count = chnsetK (chnRetrigName $ chnRefId ref) count servantUpdateChnAlive :: Monad m => Int -> DepT m () servantUpdateChnAlive pargId = do @@ -87,7 +90,7 @@ kAlive <- chngetK sName when1 Kr (kAlive <* -10) $ do turnoff - chnsetK (kAlive - 1) sName + chnsetK sName (kAlive - 1) getRetrigVal :: Int -> E getRetrigVal pargId = pn $ pargId + 1 @@ -104,7 +107,7 @@ servantUpdateChnEvtLoop pargId = do let sName = chnEvtLoopName (pn pargId) kEvtLoop <- chngetK sName - chnsetK (ifB (kEvtLoop ==* 0) 1 0) sName + chnsetK sName (ifB (kEvtLoop ==* 0) 1 0) turnoff readChnEvtLoop :: Monad m => ChnRef -> DepT m E @@ -132,6 +135,9 @@ val <- readVar var depT_ $ opcsNoInlineArgs "chnmix" [(Xr, [Ar, Sr])] [val, name] +chnset :: Monad m => E -> E -> DepT m () +chnset name value = depT_ $ opcs "chnset" [(Xr, [Ar, Sr])] [value, name] + chnget :: Monad m => E -> DepT m E chnget name = depT $ opcs "chnget" [(Ar, [Sr])] [name] @@ -139,7 +145,7 @@ chngetK name = depT $ opcs "chnget" [(Kr, [Sr])] [name] chnsetK :: Monad m => E -> E -> DepT m () -chnsetK val name = depT_ $ opcsNoInlineArgs "chnset" [(Xr, [Kr, Sr])] [val, name] +chnsetK name val = depT_ $ opcsNoInlineArgs "chnset" [(Xr, [Kr, Sr])] [val, name] chnclear :: Monad m => E -> DepT m () chnclear name = depT_ $ opcs "chnclear" [(Xr, [Sr])] [name] @@ -241,11 +247,14 @@ follow :: E -> E -> E follow asig dt = opcs "follow" [(Ar, [Ar, Ir])] [asig, dt] +initSig :: E -> E +initSig a = opcs "init" [(Kr, [Ir])] [a] + turnoff :: Monad m => DepT m () turnoff = depT_ $ opcs "turnoff" [(Xr, [])] [] turnoff2 :: Monad m => E -> DepT m () -turnoff2 instrId = depT_ $ opcs "turnoff2" [(Xr, [Ir, Ir, Ir])] [instrId, 0, 0] +turnoff2 instrId = depT_ $ opcs "turnoff2" [(Xr, [Kr, Kr, Kr])] [instrId, 0, 0] exitnow :: Monad m => DepT m () exitnow = depT_ $ opcs "exitnow" [(Xr, [])] [] @@ -313,11 +322,11 @@ ----------------------------------------------------------- -- OSC -oscInit :: Monad m => E -> DepT m E -oscInit port = depT $ opcs "OSCinit" [(Ir, [Ir])] [port] +oscInit :: E -> E +oscInit port = opcs "OSCinit" [(Ir, [Ir])] [port] -oscListen :: Monad m => [E] -> DepT m E -oscListen args = depT $ opcs "OSClisten" [(Kr, Ir:Ir:Ir:repeat Xr)] args +oscListen :: Monad m => E -> E -> E -> [Var] -> DepT m E +oscListen oscHandle addr oscType vars = depT $ opcs "OSClisten" [(Kr, Ir:Ir:Ir:repeat Xr)] (oscHandle : addr : oscType : fmap inlineVar vars) oscSend :: Monad m => [E] -> DepT m () oscSend args = depT_ $ opcs "OSCsend" [(Xr, Kr:Ir:Ir:Ir:Ir:repeat Xr)] args @@ -389,6 +398,9 @@ activeIr :: E -> E activeIr instrId = opcs "active" [(Ir, [Ir])] [instrId] + +activeKr :: E -> E +activeKr instrId = opcs "active" [(Kr, [Ir])] [instrId] port :: E -> E -> E port a b = opcs "portk" [(Kr, [Kr, Ir])] [a, b] diff --git a/src/Csound/Typed/GlobalState/Options.hs b/src/Csound/Typed/GlobalState/Options.hs --- a/src/Csound/Typed/GlobalState/Options.hs +++ b/src/Csound/Typed/GlobalState/Options.hs @@ -1,18 +1,25 @@ module Csound.Typed.GlobalState.Options ( Options(..), - defGain, defSampleRate, defBlockSize, defTabFi, + defGain, defSampleRate, defBlockSize, defTabFi, defScaleUI, -- * Table fidelity - TabFi(..), fineFi, coarseFi, + TabFi(..), fineFi, coarseFi, -- ** Gen identifiers -- | Low level Csound integer identifiers for tables. These names can be used in the function 'Csound.Base.fineFi' -- *** Integer identifiers idWavs, idMp3s, idDoubles, idSines, idSines3, idSines2, idPartials, idSines4, idBuzzes, idConsts, idLins, idCubes, idExps, idSplines, idStartEnds, idPolys, idChebs1, idChebs2, idBessels, idWins, + idTabHarmonics, idMixOnTab, idMixTabs, + idNormTab, idPolynomFuns, idLinTab, idRandDists, idReadNumFile, idReadNumTab, + idExpsBreakPoints, idLinsBreakPoints, idReadTrajectoryFile, idMixSines1, idMixSines2, + idRandHist, idRandPairs, idRandRanges, idPvocex, idTuning, idMultichannel, -- *** String identifiers - idPadsynth, idTanh, idExp, idSone, idFarey, idWave + idPadsynth, idTanh, idExp, idSone, idFarey, idWave, + -- * Jacko + Jacko(..), JackoConnect, renderJacko ) where +import Data.Monoid import Control.Applicative import Data.Default @@ -29,16 +36,19 @@ -- > blockSize = 64 -- > gain = 0.5 -- > tabFi = fineFi 13 [(idLins, 11), (idExps, 11), (idConsts, 9), (idSplines, 11), (idStartEnds, 12)] } +-- > scaleUI = (1, 1) data Options = Options - { csdFlags :: Flags -- ^ Csound command line flags - , csdSampleRate :: Maybe Int -- ^ The sample rate - , csdBlockSize :: Maybe Int -- ^ The number of audio samples in one control step - , csdGain :: Maybe Double -- ^ A gain of the final output - , csdTabFi :: Maybe TabFi -- ^ Default fidelity of the arrays + { csdFlags :: Flags -- ^ Csound command line flags + , csdSampleRate :: Maybe Int -- ^ The sample rate + , csdBlockSize :: Maybe Int -- ^ The number of audio samples in one control step + , csdGain :: Maybe Double -- ^ A gain of the final output + , csdTabFi :: Maybe TabFi -- ^ Default fidelity of the arrays + , csdScaleUI :: Maybe (Double, Double) -- ^ Scale factors for UI-window + , csdJacko :: Maybe Jacko } instance Default Options where - def = Options def def def def def + def = Options def def def def def def def instance Monoid Options where mempty = def @@ -47,8 +57,13 @@ , csdSampleRate = csdSampleRate a <|> csdSampleRate b , csdBlockSize = csdBlockSize a <|> csdBlockSize b , csdGain = csdGain a <|> csdGain b - , csdTabFi = csdTabFi a <|> csdTabFi b } + , csdTabFi = csdTabFi a <|> csdTabFi b + , csdScaleUI = csdScaleUI a <|> csdScaleUI b + , csdJacko = csdJacko a <|> csdJacko b } +defScaleUI :: Options -> (Double, Double) +defScaleUI = maybe (1, 1) id . csdScaleUI + defGain :: Options -> Double defGain = maybe 0.8 id . csdGain @@ -69,7 +84,7 @@ instance Default TabFi where def = fineFi 13 - [(idLins, 11), (idExps, 11), (idConsts, 9), (idSplines, 11), (idStartEnds, 12)] + [(idLins, 11), (idExps, 11), (idConsts, 9), (idSplines, 11), (idStartEnds, 12), (idExpsBreakPoints, 11), (idLinsBreakPoints, 11), (idRandDists, 6)] [(idPadsynth, 18), (idSone, 14), (idTanh, 13), (idExp, 13)] @@ -98,8 +113,11 @@ idWavs, idMp3s, idDoubles, idSines, idSines3, idSines2, idPartials, idSines4, idBuzzes, idConsts, idLins, idCubes, - idExps, idSplines, idStartEnds, idPolys, idChebs1, idChebs2, idBessels, idWins :: Int - + idExps, idSplines, idStartEnds, idPolys, idChebs1, idChebs2, idBessels, idWins, + idTabHarmonics, idMixOnTab, idMixTabs, + idNormTab, idPolynomFuns, idLinTab, idRandDists, idReadNumFile, idReadNumTab, + idExpsBreakPoints, idLinsBreakPoints, idReadTrajectoryFile, idMixSines1, idMixSines2, + idRandHist, idRandPairs, idRandRanges, idPvocex, idTuning, idMultichannel :: Int -- Human readable Csound identifiers for GEN-routines @@ -123,14 +141,90 @@ idBessels = 12 idWins = 20 idMp3s = 49 +idTabHarmonics = 30 +idMixOnTab = 31 +idMixTabs = 32 --- Identifiers for named GEN-routines +idNormTab = 4 +idLinTab = 18 -idPadsynth, idTanh, idExp, idSone, idFarey, idWave :: String +idRandDists = 21 +idReadNumFile = 23 +idReadNumTab = 24 +idExpsBreakPoints = 25 +idLinsBreakPoints = 27 +idReadTrajectoryFile = 28 +idMixSines1 = 33 +idMixSines2 = 34 +idRandHist = 40 +idRandPairs = 41 +idRandRanges = 42 +idPvocex = 43 +idTuning = 51 +idMultichannel = 52 -idPadsynth = "padsynth" idTanh = "tanh" idExp = "exp" idSone = "sone" idFarey = "farey" idWave = "wave" + +-- Identifiers for named GEN-routines + +idPadsynth, idTanh, idExp, idSone, idFarey, idWave :: String + +idPadsynth = "padsynth" + +--------------------------------------------- +-- not implemented yet (hard to implement within the current model) + +idPolynomFuns = 15 + + +---------------------------------------------------------- +-- Jacko + +type JackoConnect = (String, String) + +-- | Describes the Jacko header. All information that is going to be set in the global settings for Jacko opcodes. +-- The jacko opcodes allows us to easily turn our app into Jack-client. We can also do it with command line flags. +-- But the Jacko opcodes provide more options. +-- +-- see the Csound docs for details: +data Jacko = Jacko + { jackoClient :: String + , jackoServer :: String + , jackoAudioIns :: [JackoConnect] + , jackoAudioOuts :: [JackoConnect] + , jackoMidiIns :: [JackoConnect] + , jackoMidiOuts :: [JackoConnect] + , jackoFreewheel :: Bool + , jackoInfo :: Bool } + +instance Default Jacko where + def = Jacko + { jackoClient = "csound-exp" + , jackoServer = "default" + , jackoAudioIns = [] + , jackoAudioOuts = [] + , jackoMidiIns = [] + , jackoMidiOuts = [] + , jackoFreewheel = False + , jackoInfo = False } + +renderJacko :: Jacko -> String +renderJacko spec = unlines $ filter ( /= "") + [ "JackoInit " ++ (str $ jackoServer spec) ++ ", " ++ (str $ jackoClient spec) + , if (jackoFreewheel spec) then "JackoFreewheel 1" else "" + , if (jackoInfo spec) then "JackoInfo" else "" + , renderConnections "JackoAudioInConnect" $ jackoAudioIns spec + , renderConnections "JackoAudioOutConnect" $ jackoAudioOuts spec + , renderConnections "JackoMidiInConnect" $ jackoMidiIns spec + , renderConnections "JackoMidiOutConnect" $ jackoMidiOuts spec + , "JackoOn" ] + where + renderConnections name links = unlines $ fmap (renderLink name) links + + renderLink name (a, b) = name ++ " " ++ (str a) ++ ", " ++ (str b) + + str x = "\"" ++ x ++ "\"" diff --git a/src/Csound/Typed/GlobalState/Port.hs b/src/Csound/Typed/GlobalState/Port.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/GlobalState/Port.hs @@ -0,0 +1,113 @@ +{-# Language ScopedTypeVariables #-} +-- | The port is a tool to route the auio signals between instruments. +-- We can allocate the port at the instance of the instrument (at the note) +-- and pass the reference in the note to another instrument. That instrument +-- cn write a signal to the port or can read the singals. +module Csound.Typed.GlobalState.Port( + IsPort(..), mixPort, modifyPort, + Port(..), freePort, + PortCtrl(..), freePortCtrl +) where + +import Control.Monad +import Control.Monad.Trans.Class + +import Csound.Dynamic + +import Csound.Typed.GlobalState.GE +import Csound.Typed.GlobalState.SE +import Csound.Typed.Types.Tuple +import Csound.Typed.Types.Prim + +import Csound.Typed.GlobalState.Opcodes(freeChn, chnName, chnget, chnset, chngetK, chnsetK) + +-- port class + +class IsPort p where + readPort :: Sigs a => p a -> SE a + writePort :: Sigs a => p a -> a -> SE () + +mixPort :: (Sigs a) => IsPort port => port a -> a -> SE () +mixPort p value = modifyPort p (value + ) + +modifyPort :: (Sigs a, IsPort port) => port a -> (a -> a) -> SE () +modifyPort p f = do + value <- readPort p + writePort p $ f value + +-- port for audio signals + +newtype Port a = Port { unPort :: GE E } + +freePort :: forall a . Sigs a => SE (Port a) +freePort = SE $ fmap (Port . return) $ freeChn + +instance Sigs a => Tuple (Port a) where + tupleMethods = makeTupleMethods to from + where + to :: D -> Port a + to = Port . toGE + + from :: Port a -> D + from (Port e) = fromGE e + +instance Sigs a => Arg (Port a) where + +instance IsPort Port where + readPort port = SE $ hideGEinDep $ do + names <- getNames port + return $ fmap (toTuple . return) $ mapM chnget names + + writePort port a = SE $ do + (names, values) <- lift getNamesAndValues + zipWithM_ chnset names values + where + getNamesAndValues = do + names <- getNames port + values <- fromTuple a + return (names, values) + +------------------------------------------------------------- +-- ports for control signals + +newtype PortCtrl a = PortCtrl { unPortCtrl :: GE E } + +freePortCtrl :: forall a . Sigs a => SE (PortCtrl a) +freePortCtrl = SE $ fmap (PortCtrl . return) $ freeChn + +instance Sigs a => Tuple (PortCtrl a) where + tupleMethods = makeTupleMethods to from + where + to :: D -> PortCtrl a + to = PortCtrl . toGE + + from :: PortCtrl a -> D + from (PortCtrl e) = fromGE e + +instance Sigs a => Arg (PortCtrl a) where + +instance IsPort PortCtrl where + readPort port = SE $ hideGEinDep $ do + names <- getNamesCtrl port + return $ fmap (toTuple . return) $ mapM chngetK names + + writePort port a = SE $ do + (names, values) <- lift getNamesAndValues + zipWithM_ chnsetK names values + where + getNamesAndValues = do + names <- getNamesCtrl port + values <- fromTuple a + return (names, values) + +------------------------------------------------------- + +getNames :: forall a . Sigs a => Port a -> GE [E] +getNames (Port ref) = do + idx <- ref + return $ fmap (flip chnName idx) [1 .. (tupleArity ((error "No def here") :: a))] + +getNamesCtrl :: forall a . Sigs a => PortCtrl a -> GE [E] +getNamesCtrl (PortCtrl ref) = do + idx <- ref + return $ fmap (flip chnName idx) [1 .. (tupleArity ((error "No def here") :: a))] diff --git a/src/Csound/Typed/GlobalState/SE.hs b/src/Csound/Typed/GlobalState/SE.hs --- a/src/Csound/Typed/GlobalState/SE.hs +++ b/src/Csound/Typed/GlobalState/SE.hs @@ -2,17 +2,19 @@ SE(..), LocalHistory(..), runSE, execSE, evalSE, execGEinSE, hideGEinDep, fromDep, fromDep_, geToSe, - newLocalVar, newLocalVars, newGlobalVars, newClearableGlobalVars + newLocalVar, newLocalVars, newGlobalVars, newClearableGlobalVars, + -- array variables + newLocalArrVar, newGlobalArrVar, newTmpArrVar ) where import Control.Applicative import Control.Monad import Control.Monad.Trans.Class -import Csound.Dynamic hiding (newLocalVar, newLocalVars) -import qualified Csound.Dynamic as D(newLocalVar, newLocalVars) +import Csound.Dynamic hiding (newLocalVar, newLocalVars, newLocalArrVar, newTmpArrVar) +import qualified Csound.Dynamic as D(newLocalVar, newLocalVars, newLocalArrVar, newTmpArrVar) import Csound.Typed.GlobalState.GE -import Csound.Typed.GlobalState.Elements(newPersistentGlobalVar, newClearableGlobalVar) +import Csound.Typed.GlobalState.Elements(newPersistentGlobalVar, newClearableGlobalVar, newPersistentGloabalArrVar) -- | The Csound's @IO@-monad. All values that produce side effects are wrapped -- in the @SE@-monad. @@ -78,3 +80,15 @@ newClearableGlobalVars :: [Rate] -> GE [E] -> SE [Var] newClearableGlobalVars rs vs = geToSe $ zipWithM f rs =<< vs where f r v = onGlobals $ newClearableGlobalVar r v + +------------------------------------------------------------------ +-- allocation of array vars + +newLocalArrVar :: Rate -> GE [E] -> SE Var +newLocalArrVar rate val = SE $ D.newLocalArrVar rate val + +newTmpArrVar :: Rate -> SE Var +newTmpArrVar rate = SE $ D.newTmpArrVar rate + +newGlobalArrVar :: Rate -> GE [E] -> SE Var +newGlobalArrVar r v = geToSe $ onGlobals . newPersistentGloabalArrVar r =<< v diff --git a/src/Csound/Typed/Gui/BoxModel.hs b/src/Csound/Typed/Gui/BoxModel.hs --- a/src/Csound/Typed/Gui/BoxModel.hs +++ b/src/Csound/Typed/Gui/BoxModel.hs @@ -7,6 +7,7 @@ ) where import Control.Monad +import Control.Applicative import Control.Monad.Trans.State.Strict import Data.Default import Data.Monoid diff --git a/src/Csound/Typed/Gui/Cabbage/Cabbage.hs b/src/Csound/Typed/Gui/Cabbage/Cabbage.hs --- a/src/Csound/Typed/Gui/Cabbage/Cabbage.hs +++ b/src/Csound/Typed/Gui/Cabbage/Cabbage.hs @@ -20,6 +20,7 @@ import Data.Maybe import Control.Monad.Trans.Writer.Strict +import Control.Applicative import Csound.Typed.Gui.Cabbage.CabbageLang diff --git a/src/Csound/Typed/Gui/Gui.hs b/src/Csound/Typed/Gui/Gui.hs --- a/src/Csound/Typed/Gui/Gui.hs +++ b/src/Csound/Typed/Gui/Gui.hs @@ -7,7 +7,7 @@ -- * Layout hor, ver, space, sca, horSca, verSca, - padding, margin, + padding, margin, ScaleFactor, resizeGui, -- * Props props, forceProps, Prop(..), BorderType(..), Color, @@ -187,13 +187,20 @@ data Props = Props { propsBorder :: Maybe BorderType + , propsScaleFactor :: Maybe ScaleFactor , otherProps :: [Prop] } +type ScaleFactor = (Double, Double) + instance Monoid Props where - mempty = Props Nothing [] - mappend a b = Props { propsBorder = (propsBorder a) <|> (propsBorder b) + mempty = Props Nothing Nothing [] + mappend a b = Props { propsBorder = propsBorder a <|> propsBorder b + , propsScaleFactor = propsScaleFactor a <|> propsScaleFactor b , otherProps = mappend (otherProps a) (otherProps b) } +instance Default Props where + def = mempty + -- | Properties of the widgets. data Prop = SetLabel String @@ -333,14 +340,18 @@ -- | Sets the properties for a GUI element. props :: [Prop] -> Gui -> Gui -props ps = onLowGui1 (Box.appendContext (Props Nothing ps)) +props ps = onLowGui1 (Box.appendContext $ def { otherProps = ps }) +-- | Rescales the default sizes for the UI elements. +resizeGui :: ScaleFactor -> Gui -> Gui +resizeGui factorXY = onLowGui1 (Box.appendContext $ def { propsScaleFactor = Just factorXY }) + -- | Sets the properties for a GUI element on all levels. forceProps :: [Prop] -> Gui -> Gui forceProps = error "forceProps: TODO" setBorder :: BorderType -> Gui -> Gui -setBorder a = onLowGui1 (Box.appendContext (Props (Just a) [])) +setBorder a = onLowGui1 (Box.appendContext $ def { propsBorder = Just a }) type GuiMap = IM.IntMap Gui @@ -354,20 +365,20 @@ _ -> return elem -guiStmt :: Monad m => [Panel] -> DepT m () -guiStmt panels = depT_ $ noRate phi - where phi +guiStmt :: Monad m => ScaleFactor -> [Panel] -> DepT m () +guiStmt defaultScaleUI panels = depT_ $ noRate (phi defaultScaleUI) + where phi scaleUI | null panels = EmptyExp - | otherwise = Verbatim $ show $ vcat [vcat $ fmap drawGui panels, text "FLrun"] + | otherwise = Verbatim $ show $ vcat [vcat $ fmap (drawGui scaleUI) panels, text "FLrun"] -drawGui :: Panel -> Doc -drawGui x = case x of +drawGui :: ScaleFactor -> Panel -> Doc +drawGui defaultScaleUI x = case x of Single w isKeybd -> panel isKeybd boundingRect $ drawWin (withWinMargin boundingRect) w Tabs _ _ ws isKeybd -> panel isKeybd tabPanelRect $ case ws of [] -> empty _ -> onTabs mainTabRect $ vcat $ fmap (uncurry $ drawTab shift) tabsRs - where boundingRect = panelRect (fmap fst tabsRs) x - tabsRs = tabsRects x + where boundingRect = panelRect defaultScaleUI (fmap fst tabsRs) x + tabsRs = tabsRects defaultScaleUI x (mainTabRect, shift) = mainTabRectAndShift boundingRect tabPanelRect = Rect @@ -397,9 +408,9 @@ Single w _ -> winTitle w Tabs title _ _ _ -> title -panelRect :: [Rect] -> Panel -> Rect -panelRect rs x = case x of - Single w _ -> winBoundingRect w +panelRect :: ScaleFactor -> [Rect] -> Panel -> Rect +panelRect defaultScaleUI rs x = case x of + Single w _ -> winBoundingRect defaultScaleUI w Tabs _ mrect _ _ -> case rs of [] -> Box.zeroRect _ -> maybe (foldr boundingRect (head rs) rs) id mrect @@ -422,13 +433,13 @@ -tabsRects :: Panel -> [(Rect, Win)] -tabsRects x = case x of +tabsRects :: ScaleFactor -> Panel -> [(Rect, Win)] +tabsRects defaultScaleUI x = case x of Single _ _ -> [] - Tabs _ _ ws _ -> zip (fmap winBoundingRect ws) ws + Tabs _ _ ws _ -> zip (fmap (winBoundingRect defaultScaleUI) ws) ws -winBoundingRect :: Win -> Rect -winBoundingRect w = maybe (shiftBy 50 $ bestRect $ winGui w) id $ winRect w +winBoundingRect :: ScaleFactor -> Win -> Rect +winBoundingRect defaultScaleUI w = maybe (shiftBy 50 $ bestRect defaultScaleUI $ winGui w) id $ winRect w where shiftBy n r = r { px = n + px r, py = n + py r } drawTab :: (Int, Int) -> Rect -> Win -> Doc @@ -855,33 +866,41 @@ , width = width r - 2 * winMargin } -bestRect :: Gui -> Rect -bestRect +bestRect :: ScaleFactor -> Gui -> Rect +bestRect defaultScaleUI = appendWinMargin . Box.boundingRect - . mapWithOrient (\curOrient x -> uncurry noShiftRect $ bestElemSizes curOrient $ elemContent x) + . mapWithOrientAndScale defaultScaleUI (\curOrient curScaleFactor x -> uncurry noShiftRect $ bestElemSizesRescaled curScaleFactor $ bestElemSizes curOrient $ elemContent x) . unGui where noShiftRect w h = Rect { px = 0, py = 0, width = w, height = h } -mapWithOrient :: (Orient -> a -> b) -> Box.Scene ctx a -> Box.Scene ctx b -mapWithOrient f = iter Hor +mapWithOrientAndScale :: ScaleFactor -> (Orient -> ScaleFactor -> a -> b) -> Box.Scene Props a -> Box.Scene Props b +mapWithOrientAndScale defaultScaleUI f = iter Hor defaultScaleUI where - iter curOrient x = case x of - Box.Prim a -> Box.Prim $ f curOrient a + iter curOrient curScale x = case x of + Box.Prim a -> Box.Prim $ f curOrient curScale a Box.Space -> Box.Space - Box.Scale d a -> Box.Scale d $ iter curOrient a - Box.Hor offs as -> Box.Hor offs $ fmap (iter Hor) as - Box.Ver offs as -> Box.Ver offs $ fmap (iter Ver) as - Box.Context ctx a -> Box.Context ctx $ iter curOrient a - + Box.Scale d a -> Box.Scale d $ iter curOrient curScale a + Box.Hor offs as -> Box.Hor offs $ fmap (iter Hor curScale) as + Box.Ver offs as -> Box.Ver offs $ fmap (iter Ver curScale) as + Box.Context ctx a -> case propsScaleFactor ctx of + Nothing -> Box.Context ctx $ iter curOrient curScale a + Just newScale -> Box.Context ctx $ iter curOrient (mulFactors curScale newScale) a + where + mulFactors (x1, y1) (x2, y2) = (x1 * x2, y1 * y2) + +bestElemSizesRescaled :: ScaleFactor -> (Int, Int) -> (Int, Int) +bestElemSizesRescaled (scaleX, scaleY) (sizeX, sizeY) = (mul scaleX sizeX, mul scaleY sizeY) + where mul double int = round $ double * fromIntegral int + bestElemSizes :: Orient -> Elem -> (Int, Int) bestElemSizes orient x = case x of -- valuators - Count _ _ _ -> (150, 35) - Joy _ _ -> (350, 350) - Knob _ -> (170, 170) - Roller _ _ -> inVer (250, 35) - Slider _ -> inVer (300, 35) - Text _ _ -> (120, 35) + Count _ _ _ -> (120, 30) + Joy _ _ -> (200, 200) + Knob _ -> (80, 80) + Roller _ _ -> inVer (150, 30) + Slider _ -> inVer (150, 25) + Text _ _ -> (100, 35) -- other widgets Box label -> @@ -889,11 +908,11 @@ numOfLines = succ $ div (length label) symbolsPerLine in (xBox 15 symbolsPerLine, yBox 15 numOfLines) - ButBank xn yn -> (xn * 80, yn * 35) - Button _ -> (80, 35) - Toggle -> (80, 35) - Value -> (100, 35) - Vkeybd -> (1280, 240) + ButBank xn yn -> (xn * 70, yn * 35) + Button _ -> (75, 35) + Toggle -> (75, 35) + Value -> (80, 35) + Vkeybd -> (1080, 240) -- error GuiVar h -> orphanGuiVar h diff --git a/src/Csound/Typed/Gui/Widget.hs b/src/Csound/Typed/Gui/Widget.hs --- a/src/Csound/Typed/Gui/Widget.hs +++ b/src/Csound/Typed/Gui/Widget.hs @@ -35,6 +35,7 @@ import Csound.Typed.Gui.Gui import Csound.Typed.GlobalState import Csound.Typed.Types hiding (whens) +import Csound.Typed.InnerOpcodes -- | Renders a list of panels. panels :: [Gui] -> SE () @@ -498,16 +499,6 @@ flPrintk2 :: Sig -> D -> SE () flPrintk2 val handle = SE $ (depT_ =<<) $ lift $ f <$> toGE val <*> toGE handle where f a b = opcs "FLprintk2" [(Xr, [Kr, Ir])] [a, b] - --- | This opcode outputs a trigger signal that informs when any one of its k-rate --- arguments has changed. Useful with valuator widgets or MIDI controllers. --- --- > ktrig changed kvar1 [, kvar2,..., kvarN] --- --- doc: -changed :: [Sig] -> Sig -changed = Sig . fmap f . mapM toGE - where f = opcs "changed" [(Kr, repeat Kr)] ----------------------------------------------------- diff --git a/src/Csound/Typed/InnerOpcodes.hs b/src/Csound/Typed/InnerOpcodes.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/InnerOpcodes.hs @@ -0,0 +1,16 @@ +module Csound.Typed.InnerOpcodes( + changed +) where + +import Csound.Typed.Types.Prim +import Csound.Dynamic + +-- | This opcode outputs a trigger signal that informs when any one of its k-rate +-- arguments has changed. Useful with valuator widgets or MIDI controllers. +-- +-- > ktrig changed kvar1 [, kvar2,..., kvarN] +-- +-- doc: +changed :: [Sig] -> Sig +changed = Sig . fmap f . mapM toGE + where f = opcs "changed" [(Kr, repeat Kr)] diff --git a/src/Csound/Typed/Plugins.hs b/src/Csound/Typed/Plugins.hs --- a/src/Csound/Typed/Plugins.hs +++ b/src/Csound/Typed/Plugins.hs @@ -27,7 +27,18 @@ linKorg_lp, linKorg_hp, korg_lp, korg_hp, -- zero delay convolution - ZConvSpec(..), zconv, zconv' + ZConvSpec(..), zconv, zconv', + + -- ptich shifter delay + pitchShifterDelay, + + -- Iain's fxs + fxAnalogDelay, fxDistortion, fxEnvelopeFollower, fxFlanger, fxFreqShifter, fxLoFi, + fxPanTrem, fxMonoTrem, fxPhaser, fxPitchShifter, fxReverse, fxRingModulator, fxChorus2, fxPingPong, + + -- utilities + delay1k + ) where import Csound.Typed.Plugins.Adsr140 @@ -37,3 +48,5 @@ import Csound.Typed.Plugins.Korg35 import Csound.Typed.Plugins.SolinaChorus import Csound.Typed.Plugins.ZeroDelayConvolution +import Csound.Typed.Plugins.Iain +import Csound.Typed.Plugins.Utilities diff --git a/src/Csound/Typed/Plugins/Adsr140.hs b/src/Csound/Typed/Plugins/Adsr140.hs --- a/src/Csound/Typed/Plugins/Adsr140.hs +++ b/src/Csound/Typed/Plugins/Adsr140.hs @@ -4,10 +4,11 @@ import Data.Boolean import Control.Monad.Trans.Class +import Control.Applicative import Csound.Dynamic -import Csound.Typed.Types +import Csound.Typed.Types.Prim import Csound.Typed.GlobalState import qualified Csound.Typed.GlobalState.Elements as E(adsr140Plugin) diff --git a/src/Csound/Typed/Plugins/Audaciouseq.hs b/src/Csound/Typed/Plugins/Audaciouseq.hs --- a/src/Csound/Typed/Plugins/Audaciouseq.hs +++ b/src/Csound/Typed/Plugins/Audaciouseq.hs @@ -4,6 +4,7 @@ import Data.Boolean import Control.Monad.Trans.Class +import Control.Applicative import Csound.Dynamic diff --git a/src/Csound/Typed/Plugins/Diode.hs b/src/Csound/Typed/Plugins/Diode.hs --- a/src/Csound/Typed/Plugins/Diode.hs +++ b/src/Csound/Typed/Plugins/Diode.hs @@ -4,6 +4,7 @@ import Data.Boolean import Control.Monad.Trans.Class +import Control.Applicative import Csound.Dynamic diff --git a/src/Csound/Typed/Plugins/Iain.hs b/src/Csound/Typed/Plugins/Iain.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Plugins/Iain.hs @@ -0,0 +1,313 @@ +module Csound.Typed.Plugins.Iain( + pitchShifterDelay, + fxAnalogDelay, fxDistortion, fxEnvelopeFollower, fxFlanger, fxFreqShifter, fxLoFi, + fxPanTrem, fxMonoTrem, fxPhaser, fxPitchShifter, fxReverse, fxRingModulator, fxChorus2, fxPingPong +) where + +import Data.Boolean +import Control.Monad.Trans.Class +import Control.Applicative + +import Csound.Dynamic + +import Csound.Typed.Types +import Csound.Typed.GlobalState +import qualified Csound.Typed.GlobalState.Elements as E(pitchShifterDelayPlugin, + analogDelayPlugin, distortionPlugin, envelopeFolollowerPlugin, flangerPlugin, freqShifterPlugin, + loFiPlugin, panTremPlugin, monoTremPlugin, phaserPlugin, pitchShifterPlugin, reversePlugin, ringModulatorPlugin, stChorusPlugin, stereoPingPongDelayPlugin) + +pitchShifterDelay :: D -> (Sig, Sig) -> Sig -> Sig -> Sig -> Sig +pitchShifterDelay imaxdlt (fb1, fb2) kdel ktrans ain = csdPitchShifterDelay ain ktrans kdel fb1 fb2 imaxdlt + +-- | PitchShifterDelay +-- ; ---------------- +-- ; A pitch shifter effect that employs delay lines +-- ; +-- ; aout PitchShifterDelay ain,ktrans,kdlt,kFB1,kFB2,imaxdlt +--; +--; Initialisation +--; -------------- +--; imaxdlt -- maximum delay time (kdlt should not exceed this value) +--; +--; Performance +--; ----------- +--; ain -- input audio to be pitch shifted +--; ktrans -- pitch transposition (in semitones) +--; kdlt -- delay time employed by the pitch shifter effect (should be within the range ksmps/sr and imaxdlt) +--; kFB1 -- feedback using method 1 (output from delay taps are fed back directly into their own buffers before enveloping and mixing) +--; kFB2 -- feedback using method 2 (enveloped and mixed output from both taps is fed back into both buffers) +-- +-- opcode PitchShifterDelay,a,akkkki +csdPitchShifterDelay :: Sig -> Sig -> Sig -> Sig -> Sig -> D -> Sig +csdPitchShifterDelay ain ktrans kdlt kFB1 kFB2 imaxdlt = fromGE $ do + addUdoPlugin E.pitchShifterDelayPlugin + f <$> toGE ain <*> toGE ktrans <*> toGE kdlt <*> toGE kFB1 <*> toGE kFB2 <*> toGE imaxdlt + where f ain ktrans kdlt kFB1 kFB2 imaxdlt = opcs "PitchShifterDelay" [(Ar, [Ar, Kr, Kr, Kr, Kr, Ir])] [ain, ktrans, kdlt, kFB1, kFB2, imaxdlt] + +-------------------------------------------------------- +-- multi fx + +fxAnalogDelay :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig +fxAnalogDelay kmix ktime kfback ktone ain = csdAnalogDelay ain kmix ktime kfback ktone + +-- ; AnalogDelay +-- ; ---------------- +-- ; A analog style delay with signal degradation and saturation options +-- ; +-- ; aout AnalogDelay ain,kmix,ktime,kfback,ktone +-- ; +-- ; Performance +-- ; ----------- +-- ; ain -- input audio to which the flanging effect will be applied +-- ; kmix -- dry / wet mix of the output signal (range 0 to 1) +-- ; ktime -- delay time of the effect in seconds +-- ; kfback -- control of the amount of output signal fed back into the input of the effect (exceeding 1 (100%) is possible and will result in saturation clipping effects) +-- ; ktone -- control of the amount of output signal fed back into the input of the effect (range 0 to 1) +csdAnalogDelay :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig +csdAnalogDelay ain kmix ktime kfback ktone = fromGE $ do + addUdoPlugin E.analogDelayPlugin + f <$> toGE ain <*> toGE kmix <*> toGE ktime <*> toGE kfback <*> toGE ktone + where f ain kmix ktime kfback ktone = opcs "AnalogDelay" [(Ar,[Ar,Kr,Kr,Kr,Kr])] [ain, kmix, ktime, kfback, ktone] + +fxDistortion :: Sig -> Sig -> Sig -> Sig -> Sig +fxDistortion klevel kdrive ktone ain = csdDistortion ain klevel kdrive ktone + +-- ; Distortion +-- ; ---------------- +-- ; A distortion effect offering stomp-box-like controls +-- ; +-- ; aout Distortion ain,klevel,kdrive,ktone +-- ; +-- ; Performance +-- ; ----------- +-- ; ain -- input audio to be distorted +-- ; klevel -- output level of the effect (range: 0 to 1) +-- ; kdrive -- intensity of the distortion effect (range: 0 to 1) +-- ; ktone -- tone of a lowpass filter (range: 0 to 1) +csdDistortion :: Sig -> Sig -> Sig -> Sig -> Sig +csdDistortion ain klevel kdrive ktone = fromGE $ do + addUdoPlugin E.distortionPlugin + f <$> toGE ain <*> toGE klevel <*> toGE kdrive <*> toGE ktone + where f ain klevel kdrive ktone = opcs "Distortion" [(Ar,[Ar,Kr,Kr,Kr])] [ain, klevel, kdrive, ktone] + + +fxEnvelopeFollower :: Sig -> Sig -> Sig -> Sig -> Sig +fxEnvelopeFollower ksens kfreq kres ain = csdEnvelopeFollower ain ksens kfreq kres + +-- ; EnvelopeFollower +-- ; ---------------- +-- ; A dynamic envelope following resonant lowpass filter +-- ; +-- ; aout EnvelopeFollower ain,ksens,kfreq,kres +-- ; +-- ; Performance +-- ; ----------- +-- ; ain -- input audio to be filtered +-- ; ksens -- sensitivity of the envelope follower (suggested range: 0 to 1) +-- ; kfreq -- base frequency of the filter before modulation by the input dynamics (range: 0 to 1) +-- ; kres -- resonance of the lowpass filter (suggested range: 0 to 0.99) +csdEnvelopeFollower :: Sig -> Sig -> Sig -> Sig -> Sig +csdEnvelopeFollower ain ksens kfreq kres = fromGE $ do + addUdoPlugin E.envelopeFolollowerPlugin + f <$> toGE ain <*> toGE ksens <*> toGE kfreq <*> toGE kres + where f ain ksens kfreq kres = opcs "EnvelopeFollower" [(Ar,[Ar,Kr,Kr,Kr])] [ain, ksens, kfreq, kres] + +-- ; Flanger +-- ; ---------------- +-- ; A flanger effect following the typical design of a so called 'stomp box' +-- ; +-- ; aout Flanger ain,krate,kdepth,kdelay,kfback +-- ; +-- ; Performance +-- ; ----------- +-- ; ain -- input audio to which the flanging effect will be applied +-- ; krate -- rate control of the lfo of the effect *NOT IN HERTZ* (range 0 to 1) +-- ; kdepth -- depth of the lfo of the effect (range 0 to 1) +-- ; kdelay -- static delay offset of the flanging effect (range 0 to 1) +-- ; kfback -- feedback and therefore intensity of the effect (range 0 to 1) +fxFlanger :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig +fxFlanger krate kdepth kdelay kfback ain = fromGE $ do + addUdoPlugin E.flangerPlugin + f <$> toGE ain <*> toGE krate <*> toGE kdepth <*> toGE kdelay <*> toGE kfback + where f ain krate kdepth kdelay kfback = opcs "Flanger" [(Ar,[Ar,Kr,Kr,Kr,Kr])] [ain, krate, kdepth, kdelay, kfback] + + +-- ; FreqShifter +-- ; ---------------- +-- ; A frequency shifter effect using the hilbert filter +-- ; +-- ; aout FreqShifter adry,kmix,kfreq,kmult,kfback +-- ; +-- ; Performance +-- ; ----------- +-- ; adry -- input audio to be frequency shifted +-- ; kmix -- dry / wet mix of the output signal (range 0 to 1) +-- ; kfreq -- frequency of frequency shifter effect (suggested range -1000 to 1000) +-- ; kmult -- multiplier of frequency value for fine tuning control (suggested range -1 to 1) +-- ; kfback -- control of the amount of output signal fed back into the input of the effect (suggested range 0 to 1) +fxFreqShifter :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig +fxFreqShifter kmix kfreq kmult kfback adry = fromGE $ do + addUdoPlugin E.freqShifterPlugin + f <$> toGE adry <*> toGE kmix <*> toGE kfreq <*> toGE kmult <*> toGE kfback + where f adry kmix kfreq kmult kfback = opcs "FreqShifter" [(Ar,[Ar,Kr,Kr,Kr,Kr])] [adry, kmix, kfreq, kmult, kfback] + + +-- ; LoFi +-- ; ---------------- +-- ; 'Low Fidelity' distorting effects of bit reduction and downsampling (foldover) +-- ; +-- ; aout LoFi ain,kbits,kfold +-- ; +-- ; Performance +-- ; ----------- +-- ; ain -- input audio to have low fidelity distortion effects applied +-- ; kbits -- bit depth reduction (suggested range 0 to 0.6) +-- ; kfold -- amount of foldover (range 0 to 1) +fxLoFi :: Sig -> Sig -> Sig -> Sig +fxLoFi kbits kfold ain = fromGE $ do + addUdoPlugin E.loFiPlugin + f <$> toGE ain <*> toGE kbits <*> toGE kfold + where f ain kbits kfold = opcs "LoFi" [(Ar,[Ar,Kr,Kr])] [ain, kbits, kfold] + +-- ; PanTrem +-- ; ---------------- +-- ; Auto-panning and tremolo effects +-- ; +-- ; aout1,aout2 PanTrem ainL,ainR,,krate,kdepth,kmode,kwave +-- ; +-- ; Performance +-- ; ----------- +-- ; ainL -- first/left input audio +-- ; ainR -- second/right input audio +-- ; krate -- rate control of the lfo of the effect *NOT IN HERTZ* (range 0 to 1) +-- ; kdepth -- depth of the lfo of the effect (range 0 to 1) +-- ; kmode -- mode of the effect (0=auto-panning 1=tremolo) +-- ; kwave -- waveform used by the lfo (0=sine 1=triangle 2=square) +fxPanTrem :: Sig -> Sig -> Sig -> Sig -> Sig2 -> Sig2 +fxPanTrem krate kdepth kmode kwave (ainL, ainR) = toTuple $ do + addUdoPlugin E.panTremPlugin + f <$> toGE ainL <*> toGE ainR <*> toGE krate <*> toGE kdepth <*> toGE kmode <*> toGE kwave + where f ainL ainR krate kdepth kmode kwave = ($ 2) $ mopcs "PanTrem" ([Ar,Ar], [Ar,Ar, Kr,Kr,Kr,Kr]) [ainL, ainR, krate, kdepth, kmode, kwave] + +-- ; Tremolo +-- ; ---------------- +-- ; Tremolo effect +-- ; +-- ; aout MonoTrem ain,krate,kdepth,kwave +-- ; +-- ; Performance +-- ; ----------- +-- ; ain -- input audio +-- ; krate -- rate control of the lfo of the effect *NOT IN HERTZ* (range 0 to 1) +-- ; kdepth -- depth of the lfo of the effect (range 0 to 1) +-- ; kwave -- waveform used by the lfo (0=sine 1=triangle 2=square) +fxMonoTrem :: Sig -> Sig -> Sig -> Sig -> Sig +fxMonoTrem krate kdepth kwave ain = fromGE $ do + addUdoPlugin E.monoTremPlugin + f <$> toGE ain <*> toGE krate <*> toGE kdepth <*> toGE kwave + where f ain krate kdepth kwave = opcs "MonoTrem" [(Ar, [Ar,Kr,Kr,Kr])] [ain, krate, kdepth, kwave] + +-- ; Phaser +-- ; ---------------- +-- ; An phase shifting effect that mimics the design of a so called 'stomp box' +-- ; +-- ; aout Phaser ain,krate,kdepth,kfreq,kfback +-- ; +-- ; Performance +-- ; ----------- +-- ; ain -- input audio to be pitch shifted +-- ; krate -- rate of lfo of the effect (range 0 to 1) +-- ; kdepth -- depth of lfo of the effect (range 0 to 1) +-- ; kfreq -- centre frequency of the phase shifting effect in octaves (suggested range 6 to 11) +-- ; kfback -- feedback and therefore intensity of the effect (range 0 to 1) +fxPhaser :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig +fxPhaser krate kdepth kfreq kfback ain = fromGE $ do + addUdoPlugin E.phaserPlugin + f <$> toGE ain <*> toGE krate <*> toGE kdepth <*> toGE kfreq <*> toGE kfback + where f ain krate kdepth kfreq kfback = opcs "Phaser" [(Ar,[Ar,Kr,Kr,Kr,Kr])] [ain, krate, kdepth, kfreq, kfback] + +-- ; PitchShifter +-- ; ------------ +-- ; A pitch shifter effect based on FFT technology +-- ; +-- ; aout PitchShifter ain,kmix,kpitch,kfine,kfback +-- ; +-- ; Performance +-- ; ----------- +-- ; ain -- input audio to be pitch shifted +-- ; kmix -- dry / wet mix of the output signal (range 0 to 1) +-- ; kscal -- pitch ratio +-- #### ; kpitch -- pitch shifting interval in thousands of a semitone (suggested range -0.012 to 0.012) +-- #### ; kfine -- fine control of pitch shifting interval in octaves (range -1/12 to 1/12) +-- ; kfback -- control of the amount of output signal fed back into the input of the effect (suggested range 0 to 1) +fxPitchShifter :: D -> Sig -> Sig -> Sig -> Sig -> Sig +fxPitchShifter ifftsize kmix kscal kfback ain = fromGE $ do + addUdoPlugin E.pitchShifterPlugin + f <$> toGE ain <*> toGE kmix <*> toGE kscal <*> toGE kfback <*> toGE ifftsize + where f ain kmix kscal kfback ifftsize = opcs "PitchShifter" [(Ar,[Ar,Kr,Kr,Kr,Ir])] [ain, kmix, kscal, kfback, ifftsize] + + +-- ; Reverse +-- ; ---------------- +-- ; An effect that reverses an audio stream in chunks +-- ; +-- ; aout Reverse ain,ktime +-- ; +-- ; Performance +-- ; ----------- +-- ; ain -- input audio to be reversed +-- ; ktime -- time duration of each chunk (suggested range: 0.3 to 2)-- +fxReverse :: Sig -> Sig -> Sig +fxReverse ktime ain = fromGE $ do + addUdoPlugin E.reversePlugin + f <$> toGE ain <*> toGE ktime + where f ain ktime = opcs "Reverse" [(Ar,[Ar,Kr])] [ain, ktime] + +-- ; RingModulator +-- ; ---------------- +-- ; An ring modulating effect with an envelope follower +-- ; +-- ; aout RingModulator ain,kmix,kfreq,kenv +-- ; +-- ; Performance +-- ; ----------- +-- ; ain -- input audio to be pitch shifted +-- ; kmix -- dry / wet mix of the output signal (range 0 to 1) +-- ; kfreq -- frequency of thew ring modulator *NOT IN HERTZ* (range 0 to 1) +-- ; kenv -- amount of dynamic envelope following modulation of frequency (range 0 to 1) +fxRingModulator :: Sig -> Sig -> Sig -> Sig -> Sig +fxRingModulator kmix kfreq kenv ain = fromGE $ do + addUdoPlugin E.ringModulatorPlugin + f <$> toGE ain <*> toGE kmix <*> toGE kfreq <*> toGE kenv + where f ain kmix kfreq kenv = opcs "RingModulator" [(Ar,[Ar,Kr,Kr,Kr])] [ain, kmix, kfreq, kenv] + +-- ; StChorus +-- ; ---------------- +-- ; A stereo chorus effect +-- ; +-- ; aout StChorus ainL,ainR,krate,kdepth,kwidth +-- ; +-- ; Performance +-- ; ----------- +-- ; ainL -- first/left input audio +-- ; ainR -- second/right input audio +-- ; krate -- rate control of the lfo of the effect *NOT IN HERTZ* (range 0 to 1) +-- ; kdepth -- depth of the lfo of the effect (range 0 to 1) +-- ; kwidth -- width of stereo widening (range 0 to 1) +fxChorus2 :: Sig -> Sig -> Sig -> Sig2 -> Sig2 +fxChorus2 krate kdepth kwidth (ainL, ainR) = toTuple $ do + addUdoPlugin E.stChorusPlugin + f <$> toGE ainL <*> toGE ainR <*> toGE krate <*> toGE kdepth <*> toGE kwidth + where f ainL ainR krate kdepth kwidth = ($ 2) $ mopcs "StChorus" ([Ar,Ar], [Ar,Ar,Kr,Kr,Kr]) [ainL, ainR, krate, kdepth, kwidth] + +-- aInL, aInR, kdelayTime, kFeedback, kMix, iMaxDelayTime xin + +-- | Stereo ping-pong delay effect +-- +-- > fxPingPong maxDelayTime kmix width tone time feedback (ainL, ainR) +fxPingPong :: D -> Sig -> Sig -> Sig -> Sig -> Sig -> Sig2 -> Sig2 +fxPingPong iMaxDelTime kmix kwidth ktone ktime kfeedback (ainL, ainR) = toTuple $ do + addUdoPlugin E.stereoPingPongDelayPlugin + f <$> toGE ainL <*> toGE ainR <*> toGE ktime <*> toGE kfeedback <*> toGE kmix <*> toGE kwidth <*> toGE ktone <*> toGE iMaxDelTime + where f ainL ainR ktime kfeedback kmix kwidth ktone iMaxDelTime = ($ 2) $ mopcs "StereoPingPongDelay" ([Ar,Ar], [Ar,Ar,Kr,Kr,Kr,Kr,Kr,Ir]) [ainL, ainR, ktime, kfeedback, kmix, kwidth, ktone, iMaxDelTime] + diff --git a/src/Csound/Typed/Plugins/Korg35.hs b/src/Csound/Typed/Plugins/Korg35.hs --- a/src/Csound/Typed/Plugins/Korg35.hs +++ b/src/Csound/Typed/Plugins/Korg35.hs @@ -4,6 +4,7 @@ import Data.Boolean import Control.Monad.Trans.Class +import Control.Applicative import Csound.Dynamic diff --git a/src/Csound/Typed/Plugins/SolinaChorus.hs b/src/Csound/Typed/Plugins/SolinaChorus.hs --- a/src/Csound/Typed/Plugins/SolinaChorus.hs +++ b/src/Csound/Typed/Plugins/SolinaChorus.hs @@ -4,6 +4,7 @@ import Data.Boolean import Control.Monad.Trans.Class +import Control.Applicative import Csound.Dynamic diff --git a/src/Csound/Typed/Plugins/TabQueue.hs b/src/Csound/Typed/Plugins/TabQueue.hs --- a/src/Csound/Typed/Plugins/TabQueue.hs +++ b/src/Csound/Typed/Plugins/TabQueue.hs @@ -4,6 +4,7 @@ import Data.Boolean import Control.Monad.Trans.Class +import Control.Applicative import Csound.Dynamic diff --git a/src/Csound/Typed/Plugins/Utilities.hs b/src/Csound/Typed/Plugins/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Plugins/Utilities.hs @@ -0,0 +1,23 @@ +module Csound.Typed.Plugins.Utilities( + delay1k +) where + +import Data.Boolean +import Control.Monad.Trans.Class +import Control.Applicative + +import Csound.Dynamic + +import Csound.Typed.Types.Prim +import Csound.Typed.GlobalState +import qualified Csound.Typed.GlobalState.Elements as E(delay1kPlugin) + + +------------------------------------------------------------------------------- + +-- | Delay a control signal by single sample. +delay1k :: Sig -> Sig +delay1k ain = fromGE $ do + addUdoPlugin E.delay1kPlugin + f <$> toGE ain + where f ain = opcs "Delay1k" [(Kr, [Kr])] [ain] diff --git a/src/Csound/Typed/Plugins/Zdf.hs b/src/Csound/Typed/Plugins/Zdf.hs --- a/src/Csound/Typed/Plugins/Zdf.hs +++ b/src/Csound/Typed/Plugins/Zdf.hs @@ -18,6 +18,7 @@ import Data.Boolean import Control.Monad.Trans.Class +import Control.Applicative import Csound.Dynamic diff --git a/src/Csound/Typed/Plugins/ZeroDelayConvolution.hs b/src/Csound/Typed/Plugins/ZeroDelayConvolution.hs --- a/src/Csound/Typed/Plugins/ZeroDelayConvolution.hs +++ b/src/Csound/Typed/Plugins/ZeroDelayConvolution.hs @@ -5,6 +5,7 @@ import Data.Boolean import Data.Default import Control.Monad.Trans.Class +import Control.Applicative import Csound.Dynamic diff --git a/src/Csound/Typed/Render.hs b/src/Csound/Typed/Render.hs --- a/src/Csound/Typed/Render.hs +++ b/src/Csound/Typed/Render.hs @@ -15,7 +15,9 @@ import Data.Ord import Data.List(sortBy, groupBy) import qualified Data.IntMap as IM +import Control.Monad import Control.Monad.IO.Class +import Control.Monad.Trans.Class import Text.PrettyPrint.Leijen(displayS, renderPretty) @@ -98,6 +100,8 @@ getInstr0 :: Maybe Int -> Int -> Options -> Dep () -> History -> Dep () getInstr0 mnchnls_i nchnls opt udos hist = do + macroses + defaultScaleUI <- fmap defScaleUI $ lift getOptions globalConstants midiAssigns midiInitCtrls @@ -106,8 +110,9 @@ userInstr0 hist chnUpdateUdo udos - sf2 - guiStmt $ getPanels hist + sf2 + jackos + guiStmt defaultScaleUI $ getPanels hist where globalConstants = do setSr $ defSampleRate opt @@ -126,6 +131,14 @@ where getName = sfName . fst phi as = (getName $ head as, fmap (\(sf, index) -> (sfBank sf, sfProgram sf, index)) as) + + macroses = forM_ (fmap snd $ M.toList $ macrosInits hist) $ \x -> case x of + MacrosInitDouble name value -> initMacrosDouble name value + MacrosInitString name value -> initMacrosString name value + MacrosInitInt name value -> initMacrosInt name value + + jackos = maybe (return ()) (verbatim . renderJacko) $ csdJacko opt + reactOnMidi :: History -> Flags -> Flags reactOnMidi h flags diff --git a/src/Csound/Typed/Types.hs b/src/Csound/Typed/Types.hs --- a/src/Csound/Typed/Types.hs +++ b/src/Csound/Typed/Types.hs @@ -12,6 +12,15 @@ -- * Events module Csound.Typed.Types.Evt, + -- * Arrays + module Csound.Typed.Types.Array, + + -- * Arguments for monophonic synths + module Csound.Typed.Types.MonoArg, + + -- * Signal space (generic signal transformers) + module Csound.Typed.Types.SigSpace, + -- * Tab helpers getNextGlobalGenId ) where @@ -22,6 +31,9 @@ import Csound.Typed.Types.Tuple import Csound.Typed.Types.Evt import Csound.Typed.Types.Lift +import Csound.Typed.Types.Array +import Csound.Typed.Types.MonoArg +import Csound.Typed.Types.SigSpace import Csound.Typed.GlobalState(evalSE, SE, geToSe) diff --git a/src/Csound/Typed/Types/Array.hs b/src/Csound/Typed/Types/Array.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Types/Array.hs @@ -0,0 +1,612 @@ +{-# Language FlexibleInstances, ScopedTypeVariables #-} +module Csound.Typed.Types.Array( + Arr(..), + newLocalArr, newGlobalArr, newLocalCtrlArr, newGlobalCtrlArr, + fillLocalArr, fillGlobalArr, fillLocalCtrlArr, fillGlobalCtrlArr, + readArr, writeArr, writeInitArr, modifyArr, mixArr, + -- * Misc functions to help the type inverence + Arr1, DArr1, Arr2, DArr2, Arr3, DArr3, + arr1, darr1, arr2, darr2, arr3, darr3, + + -- * Array opcodes + maparrayNew, lenarray, copyf2array, copya2ftab, minarray, maxarray, sumarray, + scalearray, slicearrayNew, + + maparrayCopy, slicearrayCopy, + + -- * Spectral opcodes + SpecArr, + + fftNew, fftinvNew, rfftNew, rifftNew, pvs2tab, tab2pvs, cmplxprodNew, + rect2polNew, pol2rectNew, pol2rect2New, windowArrayNew, + r2cNew, c2rNew, magsArrayNew, phsArrayNew, + + fftCopy, fftinvCopy, rfftCopy, rifftCopy, cmplxprodCopy, + rect2polCopy, pol2rectCopy, pol2rect2Copy, windowArrayCopy, + r2cCopy, c2rCopy, magsArrayCopy, phsArrayCopy +) where + + +import Control.Monad +import Control.Monad.Trans.Class + +import Csound.Dynamic hiding (writeArr, writeInitArr, readArr, newLocalArrVar, newTmpArrVar, int) +import qualified Csound.Dynamic as D + +import Csound.Typed.Types.Prim +import Csound.Typed.Types.Tuple +import Csound.Typed.GlobalState.SE +import Csound.Typed.GlobalState.GE + +-- | An array with single signal index. +type Arr1 a = Arr Sig a + +-- | An array with single constant index. +type DArr1 a = Arr D a + + +-- | A matrix (2D array) with signal index. +type Arr2 a = Arr (Sig, Sig) a + +-- | A matrix (2D array) with constant index. +type DArr2 a = Arr (D, D) a + +-- | A 3D array with signal index. +type Arr3 a = Arr (Sig, Sig, Sig) a + +-- | A 3D array with constant index. +type DArr3 a = Arr (D, D, D) a + +-- | Function to help the type inference. +arr1 :: SE (Arr Sig a) -> SE (Arr Sig a) +arr1 = id + +-- | Function to help the type inference. +darr1 :: SE (Arr D a) -> SE (Arr D a) +darr1 = id + +-- | Function to help the type inference. +arr2 :: SE (Arr (Sig,Sig) a) -> SE (Arr (Sig,Sig) a) +arr2 = id + +-- | Function to help the type inference. +darr2 :: SE (Arr (D,D) a) -> SE (Arr (D,D) a) +darr2 = id + +-- | Function to help the type inference. +arr3 :: SE (Arr (Sig,Sig,Sig) a) -> SE (Arr (Sig,Sig,Sig) a) +arr3 = id + +-- | Function to help the type inference. +darr3 :: SE (Arr (D,D,D) a) -> SE (Arr (D,D,D) a) +darr3 = id + +-- | Arrays. The array data type is parametrized with type of the index and the type of the value. +-- Note that the data tpyes for indices and values can be tuples. +newtype Arr ix a = Arr { unArr :: [Var] } + +newArrBy :: forall ix a . (Tuple a, Tuple ix) => (Rate -> GE [E] -> SE Var) -> [D] -> SE (Arr ix a) +newArrBy mkVar sizes = + fmap Arr $ mapM (\x -> mkVar x (mapM toGE sizes)) (tupleRates $ (undefined :: a)) + +getIndices :: Tuple ix => [Int] -> [ix] +getIndices xs = fmap (toTuple . return . fmap D.int) $ getIntIndices xs + +getIntIndices :: [Int] -> [[Int]] +getIntIndices xs = fmap reverse $ foldl go [] xs + where + go :: [[Int]] -> Int -> [[Int]] + go res n = case res of + [] -> fmap (\x -> [x]) ix + xs -> [ first : rest | first <- ix, rest <- xs ] + where ix = [0 .. n - 1] + +fillArrBy :: (Tuple a, Tuple ix) => (Rate -> GE [E] -> SE Var) -> [Int] -> [a] -> SE (Arr ix a) +fillArrBy mkVar sizes inits = do + arr <- newArrBy mkVar (fmap int sizes) + zipWithM_ (writeInitArr arr) (getIndices sizes) inits + return arr + +-- | Creates an array that is local to the body of Csound instrument where it's defined. +-- The array contains audio signals. +-- +-- > newLocalArr sizes +newLocalArr :: (Tuple a, Tuple ix) => [D] -> SE (Arr ix a) +newLocalArr = newArrBy newLocalArrVar + +-- | Creates a global array. The array contains audio signals. +-- +-- > newGlobalArr sizes +newGlobalArr :: (Tuple a, Tuple ix) => [D] -> SE (Arr ix a) +newGlobalArr = newArrBy newGlobalArrVar + +-- | Creates an array that is local to the body of Csound instrument where it's defined. +-- The array contains control signals. +-- +-- > newLocalCtrlArr sizes +newLocalCtrlArr :: (Tuple a, Tuple ix) => [D] -> SE (Arr ix a) +newLocalCtrlArr = newArrBy newLocalCtrlArrVar + +-- | Creates a global array. The array contains control signals. +-- +-- > newGlobalCtrlArr sizes +newGlobalCtrlArr :: (Tuple a, Tuple ix) => [D] -> SE (Arr ix a) +newGlobalCtrlArr = newArrBy newGlobalCtrlArrVar + +-- | Creates an array that is local to the body of Csound instrument where it's defined. +-- The array contains audio signals. It fills the array from the list of values (the last argument). +-- +-- > fillLocalArr sizes initValues = ... +fillLocalArr :: (Tuple a, Tuple ix) => [Int] -> [a] -> SE (Arr ix a) +fillLocalArr = fillArrBy newLocalArrVar + +-- | Creates a global array. The array contains audio signals. It fills the array from the list of values (the last argument). +-- +-- > fillGlobalArr sizes initValues = ... +fillGlobalArr :: (Tuple a, Tuple ix) => [Int] -> [a] -> SE (Arr ix a) +fillGlobalArr = fillArrBy newGlobalArrVar + +-- | Creates an array that is local to the body of Csound instrument where it's defined. +-- The array contains control signals. It fills the array from the list of values (the last argument). +-- +-- > fillLocalCtrlArr sizes initValues = ... +fillLocalCtrlArr :: (Tuple a, Tuple ix) => [Int] -> [a] -> SE (Arr ix a) +fillLocalCtrlArr = fillArrBy newLocalCtrlArrVar + +-- | Creates a global array. The array contains control signals. It fills the array from the list of values (the last argument). +-- +-- > fillGlobalCtrlArr sizes initValues = ... +fillGlobalCtrlArr :: (Tuple a, Tuple ix) => [Int] -> [a] -> SE (Arr ix a) +fillGlobalCtrlArr = fillArrBy newGlobalCtrlArrVar + +newLocalCtrlArrVar = newLocalArrVar . toCtrlRate +newGlobalCtrlArrVar = newGlobalArrVar . toCtrlRate + +toCtrlRate x = case x of + Ar -> Kr + Kr -> Ir + _ -> x + +-- | Reads data from the array. +readArr :: (Tuple a, Tuple ix) => Arr ix a -> ix -> SE a +readArr (Arr vars) ixs = fmap (toTuple . return) $ SE $ hideGEinDep $ do + ixsExp <- fromTuple ixs + return $ mapM (\v -> read v ixsExp) vars + where + read :: Var -> [E] -> Dep E + read = D.readArr + +-- | Writes data to the array. +writeArr :: (Tuple ix, Tuple a) => Arr ix a -> ix -> a -> SE () +writeArr (Arr vars) ixs b = SE $ hideGEinDep $ do + ixsExp <- fromTuple ixs + bsExp <- fromTuple b + return $ zipWithM_ (\var value -> write var ixsExp value) vars bsExp + where + write :: Var -> [E] -> E -> Dep () + write = D.writeArr + +-- | Writes data to the array. +writeInitArr :: (Tuple ix, Tuple a) => Arr ix a -> ix -> a -> SE () +writeInitArr (Arr vars) ixs b = SE $ hideGEinDep $ do + ixsExp <- fromTuple ixs + bsExp <- fromTuple b + return $ zipWithM_ (\var value -> write var ixsExp value) vars bsExp + where + write :: Var -> [E] -> E -> Dep () + write = D.writeInitArr + +-- | Updates the value of the array with pure function. +modifyArr :: (Tuple a, Tuple ix) => Arr ix a -> ix -> (a -> a) -> SE () +modifyArr ref ixs f = do + value <- readArr ref ixs + writeArr ref ixs (f value) + +mixArr :: (Tuple ix, Tuple a, Num a) => Arr ix a -> ix -> a -> SE () +mixArr ref ixs a = modifyArr ref ixs (+ a) + +----------------------------------------------------- +-- opcodes with array allocation + +-- | Multiplies two numeric arrays and save the result in the third array. +mulArrayNew :: (Tuple b, Num b) => Arr a b -> Arr a b -> SE (Arr a b) +mulArrayNew = binOp "*" + +-- | Summs two numeric arrays and save the result in the third array. +addArrayNew :: (Tuple b, Num b) => Arr a b -> Arr a b -> SE (Arr a b) +addArrayNew = binOp "+" + +-- | Substraction of two numeric arrays and save the result in the third array. +subArrayNew :: (Tuple b, Num b) => Arr a b -> Arr a b -> SE (Arr a b) +subArrayNew = binOp "-" + +-- | Division of two numeric arrays and save the result in the third array. +divArrayNew :: (Tuple b, Num b) => Arr a b -> Arr a b -> SE (Arr a b) +divArrayNew = binOp "/" + +lenarray :: SigOrD c => Arr a b -> c +lenarray (Arr vs) = fromGE $ return $ f (inlineVar $ head vs) + where f a = opcs "lenarray" [(Kr, [Xr, Ir]), (Ir, [Xr, Ir])] [a] + +-- | Copies table to array. +copyf2array :: Arr Sig Sig -> Tab -> SE () +copyf2array (Arr vs) t = SE $ hideGEinDep $ do + tabExp <- toGE t + return $ depT_ $ opcs "copyf2array" [(Xr, [varRate $ head vs, Ir])] [inlineVar $ head vs, tabExp] + +-- | Copies array to table. +copya2ftab :: Arr Sig Sig -> Tab -> SE () +copya2ftab (Arr vs) t = SE $ hideGEinDep $ do + tabExp <- toGE t + return $ depT_ $ opcs "copya2ftab" [(Xr, [varRate $ head vs, Ir])] [inlineVar $ head vs, tabExp] + +-- | Mapps all values in the array with the function. +-- +-- Csound docs: +maparrayNew :: Arr a b -> Str -> SE (Arr a b) +maparrayNew (Arr vs) str = SE $ fmap Arr $ hideGEinDep $ do + strExp <- toGE str + return $ mapM (\var -> go var strExp) vs + where + go var strExp = do + outVar <- unSE $ newTmpArrVar (varRate var) + opcsArr isArrayInit outVar "slicearray" idRate [inlineVar var, strExp] + return $ outVar + + idRate = fmap (\rate -> (rate, [rate, Ir, Ir])) [Ir, Kr, Ar] + +-- | Finds a minimum value of the array. +minarray :: (Tuple b, Num b) => Arr a b -> SE b +minarray = extractArray "minarray" + +-- | Finds a maximum value of the array. +maxarray :: (Tuple b, Num b) => Arr a b -> SE b +maxarray = extractArray "maxarray" + +-- | Summs all elements in the array. +sumarray :: (Tuple b, Num b) => Arr a b -> SE b +sumarray = extractArray "sumarray" + +-- | Scales all elements in the array. +scalearray :: (Tuple b, Num b) => Arr a b -> (b, b) -> SE () +scalearray (Arr vs) (a, b) = SE $ hideGEinDep $ do + aExps <- fromTuple a + bExps <- fromTuple b + return $ zipWithM_ (\var (aExp, bExp) -> go var (aExp, bExp)) vs (zip aExps bExps) + where + go v (aExp, bExp) = + depT_ $ opcs "copyf2array" [(Xr, [varRate $ head vs, Ir])] [inlineVar $ head vs, aExp, bExp] + +-- | Creates a copy of some part of the given array +slicearrayNew :: Arr D a -> (D, D) -> SE (Arr D a) +slicearrayNew (Arr vs) (from, to) = SE $ fmap Arr $ hideGEinDep $ do + fromExp <- toGE from + toExp <- toGE to + return $ mapM (\var -> go var (fromExp, toExp)) vs + where + go var (from, to) = do + outVar <- unSE $ newTmpArrVar (varRate var) + opcsArr isArrayInit outVar "slicearray" idRate [inlineVar var, from, to] + return $ outVar + + idRate = fmap (\rate -> (rate, [rate, Ir, Ir])) [Ir, Kr, Ar] + +-- spectral opcodes + +-- | Spectral array. +type SpecArr = Arr Sig Sig + +-- | Complex-to-complex Fast Fourier Transform. +-- +-- csound docs: +fftNew :: SpecArr -> SE SpecArr +fftNew = convert "fft" + +-- | Complex-to-complex Inverse Fast Fourier Transform. +-- +-- csound docs: +fftinvNew :: SpecArr -> SE SpecArr +fftinvNew = convert "fftinvi" + +-- | Fast Fourier Transform of a real-value array. +-- +-- csound docs: +rfftNew :: SpecArr -> SE SpecArr +rfftNew = convert "rfft" + +-- | Complex-to-real Inverse Fast Fourier Transform. +-- +-- csound docs: +rifftNew :: SpecArr -> SE SpecArr +rifftNew = convert "rifft" + +-- | Copies spectral data to k-rate arrays (or t-variables). Also known as pvs2array. +-- +-- csound docs: +pvs2tab :: SpecArr -> Spec -> SE Sig +pvs2tab = extractWith "pvs2tab" (Kr, [Xr, Fr]) + +-- | Copies spectral data from k-rate arrays (or t-variables.). Also known as pvsfromarray. +-- +-- csound docs: +tab2pvs :: SpecArr -> SE Spec +tab2pvs = extract1 Fr "tab2pvs" + +-- | Complex product of two arrays. +-- +-- > kout[] cmplxprod kin1[], kin2[] +-- +-- csound docs: +cmplxprodNew :: SpecArr -> SpecArr -> SE SpecArr +cmplxprodNew = convert2 "cmplxprod" + +-- | Rectangular to polar format conversion. +-- +-- > kout[] rect2pol kin[] +-- +-- csound docs: +rect2polNew :: SpecArr -> SE SpecArr +rect2polNew = convert "rect2pol" + +-- | Polar to rectangular format conversion. +-- +-- > kout[] pol2rect kin[] +-- +-- csound docs: +pol2rectNew :: SpecArr -> SE SpecArr +pol2rectNew = convert "pol2rect" + + +-- | Polar to rectangular format conversion. +-- +-- > kout[] pol2rect kmags[], kphs[] +-- +-- csound docs: +pol2rect2New :: SpecArr -> SpecArr -> SE SpecArr +pol2rect2New = convert2 "pol2rect" + +-- | Applies a window to an array. +-- +-- > kout[] window kin[][, koff, itype] +-- +-- csound docs: +windowArrayNew :: SpecArr -> SE SpecArr +windowArrayNew = convert "window" + +-- | Real to complex format conversion. +-- +-- > kout[] r2c kin[] +-- +-- csound docs: +r2cNew :: SpecArr -> SE SpecArr +r2cNew = convert "r2c" + +-- | Complex to real format conversion. +-- +-- > kout[] c2r kin[] +-- +-- csound docs: +c2rNew :: SpecArr -> SE SpecArr +c2rNew = convert "c2r" + +-- | Obtains the magnitudes of a complex-number array +-- +-- > kout[] mags kin[] +-- +-- csound docs: +magsArrayNew :: SpecArr -> SE SpecArr +magsArrayNew = convert "mags" + +-- | Obtains the phases of a complex-number array +-- +-- kout[] phs kin[] +-- +-- > csound docs: +phsArrayNew :: SpecArr -> SE SpecArr +phsArrayNew = convert "phs" + +----------------------------- + +isArrayInit = True +noArrayInit = False + +binOp :: String -> Arr a b -> Arr a b -> SE (Arr a b) +binOp name (Arr xs) (Arr ys) = fmap Arr $ zipWithM go xs ys + where + go x y = SE $ do + outVar <- unSE $ newTmpArrVar (varRate x) + infOprArr isArrayInit outVar name (inlineVar x) (inlineVar y) + return outVar + +convert :: String -> Arr a b -> SE (Arr a b) +convert name (Arr vars) = fmap Arr $ mapM go vars + where + go v = SE $ do + outVar <- unSE $ newTmpArrVar (varRate v) + opcsArr isArrayInit outVar name idRate1 [inlineVar v] + return outVar + + idRate1 = fmap (\r -> (r, [r])) [Kr, Ar, Ir, Sr, Fr] + +convert2 :: String -> Arr a b -> Arr a b -> SE (Arr a b) +convert2 name (Arr xs) (Arr ys) = fmap Arr $ zipWithM go xs ys + where + go x y = SE $ do + outVar <- unSE $ newTmpArrVar (varRate x) + opcsArr isArrayInit outVar name idRate2 [inlineVar x, inlineVar y] + return outVar + + idRate2 = fmap (\r -> (r, [r, r])) [Kr, Ar, Ir, Sr, Fr] + +extractArray :: (Tuple b) => String -> Arr a b -> SE b +extractArray name (Arr vs) = SE $ fmap (toTuple . return) $ mapM (f . inlineVar) vs + where f a = depT $ opcs name [(Xr, [Xr])] [a] + +extract1 :: (Tuple b, Tuple c) => Rate -> String -> Arr a b -> SE c +extract1 rate name (Arr vs) = SE $ fmap (toTuple . return) $ mapM (f . inlineVar) vs + where f a = depT $ opcs name [(rate, [Xr])] [a] + +extractWith :: (Tuple b, Tuple c, Tuple d) => String -> (Rate, [Rate]) -> Arr a b -> c -> SE d +extractWith name rates (Arr vs) arg = SE $ fmap (toTuple . return) $ hideGEinDep $ do + argExps <- fromTuple arg + return $ zipWithM (\var x -> f (inlineVar var) x) vs argExps + where f a b = depT $ opcs name [rates] [a, b] + +--------------------------------------------------- +-- opcodes with copy + +-- | Transforms the dta of the array and copies it to the second array. +maparrayCopy :: Arr a b -> Str -> Arr a b -> SE () +maparrayCopy (Arr vs) str (Arr outs) = SE $ hideGEinDep $ do + strExp <- toGE str + return $ zipWithM_ (\var outVar -> go var strExp outVar) vs outs + where + go var strExp outVar = opcsArr noArrayInit outVar "slicearray" idRate [inlineVar var, strExp] + idRate = fmap (\rate -> (rate, [rate, Ir, Ir])) [Ir, Kr, Ar] + +-- | Copies a part of array to another array. +slicearrayCopy :: Arr D a -> (D, D) -> Arr D a -> SE () +slicearrayCopy (Arr vs) (from, to) (Arr outs) = SE $ hideGEinDep $ do + fromExp <- toGE from + toExp <- toGE to + return $ zipWithM_ (\var outVar -> go var (fromExp, toExp) outVar) vs outs + where + go var (from, to) outVar = opcsArr noArrayInit outVar "slicearray" idRate [inlineVar var, from, to] + idRate = fmap (\rate -> (rate, [rate, Ir, Ir])) [Ir, Kr, Ar] + +-- | Multiplies two arrays and copies the result into third array. +mulArrayCopy :: (Tuple b, Num b) => Arr a b -> Arr a b -> Arr a b -> SE () +mulArrayCopy = binOpCopy "*" + +-- | Summs two arrays and copies the result into third array. +addArrayCopy :: (Tuple b, Num b) => Arr a b -> Arr a b -> Arr a b -> SE () +addArrayCopy = binOpCopy "+" + +-- | Substracts two arrays and copies the result into third array. +subArrayCopy :: (Tuple b, Num b) => Arr a b -> Arr a b -> Arr a b -> SE () +subArrayCopy = binOpCopy "-" + +-- | Divides two arrays and copies the result into third array. +divArrayCopy :: (Tuple b, Num b) => Arr a b -> Arr a b -> Arr a b -> SE () +divArrayCopy = binOpCopy "/" + +-- spectral opcodes + + +-- | Complex-to-complex Fast Fourier Transform. +-- +-- csound docs: +fftCopy :: SpecArr -> SpecArr -> SE () +fftCopy = convertCopy "fft" + +-- | Complex-to-complex Inverse Fast Fourier Transform. +-- +-- csound docs: +fftinvCopy :: SpecArr -> SpecArr -> SE () +fftinvCopy = convertCopy "fftinvi" + +-- | Fast Fourier Transform of a real-value array. +-- +-- csound docs: +rfftCopy :: SpecArr -> SpecArr -> SE () +rfftCopy = convertCopy "rfft" + +-- | Complex-to-real Inverse Fast Fourier Transform. +-- +-- csound docs: +rifftCopy :: SpecArr -> SpecArr -> SE () +rifftCopy = convertCopy "rifft" + + +-- | Complex product of two arrays. +-- +-- > kout[] cmplxprod kin1[], kin2[] +-- +-- csound docs: +cmplxprodCopy :: SpecArr -> SpecArr -> SpecArr -> SE () +cmplxprodCopy = convert2Copy "cmplxprod" + +-- | Rectangular to polar format conversion. +-- +-- > kout[] rect2pol kin[] +-- +-- csound docs: +rect2polCopy :: SpecArr -> SpecArr -> SE () +rect2polCopy = convertCopy "rect2pol" + +-- | Polar to rectangular format conversion. +-- +-- > kout[] pol2rect kin[] +-- +-- csound docs: +pol2rectCopy :: SpecArr -> SpecArr -> SE () +pol2rectCopy = convertCopy "pol2rect" + +-- | Polar to rectangular format conversion. +-- +-- > kout[] pol2rect kmags[], kphs[] +-- +-- csound docs: +pol2rect2Copy :: SpecArr -> SpecArr -> SpecArr -> SE () +pol2rect2Copy = convert2Copy "pol2rect2" + +-- | Applies a window to an array. +-- +-- > kout[] window kin[][, koff, itype] +-- +-- csound docs: +windowArrayCopy :: SpecArr -> SpecArr -> SE () +windowArrayCopy = convertCopy "window" + +-- | Real to complex format conversion. +-- +-- > kout[] r2c kin[] +-- +-- csound docs: +r2cCopy :: SpecArr -> SpecArr -> SE () +r2cCopy = convertCopy "r2c" + +-- | Complex to real format conversion. +-- +-- > kout[] c2r kin[] +-- +-- csound docs: +c2rCopy :: SpecArr -> SpecArr -> SE () +c2rCopy = convertCopy "c2r" + + +-- | Obtains the magnitudes of a complex-number array +-- +-- > kout[] mags kin[] +-- +-- csound docs: +magsArrayCopy :: SpecArr -> SpecArr -> SE () +magsArrayCopy = convertCopy "mags" + +-- | Obtains the phases of a complex-number array +-- +-- kout[] phs kin[] +-- +-- > csound docs: +phsArrayCopy :: SpecArr -> SpecArr -> SE () +phsArrayCopy = convertCopy "phs" + +--------------------------------------------------------------- + +binOpCopy :: String -> Arr a b -> Arr a b -> Arr a b -> SE () +binOpCopy name (Arr xs) (Arr ys) (Arr outs) = mapM_ go $ zip3 xs ys outs + where + go (x, y, outVar) = SE $ infOprArr noArrayInit outVar name (inlineVar x) (inlineVar y) + +convertCopy :: String -> Arr a b -> Arr a b -> SE () +convertCopy name (Arr vars) (Arr outs) = zipWithM_ go vars outs + where + go v outVar = SE $ opcsArr noArrayInit outVar name idRate1 [inlineVar v] + idRate1 = fmap (\r -> (r, [r])) [Kr, Ar, Ir, Sr, Fr] + +convert2Copy :: String -> Arr a b -> Arr a b -> Arr a b -> SE () +convert2Copy name (Arr xs) (Arr ys) (Arr outs) = mapM_ go $ zip3 xs ys outs + where + go (x, y, outVar) = SE $ opcsArr noArrayInit outVar name idRate2 [inlineVar x, inlineVar y] + idRate2 = fmap (\r -> (r, [r, r])) [Kr, Ar, Ir, Sr, Fr] + diff --git a/src/Csound/Typed/Types/MixSco.hs b/src/Csound/Typed/Types/MixSco.hs --- a/src/Csound/Typed/Types/MixSco.hs +++ b/src/Csound/Typed/Types/MixSco.hs @@ -30,8 +30,13 @@ delayCsdEventList :: D -> CsdEventList a -> CsdEventList a delayCsdEventList = T.del + +type TupleMonoArg = (E,E,E,E) +type RawMonoInstr = TupleMonoArg -> Dep [E] + data M = Snd InstrId (CsdEventList [E]) + | MonoSnd { monoSndInstr :: InstrId, monoSndArgs :: InstrId, monoSndNotes :: (CsdEventList [E]) } | Eff InstrId (CsdEventList M) Int delayAndRescaleCsdEventListM :: CsdEventList M -> CsdEventList M @@ -43,8 +48,9 @@ delayCsdEventM :: T.Event D M -> T.Event D M delayCsdEventM (T.Event start dur evt) = T.Event start dur (phi evt) where phi x = case x of - Snd n evts -> Snd n $ delayCsdEventList start evts - Eff n evts arityIn -> Eff n (delayCsdEventListM $ delayCsdEventList start evts) arityIn + Snd n evts -> Snd n $ delayCsdEventList start evts + MonoSnd instrId argId evts -> MonoSnd instrId argId $ delayCsdEventList start evts + Eff n evts arityIn -> Eff n (delayCsdEventListM $ delayCsdEventList start evts) arityIn rescaleCsdEventListM :: CsdEventList M -> CsdEventList M rescaleCsdEventListM = T.mapEvents rescaleCsdEventM @@ -52,16 +58,18 @@ rescaleCsdEventM :: T.Event D M -> T.Event D M rescaleCsdEventM (T.Event start dur evt) = T.Event start dur (phi evt) where phi x = case x of - Snd n evts -> Snd n $ rescaleCsdEventList (dur/localDur) evts - Eff n evts arityIn -> Eff n (rescaleCsdEventListM $ rescaleCsdEventList (dur/localDur) evts) arityIn + Snd n evts -> Snd n $ rescaleCsdEventList (dur/localDur) evts + MonoSnd instrId argId evts -> MonoSnd instrId argId $ rescaleCsdEventList (dur/localDur) evts + Eff n evts arityIn -> Eff n (rescaleCsdEventListM $ rescaleCsdEventList (dur/localDur) evts) arityIn where localDur = case x of - Snd _ evts -> csdEventListDur evts - Eff _ evts _ -> csdEventListDur evts + Snd _ evts -> csdEventListDur evts + MonoSnd _ _ evts -> csdEventListDur evts + Eff _ evts _ -> csdEventListDur evts renderMixSco :: Int -> CsdEventList M -> Dep [E] renderMixSco arity evts = do chnId <- chnRefAlloc arity - aliveCountRef <- unSE $ newRef (10 :: D) + aliveCountRef <- unSE $ newRef (10 :: D) go aliveCountRef chnId evts readChn chnId where @@ -78,6 +86,7 @@ onEvent :: Ref D -> ChnRef -> (D, D, M) -> Dep () onEvent aliveCountRef outId (start, dur, x) = case x of Snd instrId es -> onSnd aliveCountRef instrId outId es + MonoSnd instr arg es -> onMonoSnd instr arg start dur outId es Eff instrId es arityIn -> onEff aliveCountRef instrId start dur outId es arityIn onSnd _ instrId outId es = forM_ (csdEventListNotes es) $ \(start, dur, args) -> @@ -88,13 +97,24 @@ mkEvent instrId start dur [chnRefId inId, chnRefId outId] go aliveCountRef inId es + onMonoSnd instrId argId start dur outId es = do + inId <- chnRefAlloc arityMonoIn + + forM_ (csdEventListNotes es) $ \(startLocal, durLocal, args) -> + mkEvent argId startLocal durLocal (args ++ [chnRefId inId]) + + mkEvent instrId start dur [chnRefId inId, chnRefId outId] + where arityMonoIn = 3 + + renderMixSco_ :: CsdEventList M -> Dep () renderMixSco_ evts = mapM_ onEvent $ csdEventListNotes evts where onEvent :: (D, D, M) -> Dep () onEvent (start, dur, x) = case x of - Snd instrId es -> onSnd instrId es - Eff instrId es _ -> onEff instrId start dur es + Snd instrId es -> onSnd instrId es + MonoSnd instr arg es -> onMonoSnd instr arg es + Eff instrId es _ -> onEff instrId start dur es onSnd instrId es = forM_ (csdEventListNotes es) $ \(start, dur, args) -> mkEvent instrId start dur args @@ -102,6 +122,8 @@ onEff instrId start dur es = do mkEvent instrId start dur [] renderMixSco_ es + + onMonoSnd instr arg es = undefined mkEvent :: InstrId -> D -> D -> [E] -> Dep () diff --git a/src/Csound/Typed/Types/MonoArg.hs b/src/Csound/Typed/Types/MonoArg.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Types/MonoArg.hs @@ -0,0 +1,38 @@ +module Csound.Typed.Types.MonoArg( + MonoArg(..), MonoAdsr, adsrMonoSynt, monoAdsr +) where + +import Csound.Typed.Types.Prim +import Csound.Typed.Types.Tuple +import Csound.Typed.Plugins.Adsr140 + +-- | Input argument for monophonic synthesizer. +-- It includes signals for amplitude, frequency (Cycles Per second), gate, trigger. +-- The gate equals to 1 when any note is pressed or zero when nothing is pressed. +-- The trigger equals to 1 at the moment when new note is pressed otherwise it's 0. +data MonoArg = MonoArg + { monoAmp :: Sig + , monoCps :: Sig + , monoGate :: Sig + , monoTrig :: Sig } + +instance Tuple MonoArg where + tupleMethods = makeTupleMethods to from + where + to :: Sig4 -> MonoArg + to (amp, cps, gate, trig) = MonoArg amp cps gate trig + + from :: MonoArg -> Sig4 + from (MonoArg amp cps gate trig) = (amp, cps, gate, trig) + +-- | ADSR that's used in monophonic instruments. +type MonoAdsr = Sig -> Sig -> Sig -> Sig -> Sig + +-- | Turns the function that expects ADSR-function and amplitude and frequency to the +-- function on monophonic argument. +adsrMonoSynt :: (MonoAdsr -> (Sig, Sig) -> a) -> (MonoArg -> a) +adsrMonoSynt f arg = f env (monoAmp arg, monoCps arg) + where env = monoAdsr arg + +monoAdsr :: MonoArg -> MonoAdsr +monoAdsr arg = adsr140 (monoGate arg) (monoTrig arg) diff --git a/src/Csound/Typed/Types/Prim.hs b/src/Csound/Typed/Types/Prim.hs --- a/src/Csound/Typed/Types/Prim.hs +++ b/src/Csound/Typed/Types/Prim.hs @@ -1,7 +1,9 @@ {-# Language TypeFamilies, FlexibleInstances, FlexibleContexts, ScopedTypeVariables, Rank2Types #-} module Csound.Typed.Types.Prim( - Sig(..), unSig, D(..), unD, Tab(..), unTab, Str(..), Spec(..), Wspec(..), + Sig(..), unSig, D(..), unD, Tab(..), unTab, Str(..), Spec(..), Wspec(..), renderTab, BoolSig(..), unBoolSig, BoolD(..), unBoolD, Unit(..), unit, Val(..), hideGE, SigOrD, + Sig2, Sig3, Sig4, Sig5, Sig6, Sig7, Sig8, + D2, D3, D4, D5, D6, -- ** Tables preTab, preStringTab, TabSize(..), TabArgs(..), updateTabSize, @@ -39,11 +41,13 @@ import qualified Data.IntMap as IM import qualified Data.Map as M +import Control.Monad.Trans.Reader + import Data.Default import Data.Boolean -import Csound.Dynamic hiding (double, int, str, when1, whens, ifBegin, ifEnd, elseBegin, untilBegin, untilEnd, untilDo) -import qualified Csound.Dynamic as D(double, int, str, ifBegin, ifEnd, elseBegin, untilBegin, untilEnd) +import Csound.Dynamic hiding (double, int, str, when1, whens, ifBegin, ifEnd, elseBegin, untilBegin, untilEnd, untilDo, whileBegin, whileEnd, whileDo) +import qualified Csound.Dynamic as D(double, int, str, ifBegin, ifEnd, elseBegin, untilBegin, untilEnd, whileBegin, whileEnd) import Csound.Typed.GlobalState.GE import Csound.Typed.GlobalState.SE import Csound.Typed.GlobalState.Options @@ -74,6 +78,20 @@ -- | Another type for spectrum. It's @wsig@ in the Csound. newtype Wspec = Wspec { unWspec :: GE E } +type D2 = (D, D) +type D3 = (D, D, D) +type D4 = (D, D, D, D) +type D5 = (D, D, D, D, D) +type D6 = (D, D, D, D, D, D) + +type Sig2 = (Sig, Sig) +type Sig3 = (Sig, Sig, Sig) +type Sig4 = (Sig, Sig, Sig, Sig) +type Sig5 = (Sig, Sig, Sig, Sig, Sig) +type Sig6 = (Sig, Sig, Sig, Sig, Sig, Sig) +type Sig7 = (Sig, Sig, Sig, Sig, Sig, Sig, Sig) +type Sig8 = (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) + -- Booleans -- | A signal of booleans. @@ -151,15 +169,15 @@ -- Table arguments can be data TabArgs -- absolute - = ArgsPlain [Double] - -- or relative to the table size (used for tables that implement interpolation) + = ArgsPlain (Reader Int [Double]) +{- -- or relative to the table size (used for tables that implement interpolation) | ArgsRelative [Double] -- GEN 16 uses unusual interpolation scheme, so we need a special case - | ArgsGen16 [Double] + | ArgsGen16 [Double] -} | FileAccess String [Double] -renderTab :: PreTab -> GE E -renderTab a = saveGen =<< fromPreTab a +renderPreTab :: PreTab -> GE E +renderPreTab a = (fmap D.int . saveGen) =<< fromPreTab a getPreTabUnsafe :: String -> Tab -> PreTab getPreTabUnsafe msg x = case x of @@ -193,38 +211,9 @@ defineTabArgs :: Int -> TabArgs -> ([Double], Maybe String) defineTabArgs size args = case args of - ArgsPlain as -> (as, Nothing) - ArgsRelative as -> (fromRelative size as, Nothing) - ArgsGen16 as -> (formRelativeGen16 size as, Nothing) + ArgsPlain as -> (runReader as size, Nothing) FileAccess filename as -> (as, Just filename) - where fromRelative n as = substEvens (mkRelative n $ getEvens as) as - getEvens xs = case xs of - [] -> [] - _:[] -> [] - _:b:as -> b : getEvens as - - substEvens evens xs = case (evens, xs) of - ([], as) -> as - (_, []) -> [] - (e:es, a:_:as) -> a : e : substEvens es as - _ -> error "table argument list should contain even number of elements" - - mkRelative n as = fmap ((fromIntegral :: (Int -> Double)) . round . (s * )) as - where s = fromIntegral n / sum as - -- special case. subst relatives for Gen16 - formRelativeGen16 n as = substGen16 (mkRelative n $ getGen16 as) as - - getGen16 xs = case xs of - _:durN:_:rest -> durN : getGen16 rest - _ -> [] - - substGen16 durs xs = case (durs, xs) of - ([], as) -> as - (_, []) -> [] - (d:ds, valN:_:typeN:rest) -> valN : d : typeN : substGen16 ds rest - (_, _) -> xs - -- | Skips normalization (sets table size to negative value) skipNorm :: Tab -> Tab skipNorm x = case x of @@ -255,7 +244,6 @@ Tab _ -> error "you can change size only for primitive tables (made with gen-routines)" TabPre a -> TabPre $ a{ preTabSize = phi $ preTabSize a } - ---------------------------------------------------------------------------- -- Tab of tabs @@ -375,8 +363,13 @@ unTab :: Tab -> GE E unTab x = case x of Tab a -> a - TabPre a -> renderTab a + TabPre a -> renderPreTab a +renderTab :: Tab -> GE Int +renderTab x = case x of + TabPre a -> saveGen =<< fromPreTab a + Tab _ -> error "table should be primitive" + instance Val BoolSig where fromGE = BoolSig toGE x = case x of @@ -656,8 +649,17 @@ untilEnd whileDo :: BoolSig -> SE () -> SE () -whileDo p = untilDo (notB p) +whileDo p body = do + whileBegin p + body + whileEnd +whileBegin :: BoolSig -> SE () +whileBegin a = fromDep_ $ D.whileBegin =<< lift (toGE a) + +whileEnd :: SE () +whileEnd = fromDep_ D.whileEnd + untilBegin :: BoolSig -> SE () untilBegin a = fromDep_ $ D.untilBegin =<< lift (toGE a) @@ -671,8 +673,14 @@ untilEnd whileDoD :: BoolD -> SE () -> SE () -whileDoD p = untilDoD (notB p) +whileDoD p body = do + whileBeginD p + body + whileEnd +whileBeginD :: BoolD -> SE () +whileBeginD a = fromDep_ $ D.whileBegin =<< lift (toGE a) + untilBeginD :: BoolD -> SE () untilBeginD a = fromDep_ $ D.untilBegin =<< lift (toGE a) @@ -728,3 +736,188 @@ ftcps :: Tab -> D ftcps = on1 $ opr1 "ftcps" + +------------------------------------------------- +-- numeric instances + +instance Num Sig2 where + (a1, a2) + (b1, b2) = (a1 + b1, a2 + b2) + (a1, a2) * (b1, b2) = (a1 * b1, a2 * b2) + negate (a1, a2) = (negate a1, negate a2) + + fromInteger n = (fromInteger n, fromInteger n) + signum (a1, a2) = (signum a1, signum a2) + abs (a1, a2) = (abs a1, abs a2) + +instance Fractional Sig2 where + recip (a1, a2) = (recip a1, recip a2) + fromRational n = (fromRational n, fromRational n) + +instance Num Sig3 where + (a1, a2, a3) + (b1, b2, b3) = (a1 + b1, a2 + b2, a3 + b3) + (a1, a2, a3) * (b1, b2, b3) = (a1 * b1, a2 * b2, a3 * b3) + negate (a1, a2, a3) = (negate a1, negate a2, negate a3) + + fromInteger n = (fromInteger n, fromInteger n, fromInteger n) + signum (a1, a2, a3) = (signum a1, signum a2, signum a3) + abs (a1, a2, a3) = (abs a1, abs a2, abs a3) + +instance Fractional Sig3 where + recip (a1, a2, a3) = (recip a1, recip a2, recip a3) + fromRational n = (fromRational n, fromRational n, fromRational n) + +instance Num Sig4 where + (a1, a2, a3, a4) + (b1, b2, b3, b4) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4) + (a1, a2, a3, a4) * (b1, b2, b3, b4) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4) + negate (a1, a2, a3, a4) = (negate a1, negate a2, negate a3, negate a4) + + fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n) + signum (a1, a2, a3, a4) = (signum a1, signum a2, signum a3, signum a4) + abs (a1, a2, a3, a4) = (abs a1, abs a2, abs a3, abs a4) + +instance Fractional Sig4 where + recip (a1, a2, a3, a4) = (recip a1, recip a2, recip a3, recip a4) + fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n) + +instance Num Sig5 where + (a1, a2, a3, a4, a5) + (b1, b2, b3, b4, b5) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5) + (a1, a2, a3, a4, a5) * (b1, b2, b3, b4, b5) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4, a5 * b5) + negate (a1, a2, a3, a4, a5) = (negate a1, negate a2, negate a3, negate a4, negate a5) + + fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n) + signum (a1, a2, a3, a4, a5) = (signum a1, signum a2, signum a3, signum a4, signum a5) + abs (a1, a2, a3, a4, a5) = (abs a1, abs a2, abs a3, abs a4, abs a5) + +instance Fractional Sig5 where + recip (a1, a2, a3, a4, a5) = (recip a1, recip a2, recip a3, recip a4, recip a5) + fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n, fromRational n) + +instance Num Sig6 where + (a1, a2, a3, a4, a5, a6) + (b1, b2, b3, b4, b5, b6) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5, a6 + b6) + (a1, a2, a3, a4, a5, a6) * (b1, b2, b3, b4, b5, b6) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4, a5 * b5, a6 * b6) + negate (a1, a2, a3, a4, a5, a6) = (negate a1, negate a2, negate a3, negate a4, negate a5, negate a6) + + fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n) + signum (a1, a2, a3, a4, a5, a6) = (signum a1, signum a2, signum a3, signum a4, signum a5, signum a6) + abs (a1, a2, a3, a4, a5, a6) = (abs a1, abs a2, abs a3, abs a4, abs a5, abs a6) + +instance Fractional Sig6 where + recip (a1, a2, a3, a4, a5, a6) = (recip a1, recip a2, recip a3, recip a4, recip a5, recip a6) + fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n, fromRational n, fromRational n) + +instance Num Sig7 where + (a1, a2, a3, a4, a5, a6, a7) + (b1, b2, b3, b4, b5, b6, b7) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5, a6 + b6, a7 + b7) + (a1, a2, a3, a4, a5, a6, a7) * (b1, b2, b3, b4, b5, b6, b7) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4, a5 * b5, a6 * b6, a7 * b7) + negate (a1, a2, a3, a4, a5, a6, a7) = (negate a1, negate a2, negate a3, negate a4, negate a5, negate a6, negate a7) + + fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n) + signum (a1, a2, a3, a4, a5, a6, a7) = (signum a1, signum a2, signum a3, signum a4, signum a5, signum a6, signum a7) + abs (a1, a2, a3, a4, a5, a6, a7) = (abs a1, abs a2, abs a3, abs a4, abs a5, abs a6, abs a7) + +instance Fractional Sig7 where + recip (a1, a2, a3, a4, a5, a6, a7) = (recip a1, recip a2, recip a3, recip a4, recip a5, recip a6, recip a7) + fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n, fromRational n, fromRational n, fromRational n) + +instance Num Sig8 where + (a1, a2, a3, a4, a5, a6, a7, a8) + (b1, b2, b3, b4, b5, b6, b7, b8) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5, a6 + b6, a7 + b7, a8 + b8) + (a1, a2, a3, a4, a5, a6, a7, a8) * (b1, b2, b3, b4, b5, b6, b7, b8) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4, a5 * b5, a6 * b6, a7 + b7, a8 + b8) + negate (a1, a2, a3, a4, a5, a6, a7, a8) = (negate a1, negate a2, negate a3, negate a4, negate a5, negate a6, negate a7, negate a8) + + fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n) + signum (a1, a2, a3, a4, a5, a6, a7, a8) = (signum a1, signum a2, signum a3, signum a4, signum a5, signum a6, signum a7, signum a8) + abs (a1, a2, a3, a4, a5, a6, a7, a8) = (abs a1, abs a2, abs a3, abs a4, abs a5, abs a6, abs a7, abs a8) + +instance Fractional Sig8 where + recip (a1, a2, a3, a4, a5, a6, a7, a8) = (recip a1, recip a2, recip a3, recip a4, recip a5, recip a6, recip a7, recip a8) + fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n, fromRational n, fromRational n, fromRational n, fromRational n) + +instance Num (Sig8, Sig8) where + (a1, a2) + (b1, b2) = (a1 + b1, a2 + b2) + (a1, a2) * (b1, b2) = (a1 * b1, a2 * b2) + negate (a1, a2) = (negate a1, negate a2) + + fromInteger n = (fromInteger n, fromInteger n) + signum (a1, a2) = (signum a1, signum a2) + abs (a1, a2) = (abs a1, abs a2) + +instance Fractional (Sig8, Sig8) where + recip (a1, a2) = (recip a1, recip a2) + fromRational n = (fromRational n, fromRational n) + +instance Num (Sig8, Sig8, Sig8, Sig8) where + (a1, a2, a3, a4) + (b1, b2, b3, b4) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4) + (a1, a2, a3, a4) * (b1, b2, b3, b4) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4) + negate (a1, a2, a3, a4) = (negate a1, negate a2, negate a3, negate a4) + + fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n) + signum (a1, a2, a3, a4) = (signum a1, signum a2, signum a3, signum a4) + abs (a1, a2, a3, a4) = (abs a1, abs a2, abs a3, abs a4) + +instance Fractional (Sig8, Sig8, Sig8, Sig8) where + recip (a1, a2, a3, a4) = (recip a1, recip a2, recip a3, recip a4) + fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n) + +instance Num (Sig2, Sig2) where + (a1, a2) + (b1, b2) = (a1 + b1, a2 + b2) + (a1, a2) * (b1, b2) = (a1 * b1, a2 * b2) + negate (a1, a2) = (negate a1, negate a2) + + fromInteger n = (fromInteger n, fromInteger n) + signum (a1, a2) = (signum a1, signum a2) + abs (a1, a2) = (abs a1, abs a2) + +instance Fractional (Sig2, Sig2) where + recip (a1, a2) = (recip a1, recip a2) + fromRational n = (fromRational n, fromRational n) + +instance Num (Sig2, Sig2, Sig2) where + (a1, a2, a3) + (b1, b2, b3) = (a1 + b1, a2 + b2, a3 + b3) + (a1, a2, a3) * (b1, b2, b3) = (a1 * b1, a2 * b2, a3 * b3) + negate (a1, a2, a3) = (negate a1, negate a2, negate a3) + + fromInteger n = (fromInteger n, fromInteger n, fromInteger n) + signum (a1, a2, a3) = (signum a1, signum a2, signum a3) + abs (a1, a2, a3) = (abs a1, abs a2, abs a3) + +instance Fractional (Sig2, Sig2, Sig2) where + recip (a1, a2, a3) = (recip a1, recip a2, recip a3) + fromRational n = (fromRational n, fromRational n, fromRational n) + +instance Num (Sig2, Sig2, Sig2, Sig2) where + (a1, a2, a3, a4) + (b1, b2, b3, b4) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4) + (a1, a2, a3, a4) * (b1, b2, b3, b4) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4) + negate (a1, a2, a3, a4) = (negate a1, negate a2, negate a3, negate a4) + + fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n) + signum (a1, a2, a3, a4) = (signum a1, signum a2, signum a3, signum a4) + abs (a1, a2, a3, a4) = (abs a1, abs a2, abs a3, abs a4) + +instance Fractional (Sig2, Sig2, Sig2, Sig2) where + recip (a1, a2, a3, a4) = (recip a1, recip a2, recip a3, recip a4) + fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n) + +instance Num (Sig2, Sig2, Sig2, Sig2, Sig2) where + (a1, a2, a3, a4, a5) + (b1, b2, b3, b4, b5) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5) + (a1, a2, a3, a4, a5) * (b1, b2, b3, b4, b5) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4, a5 * b5) + negate (a1, a2, a3, a4, a5) = (negate a1, negate a2, negate a3, negate a4, negate a5) + + fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n) + signum (a1, a2, a3, a4, a5) = (signum a1, signum a2, signum a3, signum a4, signum a5) + abs (a1, a2, a3, a4, a5) = (abs a1, abs a2, abs a3, abs a4, abs a5) + +instance Fractional (Sig2, Sig2, Sig2, Sig2, Sig2) where + recip (a1, a2, a3, a4, a5) = (recip a1, recip a2, recip a3, recip a4, recip a5) + fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n, fromRational n) + +instance Num (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where + (a1, a2, a3, a4, a5, a6) + (b1, b2, b3, b4, b5, b6) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5, a6 + b6) + (a1, a2, a3, a4, a5, a6) * (b1, b2, b3, b4, b5, b6) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4, a5 * b5, a6 * b6) + negate (a1, a2, a3, a4, a5, a6) = (negate a1, negate a2, negate a3, negate a4, negate a5, negate a6) + + fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n) + signum (a1, a2, a3, a4, a5, a6) = (signum a1, signum a2, signum a3, signum a4, signum a5, signum a6) + abs (a1, a2, a3, a4, a5, a6) = (abs a1, abs a2, abs a3, abs a4, abs a5, abs a6) + +instance Fractional (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where + recip (a1, a2, a3, a4, a5, a6) = (recip a1, recip a2, recip a3, recip a4, recip a5, recip a6) + fromRational n = (fromRational n, fromRational n, fromRational n, fromRational n, fromRational n, fromRational n) diff --git a/src/Csound/Typed/Types/SigSpace.hs b/src/Csound/Typed/Types/SigSpace.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Types/SigSpace.hs @@ -0,0 +1,702 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# Language + TypeFamilies, + MultiParamTypeClasses, + FlexibleInstances, + FlexibleContexts #-} +module Csound.Typed.Types.SigSpace( + SigSpace(..), BindSig(..), mul, mul', on, uon, At(..), MixAt(..), + cfd, genCfds, cfd4, cfds, + + -- * Stereo sig-space + SigSpace2(..), BindSig2(..), mul2, mul2', +) where + +import Control.Monad +import Control.Applicative +import Csound.Typed.Types.Prim +import Csound.Typed.GlobalState.SE + +-- | A class for easy way to process the outputs of the instruments. +class SigSpace a where + mapSig :: (Sig -> Sig) -> a -> a + +-- | A class for easy way to process the outputs of the instruments. +class SigSpace a => BindSig a where + bindSig :: (Sig -> SE Sig) -> a -> SE a + +-- | A class for easy way to process the outputs of the instruments. +class SigSpace2 a where + mapSig2 :: (Sig2 -> Sig2) -> a -> a + +-- | A class for easy way to process the outputs of the instruments. +class SigSpace2 a => BindSig2 a where + bindSig2 :: (Sig2 -> SE Sig2) -> a -> SE a + + +-- | Scaling the sound. +mul :: SigSpace a => Sig -> a -> a +mul k = mapSig (k * ) + +-- | Scaling the sound with effectful signal. +mul' :: BindSig a => SE Sig -> a -> SE a +mul' k = bindSig (\x -> fmap (* x) k) + +-- | Scaling the sound with a pair. +mul2 :: SigSpace2 a => Sig2 -> a -> a +mul2 (ka, kb) = mapSig2 (\(a, b) -> (ka * a, kb * b)) + +-- | Scaling the sound with effectful pair of signals. +mul2' :: BindSig2 a => SE Sig2 -> a -> SE a +mul2' k = bindSig2 (\(xa, xb) -> fmap (\(ka, kb) -> (ka * xa, kb * xb)) k) + +-- rescaling + +-- | Rescaling of the bipolar signal (-1, 1) -> (a, b) +-- +-- > on a b biSig +on :: SigSpace a => Sig -> Sig -> a -> a +on a b x = uon a b $ mapSig unipolar x + where unipolar a = 0.5 + 0.5 * a + +-- | Rescaling of the unipolar signal (0, 1) -> (a, b) +-- +-- > on a b uniSig +uon :: SigSpace a => Sig -> Sig -> a -> a +uon a b = mapSig (\x -> a + (b - a) * x) + +-- | Crossfade. +-- +-- > cfd coeff sig1 sig2 +-- +-- If coeff equals 0 then we get the first signal and if it equals 1 we get the second signal. +cfd :: (Num a, SigSpace a) => Sig -> a -> a -> a +cfd coeff a b = (1 - coeff) `mul` a + coeff `mul` b + +genCfds :: a -> (Sig -> a -> a -> a) -> [Sig] -> [a] -> a +genCfds zero mixFun cs xs = case xs of + [] -> zero + a:as -> foldl (\x f -> f x) a $ zipWith mix' cs as + where mix' c a b = mixFun c b a + +-- | Bilinear interpolation for four signals. +-- The signals are placed in the corners of the unit square. +-- The first two signals are the xy coordinates in the square. +-- +-- > cfd4 x y a b c d +-- +-- * (0, 0) is for a +-- +-- * (1, 0) is for b +-- +-- * (1, 1) is for c +-- +-- * (0, 1) is for d +cfd4 :: (Num a, SigSpace a) => Sig -> Sig -> a -> a -> a -> a -> a +cfd4 x y a b c d = sum $ zipWith mul [(1 - x) * (1 - y), x * (1 - y) , x * y, (1 - x) * y] [a, b, c, d] + +-- | Generic crossfade for n coefficients and n+1 signals. +-- +-- > cfds coeffs sigs +cfds :: (Num a, SigSpace a) => [Sig] -> [a] -> a +cfds = genCfds 0 cfd + + +instance SigSpace Sig where mapSig = id +instance BindSig Sig where bindSig = id + +instance SigSpace (Sig, Sig) where mapSig f (a1, a2) = (f a1, f a2) +instance BindSig (Sig, Sig) where bindSig f (a1, a2) = (,) <$> f a1 <*> f a2 + +instance SigSpace (Sig, Sig, Sig) where mapSig f (a1, a2, a3) = (f a1, f a2, f a3) +instance BindSig (Sig, Sig, Sig) where bindSig f (a1, a2, a3) = (,,) <$> f a1 <*> f a2 <*> f a3 + +instance SigSpace (Sig, Sig, Sig, Sig) where mapSig f (a1, a2, a3, a4) = (f a1, f a2, f a3, f a4) +instance BindSig (Sig, Sig, Sig, Sig) where bindSig f (a1, a2, a3, a4) = (,,,) <$> f a1 <*> f a2 <*> f a3 <*> f a4 + +instance SigSpace (Sig, Sig, Sig, Sig, Sig) where mapSig f (a1, a2, a3, a4, a5) = (f a1, f a2, f a3, f a4, f a5) +instance BindSig (Sig, Sig, Sig, Sig, Sig) where bindSig f (a1, a2, a3, a4, a5) = (,,,,) <$> f a1 <*> f a2 <*> f a3 <*> f a4 <*> f a5 + +instance SigSpace (Sig, Sig, Sig, Sig, Sig, Sig) where mapSig f (a1, a2, a3, a4, a5, a6) = (f a1, f a2, f a3, f a4, f a5, f a6) +instance BindSig (Sig, Sig, Sig, Sig, Sig, Sig) where bindSig f (a1, a2, a3, a4, a5, a6) = (,,,,,) <$> f a1 <*> f a2 <*> f a3 <*> f a4 <*> f a5 <*> f a6 + +instance SigSpace (Sig, Sig, Sig, Sig, Sig, Sig, Sig) where mapSig f (a1, a2, a3, a4, a5, a6, a7) = (f a1, f a2, f a3, f a4, f a5, f a6, f a7) +instance BindSig (Sig, Sig, Sig, Sig, Sig, Sig, Sig) where bindSig f (a1, a2, a3, a4, a5, a6, a7) = (,,,,,,) <$> f a1 <*> f a2 <*> f a3 <*> f a4 <*> f a5 <*> f a6 <*> f a7 + +instance SigSpace (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) where mapSig f (a1, a2, a3, a4, a5, a6, a7, a8) = (f a1, f a2, f a3, f a4, f a5, f a6, f a7, f a8) +instance BindSig (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) where bindSig f (a1, a2, a3, a4, a5, a6, a7, a8) = (,,,,,,,) <$> f a1 <*> f a2 <*> f a3 <*> f a4 <*> f a5 <*> f a6 <*> f a7 <*> f a8 + +instance SigSpace (Sig2, Sig2) where mapSig f (a1, a2) = (mapSig f a1, mapSig f a2) +instance BindSig (Sig2, Sig2) where bindSig f (a1, a2) = (,) <$> bindSig f a1 <*> bindSig f a2 + +instance SigSpace (Sig2, Sig2, Sig2) where mapSig f (a1, a2, a3) = (mapSig f a1, mapSig f a2, mapSig f a3) +instance BindSig (Sig2, Sig2, Sig2) where bindSig f (a1, a2, a3) = (,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 + +instance SigSpace (Sig2, Sig2, Sig2, Sig2) where mapSig f (a1, a2, a3, a4) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4) +instance BindSig (Sig2, Sig2, Sig2, Sig2) where bindSig f (a1, a2, a3, a4) = (,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4 + +instance SigSpace (Sig2, Sig2, Sig2, Sig2, Sig2) where mapSig f (a1, a2, a3, a4, a5) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4, mapSig f a5) +instance BindSig (Sig2, Sig2, Sig2, Sig2, Sig2) where bindSig f (a1, a2, a3, a4, a5) = (,,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4 <*> bindSig f a5 + +instance SigSpace (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where mapSig f (a1, a2, a3, a4, a5, a6) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4, mapSig f a5, mapSig f a6) +instance BindSig (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where bindSig f (a1, a2, a3, a4, a5, a6) = (,,,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4 <*> bindSig f a5 <*> bindSig f a6 + +instance SigSpace (Sig8, Sig8) where mapSig f (a1, a2) = (mapSig f a1, mapSig f a2) +instance BindSig (Sig8, Sig8) where bindSig f (a1, a2) = (,) <$> bindSig f a1 <*> bindSig f a2 + +instance SigSpace (Sig8, Sig8, Sig8, Sig8) where mapSig f (a1, a2, a3, a4) = (mapSig f a1, mapSig f a2, mapSig f a3, mapSig f a4) +instance BindSig (Sig8, Sig8, Sig8, Sig8) where bindSig f (a1, a2, a3, a4) = (,,,) <$> bindSig f a1 <*> bindSig f a2 <*> bindSig f a3 <*> bindSig f a4 + +instance SigSpace (SE Sig) where mapSig f = fmap (mapSig f) +instance BindSig (SE Sig) where bindSig f = fmap (bindSig f) + +instance SigSpace (SE (Sig, Sig)) where mapSig f = fmap (mapSig f) +instance BindSig (SE (Sig, Sig)) where bindSig f = fmap (bindSig f) + +instance SigSpace (SE (Sig, Sig, Sig)) where mapSig f = fmap (mapSig f) +instance BindSig (SE (Sig, Sig, Sig)) where bindSig f = fmap (bindSig f) + +instance SigSpace (SE (Sig, Sig, Sig, Sig)) where mapSig f = fmap (mapSig f) +instance BindSig (SE (Sig, Sig, Sig, Sig)) where bindSig f = fmap (bindSig f) + +---------------------------------------------------------------------------------------------------------- + +-- | Converts stereosignal to mono with function mean. +toMono :: (Sig, Sig) -> Sig +toMono (a, b) = 0.5 * a + 0.5 * b + +instance SigSpace2 Sig where mapSig2 f a = toMono $ f (a, a) +instance BindSig2 Sig where bindSig2 f a = fmap toMono $ f (a, a) + +instance SigSpace2 (Sig, Sig) where mapSig2 = id +instance BindSig2 (Sig, Sig) where bindSig2 = id + +instance SigSpace2 (Sig, Sig, Sig) where + mapSig2 f (a1, a2, a3) = (b1, b2, toMono (b3, b4)) + where + (b1, b2, b3, b4) = mapSig2 f (a1, a2, a3, a4) + a4 = a3 + +instance BindSig2 (Sig, Sig, Sig) where + bindSig2 f (a1, a2, a3) = do + (b1, b2, b3, b4) <- bindSig2 f (a1, a2, a3, a4) + return (b1, b2, toMono (b3, b4)) + where + a4 = a3 + +instance SigSpace2 (Sig, Sig, Sig, Sig) where + mapSig2 f (a1, a2, a3, a4) = (b1, b2, b3, b4) + where + (b1, b2) = f (a1, a2) + (b3, b4) = f (a3, a4) + +instance BindSig2 (Sig, Sig, Sig, Sig) where + bindSig2 f (a1, a2, a3, a4) = do + (b1, b2) <- f (a1, a2) + (b3, b4) <- f (a3, a4) + return (b1, b2, b3, b4) + +instance SigSpace2 (Sig, Sig, Sig, Sig, Sig) where + mapSig2 f (a1, a2, a3, a4, a5) = (b1, b2, b3, b4, toMono (b5, b6)) + where + (b1, b2, b3, b4, b5, b6) = mapSig2 f (a1, a2, a3, a4, a5, a6) + a6 = a5 + +instance BindSig2 (Sig, Sig, Sig, Sig, Sig) where + bindSig2 f (a1, a2, a3, a4, a5) = do + (b1, b2, b3, b4, b5, b6) <- bindSig2 f (a1, a2, a3, a4, a5, a6) + return (b1, b2, b3, b4, toMono (b5, b6)) + where + a6 = a5 + +instance SigSpace2 (Sig, Sig, Sig, Sig, Sig, Sig) where + mapSig2 f (a1, a2, a3, a4, a5, a6) = (b1, b2, b3, b4, b5, b6) + where + (b1, b2, b3, b4) = mapSig2 f (a1, a2, a3, a4) + (b5, b6) = f (a5, a6) + +instance BindSig2 (Sig, Sig, Sig, Sig, Sig, Sig) where + bindSig2 f (a1, a2, a3, a4, a5, a6) = do + (b1, b2, b3, b4) <- bindSig2 f (a1, a2, a3, a4) + (b5, b6) <- f (a5, a6) + return (b1, b2, b3, b4, b5, b6) + +instance SigSpace2 (Sig, Sig, Sig, Sig, Sig, Sig, Sig) where + mapSig2 f (a1, a2, a3, a4, a5, a6, a7) = (b1, b2, b3, b4, b5, b6, toMono (b7, b8)) + where + (b1, b2, b3, b4, b5, b6, b7, b8) = mapSig2 f (a1, a2, a3, a4, a5, a6, a7, a8) + a8 = a7 + +instance BindSig2 (Sig, Sig, Sig, Sig, Sig, Sig, Sig) where + bindSig2 f (a1, a2, a3, a4, a5, a6, a7) = do + (b1, b2, b3, b4, b5, b6, b7, b8) <- bindSig2 f (a1, a2, a3, a4, a5, a6, a7, a8) + return (b1, b2, b3, b4, b5, b6, toMono (b7, b8)) + where + a8 = a7 + +instance SigSpace2 (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) where + mapSig2 f (a1, a2, a3, a4, a5, a6, a7, a8) = (b1, b2, b3, b4, b5, b6, b7, b8) + where + (b1, b2, b3, b4, b5, b6) = mapSig2 f (a1, a2, a3, a4, a5, a6) + (b7, b8) = f (a7, a8) + +instance BindSig2 (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) where + bindSig2 f (a1, a2, a3, a4, a5, a6, a7, a8) = do + (b1, b2, b3, b4, b5, b6) <- bindSig2 f (a1, a2, a3, a4, a5, a6) + (b7, b8) <- f (a7, a8) + return (b1, b2, b3, b4, b5, b6, b7, b8) + +instance SigSpace2 (Sig2, Sig2) where mapSig2 f (a1, a2) = (mapSig2 f a1, mapSig2 f a2) +instance BindSig2 (Sig2, Sig2) where bindSig2 f (a1, a2) = (,) <$> bindSig2 f a1 <*> bindSig2 f a2 + +instance SigSpace2 (Sig2, Sig2, Sig2) where mapSig2 f (a1, a2, a3) = (mapSig2 f a1, mapSig2 f a2, mapSig2 f a3) +instance BindSig2 (Sig2, Sig2, Sig2) where bindSig2 f (a1, a2, a3) = (,,) <$> bindSig2 f a1 <*> bindSig2 f a2 <*> bindSig2 f a3 + +instance SigSpace2 (Sig2, Sig2, Sig2, Sig2) where mapSig2 f (a1, a2, a3, a4) = (mapSig2 f a1, mapSig2 f a2, mapSig2 f a3, mapSig2 f a4) +instance BindSig2 (Sig2, Sig2, Sig2, Sig2) where bindSig2 f (a1, a2, a3, a4) = (,,,) <$> bindSig2 f a1 <*> bindSig2 f a2 <*> bindSig2 f a3 <*> bindSig2 f a4 + +instance SigSpace2 (Sig2, Sig2, Sig2, Sig2, Sig2) where mapSig2 f (a1, a2, a3, a4, a5) = (mapSig2 f a1, mapSig2 f a2, mapSig2 f a3, mapSig2 f a4, mapSig2 f a5) +instance BindSig2 (Sig2, Sig2, Sig2, Sig2, Sig2) where bindSig2 f (a1, a2, a3, a4, a5) = (,,,,) <$> bindSig2 f a1 <*> bindSig2 f a2 <*> bindSig2 f a3 <*> bindSig2 f a4 <*> bindSig2 f a5 + +instance SigSpace2 (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where mapSig2 f (a1, a2, a3, a4, a5, a6) = (mapSig2 f a1, mapSig2 f a2, mapSig2 f a3, mapSig2 f a4, mapSig2 f a5, mapSig2 f a6) +instance BindSig2 (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where bindSig2 f (a1, a2, a3, a4, a5, a6) = (,,,,,) <$> bindSig2 f a1 <*> bindSig2 f a2 <*> bindSig2 f a3 <*> bindSig2 f a4 <*> bindSig2 f a5 <*> bindSig2 f a6 + +instance SigSpace2 (Sig8, Sig8) where mapSig2 f (a1, a2) = (mapSig2 f a1, mapSig2 f a2) +instance BindSig2 (Sig8, Sig8) where bindSig2 f (a1, a2) = (,) <$> bindSig2 f a1 <*> bindSig2 f a2 + +instance SigSpace2 (Sig8, Sig8, Sig8, Sig8) where mapSig2 f (a1, a2, a3, a4) = (mapSig2 f a1, mapSig2 f a2, mapSig2 f a3, mapSig2 f a4) +instance BindSig2 (Sig8, Sig8, Sig8, Sig8) where bindSig2 f (a1, a2, a3, a4) = (,,,) <$> bindSig2 f a1 <*> bindSig2 f a2 <*> bindSig2 f a3 <*> bindSig2 f a4 + +instance SigSpace2 (SE Sig) where mapSig2 f = fmap (mapSig2 f) +instance BindSig2 (SE Sig) where bindSig2 f = fmap (bindSig2 f) + +instance SigSpace2 (SE (Sig, Sig)) where mapSig2 f = fmap (mapSig2 f) +instance BindSig2 (SE (Sig, Sig)) where bindSig2 f = fmap (bindSig2 f) + +instance SigSpace2 (SE (Sig, Sig, Sig)) where mapSig2 f = fmap (mapSig2 f) +instance BindSig2 (SE (Sig, Sig, Sig)) where bindSig2 f = fmap (bindSig2 f) + +instance SigSpace2 (SE (Sig, Sig, Sig, Sig)) where mapSig2 f = fmap (mapSig2 f) +instance BindSig2 (SE (Sig, Sig, Sig, Sig)) where bindSig2 f = fmap (bindSig2 f) + +---------------------------------------------------------------------------------------------------------- +-- numeric instances + +-- Num + +instance Num (SE Sig) where + (+) = liftA2 (+) + (*) = liftA2 (*) + negate = fmap negate + + fromInteger = return . fromInteger + signum = fmap signum + abs = fmap abs + +instance Num (SE (Sig, Sig)) where + (+) = liftA2 (+) + (*) = liftA2 (*) + negate = fmap negate + + fromInteger = return . fromInteger + signum = fmap signum + abs = fmap abs + +instance Num (SE (Sig, Sig, Sig)) where + (+) = liftA2 (+) + (*) = liftA2 (*) + negate = fmap negate + + fromInteger = return . fromInteger + signum = fmap signum + abs = fmap abs + +instance Num (SE (Sig, Sig, Sig, Sig)) where + (+) = liftA2 (+) + (*) = liftA2 (*) + negate = fmap negate + + fromInteger = return . fromInteger + signum = fmap signum + abs = fmap abs + +instance Num (a -> Sig) where + (+) = liftA2 (+) + (*) = liftA2 (*) + negate = fmap negate + + fromInteger = return . fromInteger + signum = fmap signum + abs = fmap abs + +instance Num (a -> (Sig, Sig)) where + (+) = liftA2 (+) + (*) = liftA2 (*) + negate = fmap negate + + fromInteger = return . fromInteger + signum = fmap signum + abs = fmap abs + +instance Num (a -> (Sig, Sig, Sig)) where + (+) = liftA2 (+) + (*) = liftA2 (*) + negate = fmap negate + + fromInteger = return . fromInteger + signum = fmap signum + abs = fmap abs + +instance Num (a -> (Sig, Sig, Sig, Sig)) where + (+) = liftA2 (+) + (*) = liftA2 (*) + negate = fmap negate + + fromInteger = return . fromInteger + signum = fmap signum + abs = fmap abs + + +instance Num (a -> SE Sig) where + (+) = liftA2 (+) + (*) = liftA2 (*) + negate = fmap negate + + fromInteger = return . fromInteger + signum = fmap signum + abs = fmap abs + +instance Num (a -> SE (Sig, Sig)) where + (+) = liftA2 (+) + (*) = liftA2 (*) + negate = fmap negate + + fromInteger = return . fromInteger + signum = fmap signum + abs = fmap abs + +instance Num (a -> SE (Sig, Sig, Sig)) where + (+) = liftA2 (+) + (*) = liftA2 (*) + negate = fmap negate + + fromInteger = return . fromInteger + signum = fmap signum + abs = fmap abs + +instance Num (a -> SE (Sig, Sig, Sig, Sig)) where + (+) = liftA2 (+) + (*) = liftA2 (*) + negate = fmap negate + + fromInteger = return . fromInteger + signum = fmap signum + abs = fmap abs + +-- Fractional + + +instance Fractional (SE Sig) where + (/) = liftA2 (/) + fromRational = return . fromRational + +instance Fractional (SE (Sig, Sig)) where + (/) = liftA2 (/) + fromRational = return . fromRational + +instance Fractional (SE (Sig, Sig, Sig)) where + (/) = liftA2 (/) + fromRational = return . fromRational + +instance Fractional (SE (Sig, Sig, Sig, Sig)) where + (/) = liftA2 (/) + fromRational = return . fromRational + +instance Fractional (a -> SE Sig) where + (/) = liftA2 (/) + fromRational = return . fromRational + +instance Fractional (a -> SE (Sig, Sig)) where + (/) = liftA2 (/) + fromRational = return . fromRational + +instance Fractional (a -> SE (Sig, Sig, Sig)) where + (/) = liftA2 (/) + fromRational = return . fromRational + +instance Fractional (a -> SE (Sig, Sig, Sig, Sig)) where + (/) = liftA2 (/) + fromRational = return . fromRational + +instance Fractional (a -> Sig) where + (/) = liftA2 (/) + fromRational = return . fromRational + +instance Fractional (a -> (Sig, Sig)) where + (/) = liftA2 (/) + fromRational = return . fromRational + +instance Fractional (a -> (Sig, Sig, Sig)) where + (/) = liftA2 (/) + fromRational = return . fromRational + +instance Fractional (a -> (Sig, Sig, Sig, Sig)) where + (/) = liftA2 (/) + fromRational = return . fromRational + +----------------------------------------------------------------------- +----------------------------------------------------------------------- + +class SigSpace b => At a b c where + type AtOut a b c :: * + at :: (a -> b) -> c -> AtOut a b c + +instance SigSpace a => At Sig Sig a where + type AtOut Sig Sig a = a + at f a = mapSig f a + +------------------------------------------------------ +-- for (Sig -> SE Sig) + +instance At Sig (SE Sig) Sig where + type AtOut Sig (SE Sig) Sig = SE Sig + at f a = f a + +instance At Sig (SE Sig) Sig2 where + type AtOut Sig (SE Sig) Sig2 = SE Sig2 + at f a = bindSig f a + +instance At Sig (SE Sig) Sig3 where + type AtOut Sig (SE Sig) Sig3 = SE Sig3 + at f a = bindSig f a + +instance At Sig (SE Sig) Sig4 where + type AtOut Sig (SE Sig) Sig4 = SE Sig4 + at f a = bindSig f a + +instance At Sig (SE Sig) (SE Sig) where + type AtOut Sig (SE Sig) (SE Sig) = SE Sig + at f a = join $ bindSig f a + +instance At Sig (SE Sig) (SE Sig2) where + type AtOut Sig (SE Sig) (SE Sig2) = SE Sig2 + at f a = join $ bindSig f a + +instance At Sig (SE Sig) (SE Sig3) where + type AtOut Sig (SE Sig) (SE Sig3) = SE Sig3 + at f a = join $ bindSig f a + +instance At Sig (SE Sig) (SE Sig4) where + type AtOut Sig (SE Sig) (SE Sig4) = SE Sig4 + at f a = join $ bindSig f a + +----------------------------------------------------- +-- mono to stereo + +instance At Sig Sig2 Sig where + type AtOut Sig Sig2 Sig = Sig2 + at f a = f a + +instance At Sig Sig2 (SE Sig) where + type AtOut Sig Sig2 (SE Sig) = SE Sig2 + at f a = fmap f a + +instance At Sig Sig2 Sig2 where + type AtOut Sig Sig2 Sig2 = Sig2 + at f a = 0.5 * (f (fst a) + f (snd a)) + +instance At Sig Sig2 (SE Sig2) where + type AtOut Sig Sig2 (SE Sig2) = SE Sig2 + at f a = fmap (at f) a + +--------------------------------------------------------- + +--------------------------------------------------------- +-- Sig2 -> Sig2 + +fromMono a = (a, a) + +instance At Sig2 Sig2 Sig where + type AtOut Sig2 Sig2 Sig = Sig2 + at f a = f $ fromMono a + +instance At Sig2 Sig2 Sig2 where + type AtOut Sig2 Sig2 Sig2 = Sig2 + at f a = f a + +instance At Sig2 Sig2 (SE Sig) where + type AtOut Sig2 Sig2 (SE Sig) = SE Sig2 + at f a = fmap (f . fromMono) a + +instance At Sig2 Sig2 (SE Sig2) where + type AtOut Sig2 Sig2 (SE Sig2) = SE Sig2 + at f a = fmap f a + +--------------------------------------------- +-- Sig2 -> SE Sig2 + +instance At Sig2 (SE Sig2) Sig where + type AtOut Sig2 (SE Sig2) Sig = SE Sig2 + at f a = f $ fromMono a + +instance At Sig2 (SE Sig2) Sig2 where + type AtOut Sig2 (SE Sig2) Sig2 = SE Sig2 + at f a = f a + +instance At Sig2 (SE Sig2) (SE Sig) where + type AtOut Sig2 (SE Sig2) (SE Sig) = SE Sig2 + at f a = (f . fromMono) =<< a + +instance At Sig2 (SE Sig2) (SE Sig2) where + type AtOut Sig2 (SE Sig2) (SE Sig2) = SE Sig2 + at f a = f =<< a + +----------------------------------------------------------------------- +----------------------------------------------------------------------- +-- MixAt + +-- | It applies an effect and mixes the processed signal with original one. +-- The first argument is for proportion of dry/wet (original/processed). +-- It's like @at@ but it allows to balance processed signal with original one. +class (SigSpace b, At a b c) => MixAt a b c where + mixAt :: Sig -> (a -> b) -> c -> AtOut a b c + +--------------------------------------------------- + +instance SigSpace a => MixAt Sig Sig a where + mixAt k f a = mapSig (\x -> cfd k x (f x)) a + +------------------------------------------------------ +-- for (Sig -> SE Sig) + +instance MixAt Sig (SE Sig) Sig where + mixAt k f dry = do + wet <- f dry + return $ cfd k dry wet + +instance MixAt Sig (SE Sig) Sig2 where + mixAt k f (dry1, dry2) = do + wet1 <- f dry1 + wet2 <- f dry2 + return $ cfd k (dry1, dry2) (wet1, wet2) + +instance MixAt Sig (SE Sig) Sig3 where + mixAt k f (dry1, dry2, dry3) = do + wet1 <- f dry1 + wet2 <- f dry2 + wet3 <- f dry3 + return $ cfd k (dry1, dry2, dry3) (wet1, wet2, wet3) + +instance MixAt Sig (SE Sig) Sig4 where + mixAt k f (dry1, dry2, dry3, dry4) = do + wet1 <- f dry1 + wet2 <- f dry2 + wet3 <- f dry3 + wet4 <- f dry4 + return $ cfd k (dry1, dry2, dry3, dry4) (wet1, wet2, wet3, wet4) + +instance MixAt Sig (SE Sig) (SE Sig) where + mixAt k f dry = do + dry1 <- dry + wet1 <- f dry1 + return $ cfd k dry1 wet1 + +instance MixAt Sig (SE Sig) (SE Sig2) where + mixAt k f dry = do + (dry1, dry2) <- dry + wet1 <- f dry1 + wet2 <- f dry2 + return $ cfd k (dry1, dry2) (wet1, wet2) + +instance MixAt Sig (SE Sig) (SE Sig3) where + mixAt k f dry = do + (dry1, dry2, dry3) <- dry + wet1 <- f dry1 + wet2 <- f dry2 + wet3 <- f dry3 + return $ cfd k (dry1, dry2, dry3) (wet1, wet2, wet3) + +instance MixAt Sig (SE Sig) (SE Sig4) where + mixAt k f dry = do + (dry1, dry2, dry3, dry4) <- dry + wet1 <- f dry1 + wet2 <- f dry2 + wet3 <- f dry3 + wet4 <- f dry4 + return $ cfd k (dry1, dry2, dry3, dry4) (wet1, wet2, wet3, wet4) + +----------------------------------------------------- +-- mono to stereo + +instance MixAt Sig Sig2 Sig where + mixAt k f dry = cfd k (dry, dry) wet + where wet = f dry + +instance MixAt Sig Sig2 (SE Sig) where + mixAt k f dry = fmap (\x -> cfd k (x, x) (f x)) dry + +instance MixAt Sig Sig2 Sig2 where + mixAt k f dry = cfd k dry wet + where wet = 0.5 * (f (fst dry) + f (snd dry)) + +instance MixAt Sig Sig2 (SE Sig2) where + mixAt k f dry = do + (dry1, dry2) <- dry + let wet = 0.5 * (f dry1 + f dry2) + return $ cfd k (dry1, dry2) wet + +--------------------------------------------------------- + +--------------------------------------------------------- +-- Sig2 -> Sig2 + +instance MixAt Sig2 Sig2 Sig where + mixAt k f dry1 = cfd k dry wet + where + dry = fromMono dry1 + wet = f dry + +instance MixAt Sig2 Sig2 Sig2 where + mixAt k f dry = cfd k dry wet + where + wet = f dry + +instance MixAt Sig2 Sig2 (SE Sig) where + mixAt k f dry1 = do + dry <- fmap fromMono dry1 + let wet = f dry + return $ cfd k dry wet + +instance MixAt Sig2 Sig2 (SE Sig2) where + mixAt k f drySe = do + dry <- drySe + let wet = f dry + return $ cfd k dry wet + + +--------------------------------------------- +-- Sig2 -> SE Sig2 + +instance MixAt Sig2 (SE Sig2) Sig where + mixAt k f dry1 = do + wet <- f dry + return $ cfd k dry wet + where + dry = fromMono dry1 + +instance MixAt Sig2 (SE Sig2) Sig2 where + mixAt k f dry = do + wet <- f dry + return $ cfd k dry wet + +instance MixAt Sig2 (SE Sig2) (SE Sig) where + mixAt k f dry1 = do + dry <- fmap fromMono dry1 + wet <- f dry + return $ cfd k dry wet + +instance MixAt Sig2 (SE Sig2) (SE Sig2) where + mixAt k f drySe = do + dry <- drySe + wet <- f dry + return $ cfd k dry wet diff --git a/src/Csound/Typed/Types/Tuple.hs b/src/Csound/Typed/Types/Tuple.hs --- a/src/Csound/Typed/Types/Tuple.hs +++ b/src/Csound/Typed/Types/Tuple.hs @@ -7,9 +7,7 @@ -- ** Tuple Tuple(..), TupleMethods, makeTupleMethods, fromTuple, toTuple, tupleArity, tupleRates, defTuple, mapTuple, - - Sig2, Sig3, Sig4, Sig5, Sig6, Sig8, - + -- ** Outs Sigs, outArity, @@ -38,6 +36,7 @@ import Csound.Dynamic import Csound.Typed.Types.Prim +import Csound.Typed.Types.SigSpace import Csound.Typed.GlobalState.GE import Csound.Typed.GlobalState.SE import Csound.Typed.Types.TupleHelpers @@ -149,19 +148,15 @@ -- out instances -- | The tuples of signals. -class (Tuple a, Num a) => Sigs a where - -type Sig2 = (Sig, Sig) -type Sig3 = (Sig, Sig, Sig) -type Sig4 = (Sig, Sig, Sig, Sig) -type Sig5 = (Sig, Sig, Sig, Sig, Sig) -type Sig6 = (Sig, Sig, Sig, Sig, Sig, Sig) -type Sig8 = (Sig, Sig, Sig, Sig, Sig, Sig, Sig, Sig) +class (Tuple a, Num a, Fractional a, SigSpace a, BindSig a, SigSpace2 a, BindSig2 a) => Sigs a where instance Sigs Sig instance Sigs Sig2 +instance Sigs Sig3 instance Sigs Sig4 +instance Sigs Sig5 instance Sigs Sig6 +instance Sigs Sig7 instance Sigs Sig8 instance Sigs (Sig2, Sig2) @@ -292,115 +287,5 @@ proxy :: SE a -> a proxy = const undefined - - -------------------------------------------------- --- numeric instances - -instance Num Sig2 where - (a1, a2) + (b1, b2) = (a1 + b1, a2 + b2) - (a1, a2) * (b1, b2) = (a1 * b1, a2 * b2) - negate (a1, a2) = (negate a1, negate a2) - - fromInteger n = (fromInteger n, fromInteger n) - signum (a1, a2) = (signum a1, signum a2) - abs (a1, a2) = (abs a1, abs a2) - -instance Num Sig3 where - (a1, a2, a3) + (b1, b2, b3) = (a1 + b1, a2 + b2, a3 + b3) - (a1, a2, a3) * (b1, b2, b3) = (a1 * b1, a2 * b2, a3 * b3) - negate (a1, a2, a3) = (negate a1, negate a2, negate a3) - - fromInteger n = (fromInteger n, fromInteger n, fromInteger n) - signum (a1, a2, a3) = (signum a1, signum a2, signum a3) - abs (a1, a2, a3) = (abs a1, abs a2, abs a3) - -instance Num Sig4 where - (a1, a2, a3, a4) + (b1, b2, b3, b4) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4) - (a1, a2, a3, a4) * (b1, b2, b3, b4) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4) - negate (a1, a2, a3, a4) = (negate a1, negate a2, negate a3, negate a4) - - fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n) - signum (a1, a2, a3, a4) = (signum a1, signum a2, signum a3, signum a4) - abs (a1, a2, a3, a4) = (abs a1, abs a2, abs a3, abs a4) - -instance Num Sig6 where - (a1, a2, a3, a4, a5, a6) + (b1, b2, b3, b4, b5, b6) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5, a6 + b6) - (a1, a2, a3, a4, a5, a6) * (b1, b2, b3, b4, b5, b6) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4, a5 * b5, a6 * b6) - negate (a1, a2, a3, a4, a5, a6) = (negate a1, negate a2, negate a3, negate a4, negate a5, negate a6) - - fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n) - signum (a1, a2, a3, a4, a5, a6) = (signum a1, signum a2, signum a3, signum a4, signum a5, signum a6) - abs (a1, a2, a3, a4, a5, a6) = (abs a1, abs a2, abs a3, abs a4, abs a5, abs a6) - -instance Num Sig8 where - (a1, a2, a3, a4, a5, a6, a7, a8) + (b1, b2, b3, b4, b5, b6, b7, b8) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5, a6 + b6, a7 + b7, a8 + b8) - (a1, a2, a3, a4, a5, a6, a7, a8) * (b1, b2, b3, b4, b5, b6, b7, b8) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4, a5 * b5, a6 * b6, a7 + b7, a8 + b8) - negate (a1, a2, a3, a4, a5, a6, a7, a8) = (negate a1, negate a2, negate a3, negate a4, negate a5, negate a6, negate a7, negate a8) - - fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n) - signum (a1, a2, a3, a4, a5, a6, a7, a8) = (signum a1, signum a2, signum a3, signum a4, signum a5, signum a6, signum a7, signum a8) - abs (a1, a2, a3, a4, a5, a6, a7, a8) = (abs a1, abs a2, abs a3, abs a4, abs a5, abs a6, abs a7, abs a8) - -instance Num (Sig8, Sig8) where - (a1, a2) + (b1, b2) = (a1 + b1, a2 + b2) - (a1, a2) * (b1, b2) = (a1 * b1, a2 * b2) - negate (a1, a2) = (negate a1, negate a2) - - fromInteger n = (fromInteger n, fromInteger n) - signum (a1, a2) = (signum a1, signum a2) - abs (a1, a2) = (abs a1, abs a2) - -instance Num (Sig8, Sig8, Sig8, Sig8) where - (a1, a2, a3, a4) + (b1, b2, b3, b4) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4) - (a1, a2, a3, a4) * (b1, b2, b3, b4) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4) - negate (a1, a2, a3, a4) = (negate a1, negate a2, negate a3, negate a4) - - fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n) - signum (a1, a2, a3, a4) = (signum a1, signum a2, signum a3, signum a4) - abs (a1, a2, a3, a4) = (abs a1, abs a2, abs a3, abs a4) - -instance Num (Sig2, Sig2) where - (a1, a2) + (b1, b2) = (a1 + b1, a2 + b2) - (a1, a2) * (b1, b2) = (a1 * b1, a2 * b2) - negate (a1, a2) = (negate a1, negate a2) - - fromInteger n = (fromInteger n, fromInteger n) - signum (a1, a2) = (signum a1, signum a2) - abs (a1, a2) = (abs a1, abs a2) - -instance Num (Sig2, Sig2, Sig2) where - (a1, a2, a3) + (b1, b2, b3) = (a1 + b1, a2 + b2, a3 + b3) - (a1, a2, a3) * (b1, b2, b3) = (a1 * b1, a2 * b2, a3 * b3) - negate (a1, a2, a3) = (negate a1, negate a2, negate a3) - - fromInteger n = (fromInteger n, fromInteger n, fromInteger n) - signum (a1, a2, a3) = (signum a1, signum a2, signum a3) - abs (a1, a2, a3) = (abs a1, abs a2, abs a3) - -instance Num (Sig2, Sig2, Sig2, Sig2) where - (a1, a2, a3, a4) + (b1, b2, b3, b4) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4) - (a1, a2, a3, a4) * (b1, b2, b3, b4) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4) - negate (a1, a2, a3, a4) = (negate a1, negate a2, negate a3, negate a4) - - fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n) - signum (a1, a2, a3, a4) = (signum a1, signum a2, signum a3, signum a4) - abs (a1, a2, a3, a4) = (abs a1, abs a2, abs a3, abs a4) - -instance Num (Sig2, Sig2, Sig2, Sig2, Sig2) where - (a1, a2, a3, a4, a5) + (b1, b2, b3, b4, b5) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5) - (a1, a2, a3, a4, a5) * (b1, b2, b3, b4, b5) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4, a5 * b5) - negate (a1, a2, a3, a4, a5) = (negate a1, negate a2, negate a3, negate a4, negate a5) - - fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n) - signum (a1, a2, a3, a4, a5) = (signum a1, signum a2, signum a3, signum a4, signum a5) - abs (a1, a2, a3, a4, a5) = (abs a1, abs a2, abs a3, abs a4, abs a5) - -instance Num (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) where - (a1, a2, a3, a4, a5, a6) + (b1, b2, b3, b4, b5, b6) = (a1 + b1, a2 + b2, a3 + b3, a4 + b4, a5 + b5, a6 + b6) - (a1, a2, a3, a4, a5, a6) * (b1, b2, b3, b4, b5, b6) = (a1 * b1, a2 * b2, a3 * b3, a4 * b4, a5 * b5, a6 * b6) - negate (a1, a2, a3, a4, a5, a6) = (negate a1, negate a2, negate a3, negate a4, negate a5, negate a6) + - fromInteger n = (fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n, fromInteger n) - signum (a1, a2, a3, a4, a5, a6) = (signum a1, signum a2, signum a3, signum a4, signum a5, signum a6) - abs (a1, a2, a3, a4, a5, a6) = (abs a1, abs a2, abs a3, abs a4, abs a5, abs a6)