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.0.9.3 +Version: 0.1.0.0 Cabal-Version: >= 1.22 License: BSD3 License-file: LICENSE @@ -26,7 +26,16 @@ data/opcodes/tabQueue.udo data/opcodes/tabQueue2.udo + data/opcodes/zdf.udo + data/opcodes/solina_chorus.udo + data/opcodes/adsr140.udo + data/opcodes/audaciouseq.udo + data/opcodes/tdf2.udo + data/opcodes/diode.udo + data/opcodes/korg35.udo + data/opcodes/zero-delay-convolution.udo + Homepage: https://github.com/anton-k/csound-expression-typed Bug-Reports: https://github.com/anton-k/csound-expression-typed/issues @@ -39,7 +48,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.1.6, temporal-media >= 0.6.0, hashable + wl-pprint, csound-expression-dynamic >= 0.2.0, temporal-media >= 0.6.0, hashable Hs-Source-Dirs: src/ Exposed-Modules: Csound.Typed @@ -49,12 +58,15 @@ Csound.Typed.Render Csound.Typed.Gui + Csound.Typed.Gui.Cab Csound.Typed.Types.Prim Csound.Typed.Types.Evt Csound.Typed.Types.Tuple Csound.Typed.Types.Lift + Csound.Typed.Plugins + Other-Modules: Csound.Typed.GlobalState Csound.Typed.GlobalState.Options @@ -82,14 +94,20 @@ Csound.Typed.Gui.Gui Csound.Typed.Gui.Widget Csound.Typed.Gui.BoxModel + Csound.Typed.Gui.Cabbage.CabbageLang + Csound.Typed.Gui.Cabbage.Cabbage Csound.Typed.Constants Csound.Typed.Misc - Csound.Typed.Lib.StableMaps.Dynamic - Csound.Typed.Lib.StableMaps.Dynamic.Map - Csound.Typed.Plugins.TabQueue + Csound.Typed.Plugins.Zdf + Csound.Typed.Plugins.Diode + Csound.Typed.Plugins.Korg35 + Csound.Typed.Plugins.Adsr140 + Csound.Typed.Plugins.Audaciouseq + Csound.Typed.Plugins.SolinaChorus + Csound.Typed.Plugins.ZeroDelayConvolution Paths_csound_expression_typed diff --git a/data/opcodes/adsr140.udo b/data/opcodes/adsr140.udo new file mode 100644 --- /dev/null +++ b/data/opcodes/adsr140.udo @@ -0,0 +1,111 @@ +; Gated, Retriggerable Envelope Generator UDO (adsr140) +; Based on design of Doepfer A-140 Envelope Generator Module +; Code based on ADSR code by Nigel Redmon +; (http://www.earlevel.com/main/2013/06/03/envelope-generators-adsr-code/) +; Example by Steven Yi (2015.02.08) + +opcode adsr140_calc_coef, k, kk + + knum_samps, kratio xin + xout exp( -log((1.0 + kratio) / kratio) / knum_samps) + +endop + +/* Gated, Re-triggerable ADSR modeled after the Doepfer A-140 */ +opcode adsr140, a, aakkkk + +agate, aretrig, kattack, kdecay, ksustain, krelease xin + +kstate init 0 ; 0 = attack, 1 = decay, 2 = sustain +klasttrig init -1 +kval init 0.0 +asig init 0 +kindx = 0 + +kattack_base init 0 +kdecay_base init 0 +krelease_base init 0 + +kattack_samps init 0 +kdecay_samps init 0 +krelease_samps init 0 + +kattack_coef init 0 +kdecay_coef init 0 +ksustain_coef init 0 + +klast_attack init -1 +klast_decay init -1 +klast_release init -1 + +if (klast_attack != kattack) then + klast_attack = kattack + kattack_samps = kattack * sr + kattack_coef = adsr140_calc_coef(kattack_samps, 0.3) + kattack_base = (1.0 + 0.3) * (1 - kattack_coef) +endif + +if (klast_decay != kdecay) then + klast_decay = kdecay + kdecay_samps = kdecay * sr + kdecay_coef = adsr140_calc_coef(kdecay_samps, 0.0001) + kdecay_base = (ksustain - 0.0001) * (1.0 - kdecay_coef) +endif + +if (klast_release != krelease) then + klast_release = krelease + krelease_samps = krelease * sr + krelease_coef = adsr140_calc_coef(krelease_samps, 0.0001) + krelease_base = -0.0001 * (1.0 - krelease_coef) +endif + + +while (kindx < ksmps) do + if (agate[kindx] > 0) then + kretrig = aretrig[kindx] + if (kretrig > 0 && klasttrig <= 0) then + kstate = 0 + endif + klasttrig = kretrig + + if (kstate == 0) then + kval = kattack_base + (kval * kattack_coef) + if(kval >= 1.0) then + kval = 1.0 + kstate = 1 + endif + asig[kindx] = kval + + elseif (kstate == 1) then + kval = kdecay_base + (kval * kdecay_coef) + if(kval <= ksustain) then + kval = ksustain + kstate = 2 + endif + asig[kindx] = kval + + else + asig[kindx] = ksustain + endif + + else ; in a release state + kstate = 0 + if (kval == 0.0) then + asig[kindx] = 0 + else + ; releasing + kval = krelease_base + (kval * krelease_coef) + if(kval <= 0.0) then + kval = 0.0 + endif + asig[kindx] = kval + endif + + endif + + kindx += 1 +od + +xout asig + +endop diff --git a/data/opcodes/audaciouseq.udo b/data/opcodes/audaciouseq.udo new file mode 100644 --- /dev/null +++ b/data/opcodes/audaciouseq.udo @@ -0,0 +1,81 @@ +/* audaciouseq - multi-band equalizer + + A Csound UDO implementation of Audacious' EQ: + + https://github.com/audacious-media-player/audacious/blob/master/src/libaudcore/equalizer.cc + +*/ + + +/* Q value for band-pass filters 1.2247 = (3/2)^(1/2) + * Gives 4 dB suppression at Fc*2 and Fc/2 */ + +#define Q # 1.2247449 # + +/* single-sample, 2nd order IIR filter */ +opcode audacious_bp2, k, kik +kin, ifC, kgain xin + +;; Calc Coefficients +ith = 2 * $M_PI * (ifC / sr) +iC = (1 - tan(ith * $Q / 2)) / (1 + tan(ith * $Q / 2)) + +ia0 = (1 + iC) * cos(ith) +ia1 = -iC +ib0 = (1 - iC) / 2 +ib1 = -1.005 + +kout init 0 +kwq0 init 0 +kwq1 init 0 + +kG = pow(10, kgain / 20) - 1 + +;; Filter Code +kyt = kin +kw = kyt * ib0 + kwq0 * ia0 + kwq1 * ia1 +kyt += (kw + kwq1 * ib1) * kG + +;; Memory +kwq1 = kwq0 +kwq0 = kw + +xout kyt +endop + +/* 10-band EQ + Input: asig, kgain1, kgain2, ... + Output: aout + + 10 kgain arguments maps to each band + Bands are: 31.25, 52.6, 125, 500, 1000, + 2000, 4000, 8000, 16000 +*/ +opcode audaciouseq, a, akkkkkkkkkk + +ain, kgain1, kgain2, kgain3, kgain4, kgain5, + kgain6, kgain7, kgain8, kgain9, kgain10 xin + +aout = 0 +kndx = 0 + +while (kndx < ksmps) do + ksamp audacious_bp2 ain[kndx], 31.25, kgain1 + ksamp audacious_bp2 ksamp, 62.5, kgain2 + ksamp audacious_bp2 ksamp, 125, kgain3 + ksamp audacious_bp2 ksamp, 250, kgain4 + ksamp audacious_bp2 ksamp, 500, kgain5 + ksamp audacious_bp2 ksamp, 1000, kgain6 + ksamp audacious_bp2 ksamp, 2000, kgain7 + ksamp audacious_bp2 ksamp, 4000, kgain8 + ksamp audacious_bp2 ksamp, 8000, kgain9 + aout[kndx] audacious_bp2 ksamp, 16000, kgain10 + + kndx += 1 +od + +xout aout + +endop + + diff --git a/data/opcodes/diode.udo b/data/opcodes/diode.udo new file mode 100644 --- /dev/null +++ b/data/opcodes/diode.udo @@ -0,0 +1,342 @@ +;; Diode Ladder Filter +;; +;; Based on code by Will Pirkle, presented in: +;; +;; http://www.willpirkle.com/Downloads/AN-6DiodeLadderFilter.pdf +;; +;; and in his book "Designing software synthesizer plug-ins in C++ : for +;; RackAFX, VST3, and Audio Units" +;; +;; UDO version by Steven Yi (2016.xx.xx) + +;; ARGS +;; ain - signal to filter +;; acf/kcf - cutoff frequency +;; ak/kk - k-value that controls resonance, self-resonance occurs at k=17; +;; knlp - use non-linear processing: +;; 0 - none +;; 1 - normalized (outputs to range +-1.0) +;; 2 - non-normalized (less expensive than normalized, range +-0.8) +;; ksaturation - saturation amount for non-linear processing +;; (default: 1.0, greater values lead to higher saturation) + + +opcode diode_ladder, a, aKKKK + + ain, kcf, kk, knlp, ksaturation xin + + ;; initialization + aout init 0 + + ka1 init 1.0 + ka2 init 0.5 + ka3 init 0.5 + ka4 init 0.5 + + ;; state for each 1-pole's integrator + kz1 init 0 + kz2 init 0 + kz3 init 0 + kz4 init 0 + + ;; coefficients + kG1 init 0 + kG2 init 0 + kG3 init 0 + kG4 init 0 + + kbeta1 init 0 + kbeta2 init 0 + kbeta3 init 0 + kbeta4 init 0 + + kdelta1 init 0 + kdelta2 init 0 + kdelta3 init 0 + + kepsilon1 init 0 + kepsilon2 init 0 + kepsilon3 init 0 + + kSG1 init 0 + kSG2 init 0 + kSG3 init 0 + kSG4 init 0 + + kSIGMA init 0 + kGAMMA init 0 + + klastcut init -1 + + if (klastcut != kcf) then + ; pre-warp the cutoff- these are bilinear-transform filters + kwd = 2 * $M_PI * kcf + iT = 1/sr + kwa = (2/iT) * tan(kwd * iT/2) + kg = kwa * iT/2 + + kG4 = 0.5 * kg / (1.0 + kg) + kG3 = 0.5 * kg / (1.0 + kg - 0.5 * kg * kG4) + kG2 = 0.5 * kg / (1.0 + kg - 0.5 * kg * kG3) + kG1 = kg / (1.0 + kg - kg * kG2) + + kGAMMA = kG4 * kG3 * kG2 * kG1 + + kSG1 = kG4 * kG3 * kG2 + kSG2 = kG4 * kG3 + kSG3 = kG4 + kSG4 = 1.0 + + kalpha = kg / (1.0 + kg) + + kbeta1 = 1.0 / (1.0 + kg - kg * kG2) + kbeta2 = 1.0 / (1.0 + kg - 0.5 * kg * kG3) + kbeta3 = 1.0 / (1.0 + kg - 0.5 * kg * kG4) + kbeta4 = 1.0 / (1.0 + kg) + + kgamma1 = 1.0 + kG1 * kG2 + kgamma2 = 1.0 + kG2 * kG3 + kgamma3 = 1.0 + kG3 * kG4 + + kdelta1 = kg + kdelta2 = 0.5 * kg + kdelta3 = 0.5 * kg + + kepsilon1 = kG2 + kepsilon2 = kG3 + kepsilon3 = kG4 + + endif + + klastcut = kcf + + kindx = 0 + + while kindx < ksmps do + + kin = ain[kindx] + + ;; feedback inputs + kfb4 = kbeta4 * kz4 + kfb3 = kbeta3 * (kz3 + kfb4 * kdelta3) + kfb2 = kbeta2 * (kz2 + kfb3 * kdelta2) + + ;; feedback process + + kfbo1 = (kbeta1 * (kz1 + kfb2 * kdelta1)) + kfbo2 = (kbeta2 * (kz2 + kfb3 * kdelta2)) + kfbo3 = (kbeta3 * (kz3 + kfb4 * kdelta3)) + kfbo4 = kfb4 + + kSIGMA = kSG1 * kfbo1 + + kSG2 * kfbo2 + + kSG3 * kfbo3 + + kSG4 * kfbo4 + + ;; non-linear processing + if (knlp == 1) then + kin = (1.0 / tanh(ksaturation)) * tanh(ksaturation * kin) + elseif (knlp == 2) then + kin = tanh(ksaturation * kin) + endif + + ;; form input to loop + kun = (kin - kk * kSIGMA) / (1.0 + kk * kGAMMA) + + ;; 1st stage + kxin = (kun * kgamma1 + kfb2 + kepsilon1 * kfbo1) + kv = (ka1 * kxin - kz1) * kalpha + klp = kv + kz1 + kz1 = klp + kv + + ;; 2nd stage + kxin = (klp * kgamma2 + kfb3 + kepsilon2 * kfbo2) + kv = (ka2 * kxin - kz2) * kalpha + klp = kv + kz2 + kz2 = klp + kv + + ;; 3rd stage + kxin = (klp * kgamma3 + kfb4 + kepsilon3 * kfbo3) + kv = (ka3 * kxin - kz3) * kalpha + klp = kv + kz3 + kz3 = klp + kv + + ;; 4th stage + kv = (ka4 * klp - kz4) * kalpha + klp = kv + kz4 + kz4 = klp + kv + + aout[kindx] = klp + + kindx += 1 + od + + xout aout + +endop + + +opcode diode_ladder, a, aaaKK + + ain, acf, ak, knlp, ksaturation xin + + ;; initialization + aout init 0 + + ka1 init 1.0 + ka2 init 0.5 + ka3 init 0.5 + ka4 init 0.5 + + ;; state for each 1-pole's integrator + kz1 init 0 + kz2 init 0 + kz3 init 0 + kz4 init 0 + + ;; coefficients + kG1 init 0 + kG2 init 0 + kG3 init 0 + kG4 init 0 + + kbeta1 init 0 + kbeta2 init 0 + kbeta3 init 0 + kbeta4 init 0 + + kdelta1 init 0 + kdelta2 init 0 + kdelta3 init 0 + + kepsilon1 init 0 + kepsilon2 init 0 + kepsilon3 init 0 + + kSG1 init 0 + kSG2 init 0 + kSG3 init 0 + kSG4 init 0 + + kSIGMA init 0 + kGAMMA init 0 + + klastcut init 0 + + kindx = 0 + + while kindx < ksmps do + + kin = ain[kindx] + kcf = acf[kindx] + kk = ak[kindx] + + if (klastcut != kcf) then + ; pre-warp the cutoff- these are bilinear-transform filters + kwd = 2 * $M_PI * kcf + iT = 1/sr + kwa = (2/iT) * tan(kwd * iT/2) + kg = kwa * iT/2 + + kG4 = 0.5 * kg / (1.0 + kg) + kG3 = 0.5 * kg / (1.0 + kg - 0.5 * kg * kG4) + kG2 = 0.5 * kg / (1.0 + kg - 0.5 * kg * kG3) + kG1 = kg / (1.0 + kg - kg * kG2) + + kGAMMA = kG4 * kG3 * kG2 * kG1 + + kSG1 = kG4 * kG3 * kG2 + kSG2 = kG4 * kG3 + kSG3 = kG4 + kSG4 = 1.0 + + kalpha = kg / (1.0 + kg) + + kbeta1 = 1.0 / (1.0 + kg - kg * kG2) + kbeta2 = 1.0 / (1.0 + kg - 0.5 * kg * kG3) + kbeta3 = 1.0 / (1.0 + kg - 0.5 * kg * kG4) + kbeta4 = 1.0 / (1.0 + kg) + + kgamma1 = 1.0 + kG1 * kG2 + kgamma2 = 1.0 + kG2 * kG3 + kgamma3 = 1.0 + kG3 * kG4 + + kdelta1 = kg + kdelta2 = 0.5 * kg + kdelta3 = 0.5 * kg + + kepsilon1 = kG2 + kepsilon2 = kG3 + kepsilon3 = kG4 + + endif + + klastcut = kcf + + ;; feedback inputs + kfb4 = kbeta4 * kz4 + kfb3 = kbeta3 * (kz3 + kfb4 * kdelta3) + kfb2 = kbeta2 * (kz2 + kfb3 * kdelta2) + + ;; feedback process + + kfbo1 = (kbeta1 * (kz1 + kfb2 * kdelta1)) + kfbo2 = (kbeta2 * (kz2 + kfb3 * kdelta2)) + kfbo3 = (kbeta3 * (kz3 + kfb4 * kdelta3)) + kfbo4 = kfb4 + + kSIGMA = kSG1 * kfbo1 + + kSG2 * kfbo2 + + kSG3 * kfbo3 + + kSG4 * kfb4 + + ;; non-linear processing + if (knlp == 1) then + kin = (1.0 / tanh(ksaturation)) * tanh(ksaturation * kin) + elseif (knlp == 2) then + kin = tanh(ksaturation * kin) + endif + + ;; form input to loop + kun = (kin - kk * kSIGMA) / (1.0 + kk * kGAMMA) + + ;; 1st stage + kxin = (kun * kgamma1 + kfb2 + kepsilon1 * kfbo1) + kv = (ka1 * kxin - kz1) * kalpha + klp = kv + kz1 + kz1 = klp + kv + + ;; 2nd stage + kxin = (klp * kgamma2 + kfb3 + kepsilon2 * kfbo2) + kv = (ka2 * kxin - kz2) * kalpha + klp = kv + kz2 + kz2 = klp + kv + + ;; 3rd stage + kxin = (klp * kgamma3 + kfb4 + kepsilon3 * kfbo3) + kv = (ka3 * kxin - kz3) * kalpha + klp = kv + kz3 + kz3 = klp + kv + + ;; 4th stage + kv = (ka4 * klp - kz4) * kalpha + klp = kv + kz4 + kz4 = klp + kv + + aout[kindx] = klp + + kindx += 1 + od + + xout aout + +endop + +opcode diode_ladder, a, aaKKK + + ain, acf, kk, knlp, ksaturation xin + ares diode_ladder ain, acf, a(kk), knlp, ksaturation + + xout ares +endop + diff --git a/data/opcodes/korg35.udo b/data/opcodes/korg35.udo new file mode 100644 --- /dev/null +++ b/data/opcodes/korg35.udo @@ -0,0 +1,385 @@ +;; 12db/oct low-pass filter based on Korg 35 module +;; (found in MS-10 and MS-20). +;; +;; Based on code by Will Pirkle, presented in: +;; +;; http://www.willpirkle.com/Downloads/AN-5Korg35_V3.pdf +;; +;; [ARGS] +;; +;; ain - audio input +;; acutoff - frequency of cutoff +;; kQ - filter Q [1, 10.0] (k35-lpf will clamp to boundaries) +;; knonlinear - use non-linear processing +;; ksaturation - saturation for tanh distortion +opcode k35_lpf, a, aKKKK + + ain, kcutoff, kQ, knonlinear, ksaturation xin + + kz1 init 0 + kz2 init 0 + kz3 init 0 + kv1 init 0 + kv2 init 0 + kv3 init 0 + aout init 0 + + kg init 0 + kG init 0 + kK init 0 + klastcut init -1 + klastQ init -1 + kS35 init 0 + kalpha init -1 + klpf2_beta init -1 + khpf1_beta init -1 + + kindx = 0 + kQ = limit(kQ, 1.0, 10.0) + kcf = kcutoff + + if (klastcut != kcf) then + ; pre-warp the cutoff- these are bilinear-transform filters + kwd = 2 * $M_PI * kcf + iT = 1/sr + kwa = (2/iT) * tan(kwd * iT/2) + kg = kwa * iT/2 + kG = kg / (1 + kg) + + endif + + if (klastQ != kQ) then + kK = 0.01 + ((2.0 - 0.01) * (kQ / 10.0)) + endif + + if ((klastcut != kcf) || (klastQ != kQ)) then + klpf2_beta = (kK - (kK * kG)) / (1.0 + kg) + khpf1_beta = -1.0 / (1.0 + kg) + kalpha = 1.0 / (1.0 - (kK * kG) + (kK * kG * kG)) + endif + + klastcut = kcf + klastQ = kQ + + while (kindx < ksmps) do + ksig = ain[kindx] + + ;; lpf1 + kv1 = (ksig - kz1) * kG + klp1 = kv1 + kz1 + kz1 = klp1 + kv1 + + ku = kalpha * (klp1 + kS35) + + if (knonlinear == 1) then + ku = tanh(ku * ksaturation) + endif + + ;; lpf2 + kv2 = (ku - kz2) * kG + klp2 = kv2 + kz2 + kz2 = klp2 + kv2 + ky = kK * klp2 + + ;; hpf1 + kv3 = (ky - kz3) * kG + klp3 = kv3 + kz3 + kz3 = klp3 + kv3 + khp1 = ky - klp3 + + kS35 = (klpf2_beta * kz2) + (khpf1_beta * kz3) + + kout = (kK > 0) ? (ky / kK) : ky + + aout[kindx] = kout + + kindx += 1 + od + + xout aout + +endop + + + +opcode k35_lpf, a, aaKKK + + ain, acutoff, kQ, knonlinear, ksaturation xin + + kz1 init 0 + kz2 init 0 + kz3 init 0 + kv1 init 0 + kv2 init 0 + kv3 init 0 + aout init 0 + + kg init 0 + kG init 0 + kK init 0 + klastcut init -1 + klastQ init -1 + kS35 init 0 + kalpha init -1 + klpf2_beta init -1 + khpf1_beta init -1 + + kindx = 0 + kQ = limit(kQ, 1.0, 10.0) + + if (klastQ != kQ) then + kK = 0.01 + ((2.0 - 0.01) * (kQ / 10.0)) + endif + + klastQ = kQ + + while (kindx < ksmps) do + kcf = acutoff[kindx] + ksig = ain[kindx] + + if (klastcut != kcf) then + ; pre-warp the cutoff- these are bilinear-transform filters + kwd = 2 * $M_PI * kcf + iT = 1/sr + kwa = (2/iT) * tan(kwd * iT/2) + kg = kwa * iT/2 + kG = kg / (1 + kg) + + endif + + if ((klastcut != kcf) || (klastQ != kQ)) then + klpf2_beta = (kK - (kK * kG)) / (1.0 + kg) + khpf1_beta = -1.0 / (1.0 + kg) + kalpha = 1.0 / (1.0 - (kK * kG) + (kK * kG * kG)) + endif + + ;; lpf1 + kv1 = (ksig - kz1) * kG + klp1 = kv1 + kz1 + kz1 = klp1 + kv1 + + ku = kalpha * (klp1 + kS35) + + if (knonlinear == 1) then + ku = tanh(ku * ksaturation) + endif + + ;; lpf2 + kv2 = (ku - kz2) * kG + klp2 = kv2 + kz2 + kz2 = klp2 + kv2 + ky = kK * klp2 + + ;; hpf1 + kv3 = (ky - kz3) * kG + klp3 = kv3 + kz3 + kz3 = klp3 + kv3 + khp1 = ky - klp3 + + kS35 = (klpf2_beta * kz2) + (khpf1_beta * kz3) + + kout = (kK > 0) ? (ky / kK) : ky + + aout[kindx] = kout + + klastcut = kcf + kindx += 1 + od + + xout aout + +endop + +;; 6db/oct high-pass filter based on Korg 35 module +;; (found in MS-10 and MS-20). +;; +;; Based on code by Will Pirkle, presented in: +;; +;; http://www.willpirkle.com/Downloads/AN-7Korg35HPF_V2.pdf +;; +;; [ARGS] +;; +;; ain - audio input +;; acutoff - frequency of cutoff +;; kQ - filter Q [1, 10.0] (k35_hpf will clamp to boundaries) +;; knonlinear - use non-linear processing +;; ksaturation - saturation for tanh distortion + +opcode k35_hpf, a, aKKKK + + ain, kcutoff, kQ, knonlinear, ksaturation xin + + kz1 init 0 + kz2 init 0 + kz3 init 0 + kv1 init 0 + kv2 init 0 + kv3 init 0 + aout init 0 + + kg init 0 + kG init 0 + kK init 0 + klastcut init -1 + klastQ init -1 + kS35 init 0 + kalpha init -1 + khpf2_beta init -1 + klpf1_beta init -1 + + kindx = 0 + kQ = limit(kQ, 1.0, 10.0) + kcf = kcutoff + + if (klastcut != kcf) then + ; pre-warp the cutoff- these are bilinear-transform filters + kwd = 2 * $M_PI * kcf + iT = 1/sr + kwa = (2/iT) * tan(kwd * iT/2) + kg = kwa * iT/2 + kG = kg / (1 + kg) + + endif + + if (klastQ != kQ) then + kK = 0.01 + ((2.0 - 0.01) * (kQ / 10.0)) + endif + + if ((klastcut != kcf) || (klastQ != kQ)) then + khpf2_beta = -kG / (1.0 + kg) + klpf1_beta = 1.0 / (1.0 + kg) + kalpha = 1.0 / (1.0 - (kK * kG) + (kK * kG * kG)) + endif + + klastcut = kcf + klastQ = kQ + + while (kindx < ksmps) do + ksig = ain[kindx] + + ;; hpf1 + kv1 = (ksig - kz1) * kG + klp1 = kv1 + kz1 + kz1 = klp1 + kv1 + ky1 = ksig - klp1 + + ku = kalpha * (ky1 + kS35) + ky = kK * ku + + if (knonlinear == 1) then + ky = tanh(ky * ksaturation) + endif + + ;; hpf2 + kv2 = (ky - kz2) * kG + klp2 = kv2 + kz2 + kz2 = klp2 + kv2 + khp2 = ky - klp2 + + ;; lpf1 + kv3 = (khp2 - kz3) * kG + klp3 = kv3 + kz3 + kz3 = klp3 + kv3 + + kS35 = (khpf2_beta * kz2) + (klpf1_beta * kz3) + + kout = (kK > 0) ? (ky / kK) : ky + + aout[kindx] = kout + + kindx += 1 + od + + xout aout + +endop + + +opcode k35_hpf, a, aaKKK + + ain, acutoff, kQ, knonlinear, ksaturation xin + + kz1 init 0 + kz2 init 0 + kz3 init 0 + kv1 init 0 + kv2 init 0 + kv3 init 0 + aout init 0 + + kg init 0 + kG init 0 + kK init 0 + klastcut init -1 + klastQ init -1 + kS35 init 0 + kalpha init -1 + khpf2_beta init -1 + klpf1_beta init -1 + + kindx = 0 + kQ = limit(kQ, 1.0, 10.0) + + if (klastQ != kQ) then + kK = 0.01 + ((2.0 - 0.01) * (kQ / 10.0)) + endif + + klastQ = kQ + + while (kindx < ksmps) do + kcf = acutoff[kindx] + ksig = ain[kindx] + + if (klastcut != kcf) then + ; pre-warp the cutoff- these are bilinear-transform filters + kwd = 2 * $M_PI * kcf + iT = 1/sr + kwa = (2/iT) * tan(kwd * iT/2) + kg = kwa * iT/2 + kG = kg / (1 + kg) + + endif + + if ((klastcut != kcf) || (klastQ != kQ)) then + khpf2_beta = -kG / (1.0 + kg) + klpf1_beta = 1.0 / (1.0 + kg) + kalpha = 1.0 / (1.0 - (kK * kG) + (kK * kG * kG)) + endif + + ;; hpf1 + kv1 = (ksig - kz1) * kG + klp1 = kv1 + kz1 + kz1 = klp1 + kv1 + ky1 = ksig - klp1 + + ku = kalpha * (ky1 + kS35) + ky = kK * ku + + if (knonlinear == 1) then + ky = tanh(ky * ksaturation) + endif + + ;; hpf2 + kv2 = (ky - kz2) * kG + klp2 = kv2 + kz2 + kz2 = klp2 + kv2 + khp2 = ky - klp2 + + ;; lpf1 + kv3 = (khp2 - kz3) * kG + klp3 = kv3 + kz3 + kz3 = klp3 + kv3 + + kS35 = (khpf2_beta * kz2) + (klpf1_beta * kz3) + + kout = (kK > 0) ? (ky / kK) : ky + + aout[kindx] = kout + + klastcut = kcf + kindx += 1 + od + + xout aout + +endop diff --git a/data/opcodes/solina_chorus.udo b/data/opcodes/solina_chorus.udo new file mode 100644 --- /dev/null +++ b/data/opcodes/solina_chorus.udo @@ -0,0 +1,56 @@ +/* Solina Chorus, based on Solina String Ensemble Chorus Module + + based on: + + J. Haible: Triple Chorus + http://jhaible.com/legacy/triple_chorus/triple_chorus.html + + Hugo Portillo: Solina-V String Ensemble + http://www.native-instruments.com/en/reaktor-community/reaktor-user-library/entry/show/4525/ + + Parabola tabled shape borrowed from Iain McCurdy delayStereoChorus.csd: + http://iainmccurdy.org/CsoundRealtimeExamples/Delays/delayStereoChorus.csd + + Author: Steven Yi + Date: 2016.05.22 + + */ + + +gi_solina_parabola ftgen 0, 0, 65537, 19, 0.5, 1, 180, 1 + +;; 3 sine wave LFOs, 120 degrees out of phase +opcode sol_lfo_3, aaa, KK + kfreq, kamp xin + + aphs phasor kfreq + + a0 = tablei(aphs, gi_solina_parabola, 1, 0, 1) + a120 = tablei(aphs, gi_solina_parabola, 1, 0.333, 1) + a240 = tablei(aphs, gi_solina_parabola, 1, -0.333, 1) + + xout (a0 * kamp), (a120 * kamp), (a240 * kamp) +endop + +opcode solina_chorus, a, aKKKK + + aLeft, klfo_freq1, klfo_amp1, klfo_freq2, klfo_amp2 xin + + imax = 100 + + ;; slow lfo + as1, as2, as3 sol_lfo_3 klfo_freq1, klfo_amp1 + + ;; fast lfo + af1, af2, af3 sol_lfo_3 klfo_freq2, klfo_amp2 + + at1 = limit(as1 + af1 + 5, 0.0, imax) + at2 = limit(as2 + af2 + 5, 0.0, imax) + at3 = limit(as3 + af3 + 5, 0.0, imax) + + a1 vdelay3 aLeft, at1, imax + a2 vdelay3 aLeft, at2, imax + a3 vdelay3 aLeft, at3, imax + +xout (a1 + a2 + a3) / 3 +endop diff --git a/data/opcodes/tdf2.udo b/data/opcodes/tdf2.udo new file mode 100644 --- /dev/null +++ b/data/opcodes/tdf2.udo @@ -0,0 +1,166 @@ + + +/* + Transposed Direct Form II Biquad + + Based on C++ code by Nigel Redmon: + http://www.earlevel.com/main/2012/11/26/biquad-c-source-code/ + + + OUTPUT + aout - filtered signal + + INPUT + asig - input signal + ifilter_type - filter type: + 0 - Low Pass + 1 - High Pass + 2 - Band Pass + 3 - Notch + 4 - Peaking + 5 - Low Shelf + 6 - High Shelf + acutoff - cutoff frequency + aQ - Q value + again - gain (used by peaking, low shelf, and high shelf) + +*/ +opcode tdf2, a, aiaaa + +asig, ifilter_type, acutoff, aQ, again xin + +/* Memory */ +kz1 init 0 +kz2 init 0 + +klast_Fc init 0 +klast_Q init 0 +klast_gain init 0 + +ka0 init 0 +ka1 init 0 +ka2 init 0 +kb1 init 0 +kb2 init 0 + +aout init 0 + + +kndx = 0 +while (kndx < ksmps) do + kcut = acutoff[kndx] + kQ = aQ[kndx] + kgain = again[kndx] + + if(kcut != klast_Fc || kQ != klast_Q || kgain != klast_gain) then + + kK = tan($M_PI * (kcut / sr)) + kV = pow(10, abs(kgain) / 20.0) + kK2 = kK * kK + + if (ifilter_type == 0) then ;; LPF + knorm = 1 / (1 + kK / kQ + kK2) + ka0 = kK2 * knorm + ka1 = 2 * ka0 + ka2 = ka0 + kb1 = 2 * (kK2 - 1) * knorm + kb2 = (1 - kK / kQ + kK2) * knorm + + elseif (ifilter_type == 1) then ;; HPF + knorm = 1 / (1 + kK / kQ + kK2) + ka0 = 1 * knorm + ka1 = -2 * ka0 + ka2 = ka0 + kb1 = 2 * (kK2 - 1) * knorm + kb2 = (1 - kK / kQ + kK2) * knorm + + elseif (ifilter_type == 2) then ;; BPF + knorm = 1 / (1 + kK / kQ + kK2) + ka0 = kK / kQ * knorm + ka1 = 0 + ka2 = -ka0 + kb1 = 2 * (kK2 - 1) * knorm + kb2 = (1 - kK / kQ + kK2) * knorm + + elseif (ifilter_type == 3) then ;; Notch + knorm = 1 / (1 + kK / kQ + kK2) + ka0 = (1 + kK2) * knorm + ka1 = 2 * (kK2 - 1) * knorm + ka2 = ka0 + kb1 = ka1 + kb2 = (1 - kK / kQ + kK2) * knorm + + elseif (ifilter_type == 4) then ;; Peaking + if (kgain >= 0) then ;; boost + knorm = 1 / (1 + kK/kQ + kK2); + ka0 = (1 + kV/kQ * kK + kK2) * knorm; + ka1 = 2 * (kK2 - 1) * knorm; + ka2 = (1 - kV/kQ * kK + kK2) * knorm; + kb1 = ka1; + kb2 = (1 - 1/kQ * kK + kK2) * knorm; + else ;; cut + knorm = 1 / (1 + kV/kQ * kK + kK2) + ka0 = (1 + kK/kQ + kK2) * knorm + ka1 = 2 * (kK2 - 1) * knorm + ka2 = (1 - kK/kQ + kK2) * knorm + kb1 = ka1 + kb2 = (1 - kV/kQ * kK + kK2) * knorm + endif + + elseif (ifilter_type == 5) then ;; Low Shelf + if (kgain >= 0) then ;; boost + knorm = 1 / (1 + sqrt(2) * kK + kK2) + ka0 = (1 + sqrt(2*kV) * kK + kV * kK2) * knorm + ka1 = 2 * (kV * kK2 - 1) * knorm + ka2 = (1 - sqrt(2*kV) * kK + kV * kK2) * knorm + kb1 = 2 * (kK2 - 1) * knorm + kb2 = (1 - sqrt(2) * kK + kK2) * knorm + else ;; cut + knorm = 1 / (1 + sqrt(2*kV) * kK + kV * kK2) + ka0 = (1 + sqrt(2) * kK + kK2) * knorm + ka1 = 2 * (kK2 - 1) * knorm + ka2 = (1 - sqrt(2) * kK + kK2) * knorm + kb1 = 2 * (kV * kK2 - 1) * knorm + kb2 = (1 - sqrt(2*kV) * kK + kV * kK2) * knorm + endif + + elseif (ifilter_type == 6) then ;; High Shelf + if (kgain >= 0) then ;; boost + knorm = 1 / (1 + sqrt(2) * kK + kK2) + ka0 = (kV + sqrt(2*kV) * kK + kK2) * knorm + ka1 = 2 * (kK2 - kV) * knorm + ka2 = (kV - sqrt(2*kV) * kK + kK2) * knorm + kb1 = 2 * (kK2 - 1) * knorm + kb2 = (1 - sqrt(2) * kK + kK2) * knorm + else ;; cut + knorm = 1 / (kV + sqrt(2*kV) * kK + kK2) + ka0 = (1 + sqrt(2) * kK + kK2) * knorm + ka1 = 2 * (kK2 - 1) * knorm + ka2 = (1 - sqrt(2) * kK + kK2) * knorm + kb1 = 2 * (kK2 - kV) * knorm + kb2 = (kV - sqrt(2*kV) * kK + kK2) * knorm + endif + + endif + endif + + kin = asig[kndx] + + /* TDF2 Biquad Calculation */ + kout = kin * ka0 + kz1 + kz1 = kin * ka1 + kz2 - kb1 * kout + kz2 = kin * ka2 - kb2 * kout + + /* Output, state saving for next pass */ + aout[kndx] = kout + + klast_Fc = kcut + klast_Q = kQ + + kndx += 1 +od + +xout aout + +endop + diff --git a/data/opcodes/zdf.udo b/data/opcodes/zdf.udo new file mode 100644 --- /dev/null +++ b/data/opcodes/zdf.udo @@ -0,0 +1,540 @@ + +; Zero Delay Feedback Filters +; +; Based on code by Will Pirkle, presented in: +; +; http://www.willpirkle.com/Downloads/AN-4VirtualAnalogFilters.2.0.pdf +; +; and in his book "Designing software synthesizer plug-ins in C++ : for +; RackAFX, VST3, and Audio Units" +; +; ZDF using Trapezoidal integrator by Vadim Zavalishin, presented in "The Art +; of VA Filter Design" (https://www.native-instruments.com/fileadmin/ni_media/ +; downloads/pdf/VAFilterDesign_1.1.1.pdf) +; +; UDO versions by Steven Yi (2016.xx.xx) + + +;; 1-pole (6dB) lowpass/highpass filter +;; takes in a a-rate signal and cutoff value in frequency +opcode zdf_1pole, aa, ak + ain, kcf xin + + ; pre-warp the cutoff- these are bilinear-transform filters + kwd = 2 * $M_PI * kcf + iT = 1/sr + kwa = (2/iT) * tan(kwd * iT/2) + kg = kwa * iT/2 + + ; big combined value + kG = kg / (1.0 + kg) + + ahp init 0 + alp init 0 + + ;; state for integrators + kz1 init 0 + + kindx = 0 + while kindx < ksmps do + ; do the filter, see VA book p. 46 + ; form sub-node value v(n) + kin = ain[kindx] + kv = (kin - kz1) * kG + + ; form output of node + register + klp = kv + kz1 + khp = kin - klp + + ; z1 register update + kz1 = klp + kv + + alp[kindx] = klp + ahp[kindx] = khp + kindx += 1 + od + + xout alp, ahp +endop + + +;; 1-pole (6dB) lowpass/highpass filter +;; takes in a a-rate signal and cutoff value in frequency +opcode zdf_1pole, aa, aa + ain, acf xin + + ; pre-warp the cutoff- these are bilinear-transform filters + iT = 1/sr + + ahp init 0 + alp init 0 + + ;; state for integrators + kz1 init 0 + + kindx = 0 + while kindx < ksmps do + ; pre-warp the cutoff- these are bilinear-transform filters + kwd = 2 * $M_PI * acf[kindx] + kwa = (2/iT) * tan(kwd * iT/2) + kg = kwa * iT/2 + + ; big combined value + kG = kg / (1.0 + kg) + + ; do the filter, see VA book p. 46 + ; form sub-node value v(n) + kin = ain[kindx] + kv = (kin - kz1) * kG + + ; form output of node + register + klp = kv + kz1 + khp = kin - klp + + ; z1 register update + kz1 = klp + kv + + alp[kindx] = klp + ahp[kindx] = khp + kindx += 1 + od + + xout alp, ahp +endop + +;; 1-pole allpass filter +;; takes in an a-rate signal and corner frequency where input +;; phase is shifted -90 degrees +opcode zdf_allpass_1pole, a, ak + ain, kcf xin + alp, ahp zdf_1pole ain, kcf + aout = alp - ahp + xout aout +endop + + +;; 1-pole allpass filter +;; takes in an a-rate signal and corner frequency where input +;; phase is shifted -90 degrees +opcode zdf_allpass_1pole, a, aa + ain, acf xin + alp, ahp zdf_1pole ain, acf + aout = alp - ahp + xout aout +endop + + +;; 2-pole (12dB) lowpass/highpass/bandpass filter +;; takes in a a-rate signal, cutoff value in frequency, and +;; Q factor for resonance +opcode zdf_2pole,aaa,aKK + + ain, kcf, kQ xin + + ; pre-warp the cutoff- these are bilinear-transform filters + kwd = 2 * $M_PI * kcf + iT = 1/sr + kwa = (2/iT) * tan(kwd * iT/2) + kG = kwa * iT/2 + kR = 1 / (2 * kQ) + + ;; output signals + alp init 0 + ahp init 0 + abp init 0 + + ;; state for integrators + kz1 init 0 + kz2 init 0 + + ;; + kindx = 0 + while kindx < ksmps do + khp = (ain[kindx] - (2 * kR + kG) * kz1 - kz2) / (1 + (2 * kR * kG) + (kG * kG)) + kbp = kG * khp + kz1 + klp = kG * kbp + kz2 + + ; z1 register update + kz1 = kG * khp + kbp + kz2 = kG * kbp + klp + + alp[kindx] = klp + ahp[kindx] = khp + abp[kindx] = kbp + kindx += 1 + od + + xout alp, abp, ahp + +endop + + +;; 2-pole (12dB) lowpass/highpass/bandpass filter +;; takes in a a-rate signal, cutoff value in frequency, and +;; Q factor for resonance +opcode zdf_2pole,aaa,aaa + + ain, acf, aQ xin + + iT = 1/sr + + ;; output signals + alp init 0 + ahp init 0 + abp init 0 + + ;; state for integrators + kz1 init 0 + kz2 init 0 + + ;; + kindx = 0 + while kindx < ksmps do + + ; pre-warp the cutoff- these are bilinear-transform filters + kwd = 2 * $M_PI * acf[kindx] + kwa = (2/iT) * tan(kwd * iT/2) + kG = kwa * iT/2 + + kR = 1 / (2 * aQ[kindx]) + + khp = (ain[kindx] - (2 * kR + kG) * kz1 - kz2) / (1 + (2 * kR * kG) + (kG * kG)) + kbp = kG * khp + kz1 + klp = kG * kbp + kz2 + + ; z1 register update + kz1 = kG * khp + kbp + kz2 = kG * kbp + klp + + alp[kindx] = klp + ahp[kindx] = khp + abp[kindx] = kbp + kindx += 1 + od + + xout alp, abp, ahp + +endop + +;; 2-pole (12dB) lowpass/highpass/bandpass/notch filter +;; takes in a a-rate signal, cutoff value in frequency, and +;; Q factor for resonance +opcode zdf_2pole_notch,aaaa,aKK + + ain, kcf, kQ xin + + ; pre-warp the cutoff- these are bilinear-transform filters + kwd = 2 * $M_PI * kcf + iT = 1/sr + kwa = (2/iT) * tan(kwd * iT/2) + kG = kwa * iT/2 + kR = 1 / (2 * kQ) + + ;; output signals + alp init 0 + ahp init 0 + abp init 0 + anotch init 0 + + ;; state for integrators + kz1 init 0 + kz2 init 0 + + ;; + kindx = 0 + while kindx < ksmps do + kin = ain[kindx] + khp = (kin - (2 * kR + kG) * kz1 - kz2) / (1 + (2 * kR * kG) + (kG * kG)) + kbp = kG * khp + kz1 + klp = kG * kbp + kz2 + knotch = kin - (2 * kR * kbp) + + ; z1 register update + kz1 = kG * khp + kbp + kz2 = kG * kbp + klp + + alp[kindx] = klp + ahp[kindx] = khp + abp[kindx] = kbp + anotch[kindx] = knotch + kindx += 1 + od + + xout alp, abp, ahp, anotch + +endop + +;; 2-pole (12dB) lowpass/highpass/bandpass/notch filter +;; takes in a a-rate signal, cutoff value in frequency, and +;; Q factor for resonance +opcode zdf_2pole_notch,aaaa,aaa + + ain, acf, aQ xin + + iT = 1/sr + + ;; output signals + alp init 0 + ahp init 0 + abp init 0 + anotch init 0 + + ;; state for integrators + kz1 init 0 + kz2 init 0 + + ;; + kindx = 0 + while kindx < ksmps do + + ; pre-warp the cutoff- these are bilinear-transform filters + kwd = 2 * $M_PI * acf[kindx] + kwa = (2/iT) * tan(kwd * iT/2) + kG = kwa * iT/2 + + kR = 1 / (2 * aQ[kindx]) + + kin = ain[kindx] + khp = (kin - (2 * kR + kG) * kz1 - kz2) / (1 + (2 * kR * kG) + (kG * kG)) + kbp = kG * khp + kz1 + klp = kG * kbp + kz2 + knotch = kin - (2 * kR * kbp) + + ; z1 register update + kz1 = kG * khp + kbp + kz2 = kG * kbp + klp + + alp[kindx] = klp + ahp[kindx] = khp + abp[kindx] = kbp + anotch[kindx] = knotch + kindx += 1 + od + + xout alp, abp, ahp, anotch + +endop + +;; moog ladder + +opcode zdf_ladder, a, akk + + ain, kcf, kres xin + aout init 0 + + kR = limit(1 - kres, 0.025, 1) + + kQ = 1 / (2 * kR) + + kwd = 2 * $M_PI * kcf + iT = 1/sr + kwa = (2/iT) * tan(kwd * iT/2) + kg = kwa * iT/2 + + kk = 4.0*(kQ - 0.707)/(25.0 - 0.707) + + kg_2 = kg * kg + kg_3 = kg_2 * kg + + ; big combined value + ; for overall filter + kG = kg_2 * kg_2 + ; for individual 1-poles + kG_pole = kg/(1.0 + kg) + + ;; state for each 1-pole's integrator + kz1 init 0 + kz2 init 0 + kz3 init 0 + kz4 init 0 + + kindx = 0 + while kindx < ksmps do + ;; processing + kin = ain[kindx] + + kS = kg_3 * kz1 + kg_2 * kz2 + kg * kz3 + kz4 + ku = (kin - kk * kS) / (1 + kk * kG) + + ;; 1st stage + kv = (ku - kz1) * kG_pole + klp = kv + kz1 + kz1 = klp + kv + + ;; 2nd stage + kv = (klp - kz2) * kG_pole + klp = kv + kz2 + kz2 = klp + kv + + ;; 3rd stage + kv = (klp - kz3) * kG_pole + klp = kv + kz3 + kz3 = klp + kv + + ;; 4th stage + kv = (klp - kz4) * kG_pole + klp = kv + kz4 + kz4 = klp + kv + + aout[kindx] = klp + + kindx += 1 + od + + xout aout +endop + + +opcode zdf_ladder, a, aaa + + ain, acf, ares xin + aout init 0 + + iT = 1/sr + + ;; state for each 1-pole's integrator + kz1 init 0 + kz2 init 0 + kz3 init 0 + kz4 init 0 + + kindx = 0 + while kindx < ksmps do + + kR = limit(1 - ares[kindx], 0.025, 1) + + kQ = 1 / (2 * kR) + + kwd = 2 * $M_PI * acf[kindx] + kwa = (2/iT) * tan(kwd * iT/2) + kg = kwa * iT/2 + + kk = 4.0*(kQ - 0.707)/(25.0 - 0.707) + + kg_2 = kg * kg + kg_3 = kg_2 * kg + + ; big combined value + ; for overall filter + kG = kg_2 * kg_2 + ; for individual 1-poles + kG_pole = kg/(1.0 + kg) + + ;; processing + kin = ain[kindx] + + kS = kg_3 * kz1 + kg_2 * kz2 + kg * kz3 + kz4 + ku = (kin - kk * kS) / (1 + kk * kG) + + ;; 1st stage + kv = (ku - kz1) * kG_pole + klp = kv + kz1 + kz1 = klp + kv + + ;; 2nd stage + kv = (klp - kz2) * kG_pole + klp = kv + kz2 + kz2 = klp + kv + + ;; 3rd stage + kv = (klp - kz3) * kG_pole + klp = kv + kz3 + kz3 = klp + kv + + ;; 4th stage + kv = (klp - kz4) * kG_pole + klp = kv + kz4 + kz4 = klp + kv + + aout[kindx] = klp + + kindx += 1 + od + + xout aout +endop + +;; 4-pole + +opcode zdf_4pole, aaaaaa, akk + ain, kcf, kres xin + + alp2, abp2, ahp2 zdf_2pole ain, kcf, kres + + abp4 init 0 + abl4 init 0 + alp4 init 0 + + xout alp2, abp2, ahp2, alp4, abl4, abp4 +endop + +opcode zdf_4pole, aaaaaa, aaa + ain, acf, ares xin + + alp2, abp2, ahp2 zdf_2pole ain, acf, ares + abp4 init 0 + abl4 init 0 + alp4 init 0 + + xout alp2, abp2, ahp2, alp4, abl4, abp4 +endop + + +opcode zdf_4pole_hp, aaaaaa, akk + ain, kcf, kres xin + + alp2, abp2, ahp2 zdf_2pole ain, kcf, kres + + ahp4 init 0 + abh4 init 0 + abp4 init 0 + + xout alp2, abp2, ahp2, abp4, abh4, ahp4 +endop + +opcode zdf_4pole_hp, aaaaaa, aaa + ain, acf, ares xin + + alp2, abp2, ahp2 zdf_2pole ain, acf, ares + + ahp4 init 0 + abh4 init 0 + abp4 init 0 + + xout alp2, abp2, ahp2, abp4, abh4, ahp4 +endop + +;; TODO - implement +opcode zdf_peak_eq, a, akkk + ain, kcf, kres, kdB xin + + aout init 0 + + xout aout +endop + +opcode zdf_high_shelf_eq, a, akk + ain, kcf, kdB xin + + ;; TODO - convert db to K, check if reusing zdf_1pole is sufficient + kK init 0 + + alp, ahp zdf_1pole ain, kcf + + aout = ain + kK * ahp + + xout aout +endop + +opcode zdf_low_shelf_eq, a, akk + ain, kcf, kdB xin + + ;; TODO - convert db to K, check if reusing zdf_1pole is sufficient + kK init 0 + + alp, ahp zdf_1pole ain, kcf + + aout = ain + kK * alp + + xout aout +endop diff --git a/data/opcodes/zero-delay-convolution.udo b/data/opcodes/zero-delay-convolution.udo new file mode 100644 --- /dev/null +++ b/data/opcodes/zero-delay-convolution.udo @@ -0,0 +1,31 @@ +; Here’s a UDO for zero-latency partitioned convolution + +;/************************************************** +;asig ZConv ain,ipart,irat,inp,ifn +;ain - input signal +;ipart - first partition size in samples +;irat - partition growth ratio +;inp - total number of partition sizes +;ifn - function table number containing the IR +;**************************************************/ +opcode ZConv,a,aiiiio + asig,iprt,irat,inp,ifn,icnt xin + if icnt < inp-1 then + acn ZConv asig,iprt,irat,inp,ifn,icnt+1 + endif + if icnt == 0 then + a1 dconv asig,iprt,ifn + elseif icnt < inp-1 then + ipt = iprt*irat^(icnt-1) + isiz = ipt*(irat-1) + print ipt + print isiz + a1 ftconv asig,ifn,ipt,ipt,isiz + else + ipt = iprt*irat^(icnt-1) + a1 ftconv asig,ifn,ipt,ipt + endif + xout a1 + acn +endop + +; a1 ZConv asig,64,4,6,1 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 @@ -57,9 +57,9 @@ noteFlagExpr <- toGE noteFlag args <- fromTuple (pch, vol, other) return $ do - D.when1 (noteFlagExpr ==* 1) $ do + D.when1 D.Ir (noteFlagExpr ==* 1) $ do eventi (Event instrIdExpr 0 (-1) args) - D.when1 (noteFlagExpr ==* 0) $ do + D.when1 D.Ir (noteFlagExpr ==* 0) $ do eventi (Event (negate instrIdExpr) 0 0 args) turnoff diff --git a/src/Csound/Typed/Control/Vco.hs b/src/Csound/Typed/Control/Vco.hs --- a/src/Csound/Typed/Control/Vco.hs +++ b/src/Csound/Typed/Control/Vco.hs @@ -1,12 +1,37 @@ -- | Band-limited oscillators module Csound.Typed.Control.Vco( saw, isaw, pulse, tri, sqr, blosc, - saw', isaw', pulse', tri', sqr', blosc' + saw', isaw', pulse', tri', sqr', blosc', + + -- * Hard sync + SyncSmooth(..), + + sawSync, isawSync, pulseSync, triSync, sqrSync, bloscSync, + sawSync', isawSync', pulseSync', triSync', sqrSync', bloscSync', + + -- ** Hard sync with absolute frequency for slave oscillator + sawSyncAbs, isawSyncAbs, pulseSyncAbs, triSyncAbs, sqrSyncAbs, bloscSyncAbs, + sawSyncAbs', isawSyncAbs', pulseSyncAbs', triSyncAbs', sqrSyncAbs', bloscSyncAbs', + + -- ** Hard sync with custom smoothing algorythm + sawSyncBy, isawSyncBy, pulseSyncBy, triSyncBy, sqrSyncBy, bloscSyncBy, + sawSyncBy', isawSyncBy', pulseSyncBy', triSyncBy', sqrSyncBy', bloscSyncBy', + + -- ** Hard sync with absolute frequency for slave oscillator + sawSyncAbsBy, isawSyncAbsBy, pulseSyncAbsBy, triSyncAbsBy, sqrSyncAbsBy, bloscSyncAbsBy, + sawSyncAbsBy', isawSyncAbsBy', pulseSyncAbsBy', triSyncAbsBy', sqrSyncAbsBy', bloscSyncAbsBy' + + ) where +import Data.Default + +import Csound.Dynamic(Gen(..), GenId(..)) import Csound.Typed.GlobalState import Csound.Typed.Types +import Csound.Typed.GlobalState + -------------------------------------------------------------- -- no phase @@ -79,3 +104,406 @@ phsExpr <- toGE phs waveId <- saveBandLimitedWave waveType return $ readBandLimited (Just phsExpr) waveId expr + +-------------------------------------------------------------- +-- no phase relative sync + +relativeSync :: (Sig -> Sig -> Sig) -> (Sig -> Sig -> Sig) +relativeSync f ratioCps masterCps = f (ratioCps * masterCps) masterCps + +-- | Sawtooth oscillator with hard-sync. +-- The first argument is a ration between slave and master oscillators. +-- +-- > sawSync ratio cps +sawSync :: Sig -> Sig -> Sig +sawSync = relativeSync sawSyncAbs + +-- | Integrated sawtooth oscillator with hard-sync. +-- The first argument is a ration between slave and master oscillators. +-- +-- > isawSync ratio cps +isawSync :: Sig -> Sig -> Sig +isawSync = relativeSync isawSyncAbs + + +-- | Triangle oscillator with hard-sync. +-- The first argument is a ration between slave and master oscillators. +-- +-- > triSync ratio cps +triSync :: Sig -> Sig -> Sig +triSync = relativeSync triSyncAbs + +-- | Pulse oscillator with hard-sync. +-- The first argument is a ration between slave and master oscillators. +-- +-- > pulseSync ratio cps +pulseSync :: Sig -> Sig -> Sig +pulseSync = relativeSync pulseSyncAbs + +-- | Square oscillator with hard-sync. +-- The first argument is a ration between slave and master oscillators. +-- +-- > sqrSync ratio cps +sqrSync :: Sig -> Sig -> Sig +sqrSync = relativeSync sqrSyncAbs + +-- | Band-limited oscillator with hard-sync. +-- The first argument is a ration between slave and master oscillators. +-- +-- > bloscSync tab ratio cps +bloscSync :: Tab -> Sig -> Sig -> Sig +bloscSync t = relativeSync (bloscSyncAbs t) + +-------------------------------------------------------------- + + +relativeSync' :: (D -> Sig -> Sig -> Sig) -> (D -> Sig -> Sig -> Sig) +relativeSync' f phase ratioCps masterCps = f phase (ratioCps * masterCps) masterCps + +-- | Sawtooth oscillator with hard-sync with phase. +-- The second argument is a ration between slave and master oscillators. +-- +-- > sawSync' phase ratio cps +sawSync' :: D -> Sig -> Sig -> Sig +sawSync' = relativeSync' sawSyncAbs' + +-- | Integrated sawtooth oscillator with hard-sync with phase. +-- The second argument is a ration between slave and master oscillators. +-- +-- > isawSync' phase ratio cps +isawSync' :: D -> Sig -> Sig -> Sig +isawSync' = relativeSync' isawSyncAbs' + +-- | Triangle oscillator with hard-sync with phase. +-- The second argument is a ration between slave and master oscillators. +-- +-- > triSync' phase ratio cps +triSync' :: D -> Sig -> Sig -> Sig +triSync' = relativeSync' triSyncAbs' + +-- | Pulse oscillator with hard-sync with phase. +-- The second argument is a ration between slave and master oscillators. +-- +-- > pulseSync' phase ratio cps +pulseSync' :: D -> Sig -> Sig -> Sig +pulseSync' = relativeSync' pulseSyncAbs' + +-- | Square oscillator with hard-sync with phase. +-- The second argument is a ration between slave and master oscillators. +-- +-- > sqrSync' phase ratio cps +sqrSync' :: D -> Sig -> Sig -> Sig +sqrSync' = relativeSync' sqrSyncAbs' + +-- | Band-limited oscillator with hard-sync with phase. +-- The second argument is a ration between slave and master oscillators. +-- +-- > bloscSync' phase tab ratio cps +bloscSync' :: Tab -> D -> Sig -> Sig -> Sig +bloscSync' t = relativeSync' (bloscSyncAbs' t) + +-------------------------------------------------------------- +-- no phase relative sync + +relativeSyncBy :: (SyncSmooth -> Sig -> Sig -> Sig) -> (SyncSmooth -> Sig -> Sig -> Sig) +relativeSyncBy f smoothType ratioCps masterCps = f smoothType (ratioCps * masterCps) masterCps + +-- | Sawtooth oscillator with hard-sync. We can specify the smoothness type. +-- The @ratio@ argument is a ration between slave and master oscillators. +-- +-- > sawSyncBy spec ratio cps +sawSyncBy :: SyncSmooth -> Sig -> Sig -> Sig +sawSyncBy = relativeSyncBy sawSyncAbsBy + +-- | Integrated sawtooth oscillator with hard-sync. We can specify the smoothness type. +-- The first argument is a ration between slave and master oscillators. +-- +-- > isawSyncB specy ratio cps +isawSyncBy :: SyncSmooth -> Sig -> Sig -> Sig +isawSyncBy = relativeSyncBy isawSyncAbsBy + +-- | Triangle oscillator with hard-sync. We can specify the smoothness type. +-- The @ratio@ argument is a ration between slave and master oscillators. +-- +-- > triSyncBy spec ratio cps +triSyncBy :: SyncSmooth -> Sig -> Sig -> Sig +triSyncBy = relativeSyncBy triSyncAbsBy + +-- | Pulse oscillator with hard-sync. We can specify the smoothness type. +-- The @ratio@ argument is a ration between slave and master oscillators. +-- +-- > pulseSyncBy spec ratio cps +pulseSyncBy :: SyncSmooth -> Sig -> Sig -> Sig +pulseSyncBy = relativeSyncBy pulseSyncAbsBy + +-- | Square oscillator with hard-sync. We can specify the smoothness type. +-- The @ratio@ argument is a ration between slave and master oscillators. +-- +-- > sawSyncBy spec ratio cps +sqrSyncBy :: SyncSmooth -> Sig -> Sig -> Sig +sqrSyncBy = relativeSyncBy sqrSyncAbsBy + +-- | Bandlimited table oscillator with hard-sync. We can specify the smoothness type. +-- The @ratio@ argument is a ration between slave and master oscillators. +-- +-- > bloscSyncBy spec tab ratio cps +bloscSyncBy :: SyncSmooth -> Tab -> Sig -> Sig -> Sig +bloscSyncBy smoothType t = relativeSyncBy (\smoothType -> bloscSyncAbsBy smoothType t) smoothType + +------------------------------------------------------------ +-- phase + +relativeSyncBy' :: (SyncSmooth -> D -> Sig -> Sig -> Sig) -> (SyncSmooth -> D -> Sig -> Sig -> Sig) +relativeSyncBy' f smoothType phase ratioCps masterCps = f smoothType phase (ratioCps * masterCps) masterCps + +-- | Sawtooth oscillator with hard-sync with phase. We can specify the smoothness type. +-- The @ratio@ argument is a ration between slave and master oscillators. +-- +-- > sawSyncBy' spec phase ratio cps +sawSyncBy' :: SyncSmooth -> D -> Sig -> Sig -> Sig +sawSyncBy' = relativeSyncBy' sawSyncAbsBy' + +-- | Integrated sawtooth oscillator with hard-sync with phase. We can specify the smoothness type. +-- The @ratio@ argument is a ration between slave and master oscillators. +-- +-- > isawSyncBy' spec phase ratio cps +isawSyncBy' :: SyncSmooth -> D -> Sig -> Sig -> Sig +isawSyncBy' = relativeSyncBy' isawSyncAbsBy' + +-- | Triangle oscillator with hard-sync with phase. We can specify the smoothness type. +-- The @ratio@ argument is a ration between slave and master oscillators. +-- +-- > triSyncBy' spec phase ratio cps +triSyncBy' :: SyncSmooth -> D -> Sig -> Sig -> Sig +triSyncBy' = relativeSyncBy' triSyncAbsBy' + +-- | Pulse oscillator with hard-sync with phase. We can specify the smoothness type. +-- The @ratio@ argument is a ration between slave and master oscillators. +-- +-- > pulseSyncBy' spec phase ratio cps +pulseSyncBy' :: SyncSmooth -> D -> Sig -> Sig -> Sig +pulseSyncBy' = relativeSyncBy' pulseSyncAbsBy' + +-- | Square oscillator with hard-sync with phase. We can specify the smoothness type. +-- The @ratio@ argument is a ration between slave and master oscillators. +-- +-- > sawSyncBy' spec phase ratio cps +sqrSyncBy' :: SyncSmooth -> D -> Sig -> Sig -> Sig +sqrSyncBy' = relativeSyncBy' sqrSyncAbsBy' + +-- | Bandlimited table oscillator with hard-sync with phase. We can specify the smoothness type. +-- The @ratio@ argument is a ration between slave and master oscillators. +-- +-- > bloscSyncBy' spec phase tab ratio cps +bloscSyncBy' :: SyncSmooth -> Tab -> D -> Sig -> Sig -> Sig +bloscSyncBy' smoothType t = relativeSyncBy' (\smoothType -> bloscSyncAbsBy' smoothType t) smoothType + +------------------------------------------------------------ + +-- | Sawtooth oscillator with hard-sync. +-- The @freq@ argument is an absolute frequency of a slave oscillator. +-- +-- > sawSyncAbs freq slaveCps masterCps +sawSyncAbs :: Sig -> Sig -> Sig +sawSyncAbs = sawSyncAbsBy def + +-- | Integrated sawtooth oscillator with hard-sync. +-- The @freq@ argument is an absolute frequency of a slave oscillator. +-- +-- > isawSyncAbs freq slaveCps masterCps +isawSyncAbs :: Sig -> Sig -> Sig +isawSyncAbs = isawSyncAbsBy def + +-- | Triangle oscillator with hard-sync. +-- The @freq@ argument is an absolute frequency of a slave oscillator. +-- +-- > triSyncAbs freq slaveCps masterCps +triSyncAbs :: Sig -> Sig -> Sig +triSyncAbs = triSyncAbsBy def + +-- | Pulse oscillator with hard-sync. +-- The @freq@ argument is an absolute frequency of a slave oscillator. +-- +-- > pulseSyncAbs freq slaveCps masterCps +pulseSyncAbs :: Sig -> Sig -> Sig +pulseSyncAbs = pulseSyncAbsBy def + +-- | Square oscillator with hard-sync. +-- The @freq@ argument is an absolute frequency of a slave oscillator. +-- +-- > sqrSyncAbs freq slaveCps masterCps +sqrSyncAbs :: Sig -> Sig -> Sig +sqrSyncAbs = sqrSyncAbsBy def + +-- | Bandlimited table oscillator with hard-sync. +-- The @freq@ argument is an absolute frequency of a slave oscillator. +-- +-- > bloscSyncAbs tab freq slaveCps masterCps +bloscSyncAbs :: Tab -> Sig -> Sig -> Sig +bloscSyncAbs = bloscSyncAbsBy def + +----------------------------------------------------------- + +-- | Sawtooth oscillator with hard-sync with phase. +-- The @freq@ argument is an absolute frequency of a slave oscillator. +-- +-- > sawSyncAbs' phase freq slaveCps masterCps +sawSyncAbs' :: D -> Sig -> Sig -> Sig +sawSyncAbs' = sawSyncAbsBy' def + +-- | Integrated sawtooth oscillator with hard-sync with phase. +-- The @freq@ argument is an absolute frequency of a slave oscillator. +-- +-- > isawSyncAbs' phase freq slaveCps masterCps +isawSyncAbs' :: D -> Sig -> Sig -> Sig +isawSyncAbs' = isawSyncAbsBy' def + +-- | Triangle oscillator with hard-sync with phase. +-- The @freq@ argument is an absolute frequency of a slave oscillator. +-- +-- > triSyncAbs' phase freq slaveCps masterCps +triSyncAbs' :: D -> Sig -> Sig -> Sig +triSyncAbs' = triSyncAbsBy' def + +-- | Pulse oscillator with hard-sync with phase. +-- The @freq@ argument is an absolute frequency of a slave oscillator. +-- +-- > pulseSyncAbs' phase freq slaveCps masterCps +pulseSyncAbs' :: D -> Sig -> Sig -> Sig +pulseSyncAbs' = pulseSyncAbsBy' def + +-- | Square oscillator with hard-sync with phase. +-- The @freq@ argument is an absolute frequency of a slave oscillator. +-- +-- > sqrSyncAbs' phase freq slaveCps masterCps +sqrSyncAbs' :: D -> Sig -> Sig -> Sig +sqrSyncAbs' = sqrSyncAbsBy' def + +-- | Bandlimited table oscillator with hard-sync with phase. +-- The @freq@ argument is an absolute frequency of a slave oscillator. +-- +-- > bloscSyncAbs' phase tab freq slaveCps masterCps +bloscSyncAbs' :: Tab -> D -> Sig -> Sig -> Sig +bloscSyncAbs' = bloscSyncAbsBy' def + +-------------------------------------------------------------- +-- no phase + +-- | A hard sync for sawtooth with absolute slave frequency. +-- +-- > sawSyncAbs syncType salveCps masterCps +sawSyncAbsBy :: SyncSmooth -> Sig -> Sig -> Sig +sawSyncAbsBy = noPhaseWaveHardSync Saw + +-- | A hard sync for integrated sawtooth: 4 * x * (1 - x) with absolute slave frequency. +-- +-- > isawSyncAbs syncType salveCps masterCps +isawSyncAbsBy :: SyncSmooth -> Sig -> Sig -> Sig +isawSyncAbsBy = noPhaseWaveHardSync IntegratedSaw + +-- | A hard sync for triangle wave with absolute slave frequency. +-- +-- > triSyncAbs syncType salveCps masterCps +triSyncAbsBy :: SyncSmooth -> Sig -> Sig -> Sig +triSyncAbsBy = noPhaseWaveHardSync Triangle + +-- | A hard sync for pulse wave with absolute slave frequency. +-- +-- > pulseSyncAbs syncType salveCps masterCps +pulseSyncAbsBy :: SyncSmooth -> Sig -> Sig -> Sig +pulseSyncAbsBy = noPhaseWaveHardSync Pulse + +-- | A hard sync for square wave with absolute slave frequency. +-- +-- > sqrSyncAbs syncType salveCps masterCps +sqrSyncAbsBy :: SyncSmooth -> Sig -> Sig -> Sig +sqrSyncAbsBy = noPhaseWaveHardSync Square + +-- | A hard sync for band-limited oscillator with user defined waveform (it's stored in the table) woth absolute frequency. +-- +-- > bloscSyncAbs syncType ftable salveCps masterCps +bloscSyncAbsBy :: SyncSmooth -> Tab -> Sig -> Sig -> Sig +bloscSyncAbsBy smoothType tab ratioCps cps = hideGE $ do + gen <- fromPreTab $ getPreTabUnsafe "blosc: tab should be primitive, not an expression." tab + return $ noPhaseWaveHardSync (UserGen gen) smoothType ratioCps cps + +-------------------------------------------------------------- +-- with phase + +-- | A sawtooth. +sawSyncAbsBy' :: SyncSmooth -> D -> Sig -> Sig -> Sig +sawSyncAbsBy' = withPhaseWaveHardSync Saw + +-- | Integrated sawtooth: 4 * x * (1 - x). +isawSyncAbsBy' :: SyncSmooth -> D -> Sig -> Sig -> Sig +isawSyncAbsBy' = withPhaseWaveHardSync IntegratedSaw + +-- | A triangle wave. +triSyncAbsBy' :: SyncSmooth -> D -> Sig -> Sig -> Sig +triSyncAbsBy' = withPhaseWaveHardSync Triangle + +-- | Pulse (not normalized). +pulseSyncAbsBy' :: SyncSmooth -> D -> Sig -> Sig -> Sig +pulseSyncAbsBy' = withPhaseWaveHardSync Pulse + +-- | A square wave. +sqrSyncAbsBy' :: SyncSmooth -> D -> Sig -> Sig -> Sig +sqrSyncAbsBy' = withPhaseWaveHardSync Square + +-- | A band-limited oscillator with user defined waveform (it's stored in the table). +bloscSyncAbsBy' :: SyncSmooth -> Tab -> D -> Sig -> Sig -> Sig +bloscSyncAbsBy' smoothType tab phs ratioCps cps = hideGE $ do + gen <- fromPreTab $ getPreTabUnsafe "blosc: tab should be primitive, not an expression." tab + return $ withPhaseWaveHardSync (UserGen gen) smoothType phs ratioCps cps + +----------------------------------------------- + +-- | Type of smooth shape to make smooth transitions on retrigger. +-- Available types are: +-- +-- * No smooth: @RawSync@ +-- +-- * Ramp smooth: @SawSync@ +-- +-- * Triangular smooth: @TriSync@ +-- +-- * User defined shape: @UserSync@ +data SyncSmooth = RawSync | SawSync | TriSync | TrapSync | UserSync Tab + +instance Default SyncSmooth where + def = TrapSync + +getSyncShape :: SyncSmooth -> GE (Maybe BandLimited) +getSyncShape x = case x of + RawSync -> return $ Nothing + SawSync -> gen7 4097 [1, 4097, 0] + TriSync -> gen7 4097 [0, 2048, 1, 2049, 0] + TrapSync -> gen7 4097 [1, 2048, 1, 2049, 0] + UserSync tab -> do + gen <- fromPreTab $ getPreTabUnsafe "blosc: tab should be primitive, not an expression." tab + return $ Just $ UserGen gen + where + gen7 size args = return $ Just $ UserGen $ Gen { genSize = size, genId = IntGenId 7, genArgs = args, genFile = Nothing } + +noPhaseWaveHardSync :: BandLimited -> SyncSmooth -> Sig -> Sig -> Sig +noPhaseWaveHardSync waveType smoothWaveType slaveCps cps = fromGE $ do + smoothWave <- getSyncShape smoothWaveType + exprSlaveCps <- toGE slaveCps + exprCps <- toGE cps + waveId <- saveBandLimitedWave waveType + smoothWaveId <- case smoothWave of + Nothing -> return Nothing + Just wave -> fmap Just $ saveBandLimitedWave wave + return $ readHardSyncBandLimited smoothWaveId Nothing waveId exprSlaveCps exprCps + +withPhaseWaveHardSync :: BandLimited -> SyncSmooth -> D -> Sig -> Sig -> Sig +withPhaseWaveHardSync waveType smoothWaveType phs slaveCps cps = fromGE $ do + smoothWave <- getSyncShape smoothWaveType + phsExpr <- toGE phs + exprSlaveCps <- toGE slaveCps + exprCps <- toGE cps + waveId <- saveBandLimitedWave waveType + smoothWaveId <- case smoothWave of + Nothing -> return Nothing + Just wave -> fmap Just $ saveBandLimitedWave wave + return $ readHardSyncBandLimited smoothWaveId (Just phsExpr) waveId exprSlaveCps exprCps 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 @@ -5,7 +5,7 @@ module Csound.Typed.GlobalState.Instr, module Csound.Typed.GlobalState.Cache, -- * Reexports dynamic - BandLimited(..), readBandLimited, renderBandLimited, + BandLimited(..), readBandLimited, readHardSyncBandLimited, renderBandLimited, Instrs(..), IdMap(..), getInstrIds, getIn, chnUpdateUdo, renderGlobals, turnoff, turnoff2, exitnow, oscListen, oscInit, oscSend, 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 @@ -8,9 +8,10 @@ -- Sf2 SfFluid(..), SfSpec(..), SfMap, newSf, sfVar, renderSf, -- ** Band-limited waveforms - BandLimited(..), BandLimitedMap, + BandLimited(..), BandLimitedMap(..), BandLimitedId(..), saveBandLimited, renderBandLimited, - readBandLimited, + readBandLimited, readHardSyncBandLimited, + -- ** String arguments StringMap, newString, -- * Midi @@ -29,7 +30,9 @@ subinstr, subinstr_, event_i, event, safeOut, autoOff, changed, -- * Udo plugins UdoPlugin, addUdoPlugin, getUdoPluginNames, - tabQueuePlugin, tabQueue2Plugin + tabQueuePlugin, tabQueue2Plugin, + zdfPlugin, solinaChorusPlugin, audaciouseqPlugin, adsr140Plugin, + diodePlugin, korg35Plugin, zeroDelayConvolutionPlugin ) where import Data.List @@ -51,7 +54,8 @@ data IdMap a = IdMap { idMapContent :: M.Map a Int - , idMapNewId :: Int } + , idMapNewId :: Int + } deriving (Eq, Ord) instance Default (IdMap a) where def = IdMap def 1 @@ -187,36 +191,85 @@ data BandLimited = Saw | Pulse | Square | Triangle | IntegratedSaw | UserGen Gen deriving (Eq, Ord) -type BandLimitedMap = M.Map BandLimited Int +data BandLimitedId = SimpleBandLimitedWave Int | UserBandLimitedWave Int + deriving (Eq, Ord) -saveBandLimited :: BandLimited -> State (GenMap, BandLimitedMap) Int +bandLimitedIdToExpr :: BandLimitedId -> E +bandLimitedIdToExpr x = case x of + SimpleBandLimitedWave simpleId -> int simpleId + UserBandLimitedWave userId -> noRate $ ReadVar $ bandLimitedVar userId + +bandLimitedVar userId = Var GlobalVar Ir ("BandLim" ++ show userId) + +data BandLimitedMap = BandLimitedMap + { simpleBandLimitedMap :: M.Map BandLimited BandLimitedId + , vcoInitMap :: GenMap + } deriving (Eq, Ord) + +instance Default BandLimitedMap where + def = BandLimitedMap def def + +saveBandLimited :: BandLimited -> State BandLimitedMap BandLimitedId saveBandLimited x = case x of Saw -> simpleWave 1 0 IntegratedSaw -> simpleWave 2 1 Pulse -> simpleWave 4 2 Square -> simpleWave 8 3 Triangle -> simpleWave 16 4 - UserGen _ -> userGen + UserGen gen -> userGen gen where - simpleWave writeId readId = state $ \s@(genMap, blMap) -> - if (M.member x blMap) - then (readId, s) - else (readId, (genMap, M.insert x writeId blMap)) + simpleWave writeId readId = state $ \blMap -> + if (M.member x (simpleBandLimitedMap blMap)) + then (SimpleBandLimitedWave readId, blMap) + else (SimpleBandLimitedWave readId, blMap { simpleBandLimitedMap = M.insert x (SimpleBandLimitedWave writeId) (simpleBandLimitedMap blMap) }) - userGen = state $ \s@(genMap, blMap) -> case M.lookup x blMap of - Just n -> (n, s) - Nothing -> - let (newId, genMap1) = runState newGenId genMap - blMap1 = M.insert x newId blMap - in (negate newId, (genMap1, blMap1)) + userGen gen = state $ \blMap -> + let genMap = vcoInitMap blMap + (newId, genMap1) = runState (saveId gen) genMap + blMap1 = blMap { vcoInitMap = genMap1 } + in (UserBandLimitedWave newId, blMap1) + renderBandLimited :: Monad m => GenMap -> BandLimitedMap -> DepT m () -renderBandLimited genMap blMap = case M.toList blMap of - [] -> return () - as -> render (idMapNewId genMap) (getUserGens as) as +renderBandLimited genMap blMap = + if isEmptyBlMap blMap + then return () + else render (idMapNewId genMap) (M.toList $ idMapContent $ vcoInitMap blMap) (M.toList $ simpleBandLimitedMap blMap) where - render n gens vcos = do - mapM_ renderGen gens + isEmptyBlMap m = (M.null $ simpleBandLimitedMap m) && (M.null $ idMapContent $ vcoInitMap m) + + render lastGenId gens vcos = do + writeVar freeVcoVar $ int (lastGenId + length gens + 100) + mapM_ (renderGen lastGenId) gens + mapM_ renderVco vcos + + renderGen :: Monad m => Int -> (Gen, Int) -> DepT m () + renderGen lastGenId (gen, genId) = do + renderFtgen lastGenId (gen, genId) + renderVcoGen genId + renderVcoVarAssignment genId + + freeVcoVar = Var GlobalVar Ir "free_vco" + ftVar n = Var GlobalVar Ir $ "vco_table_" ++ show n + + renderFtgen lastGenId (g, n) = writeVar (ftVar n) $ ftgen (int $ lastGenId + n) g + + renderVcoGen ftId = do + ft <- readVar (ftVar ftId) + free <- readVar freeVcoVar + writeVar freeVcoVar $ vco2init [-ft, free, 1.05, -1, -1, ft] + + renderVcoVarAssignment n = writeVar (bandLimitedVar n) =<< (fmap negate $ readVar (ftVar n)) + + renderVco :: Monad m => (BandLimited, BandLimitedId) -> DepT m () + renderVco (bandLimited, blId) = case blId of + SimpleBandLimitedWave waveId -> do + free <- readVar freeVcoVar + writeVar freeVcoVar $ vco2init [int waveId, free] + UserBandLimitedWave _ -> return () + + +{- renderFirstVco n (head vcos) mapM_ renderTailVco (tail vcos) @@ -240,10 +293,23 @@ dummyVar = Var LocalVar Ir "ft" toDummy = writeVar dummyVar +-} -readBandLimited :: Maybe E -> Int -> E -> E -readBandLimited mphase n cps = oscilikt 1 cps (vco2ft cps (int n)) mphase +readBandLimited :: Maybe E -> BandLimitedId -> E -> E +readBandLimited mphase n cps = oscilikt 1 cps (vco2ft cps (bandLimitedIdToExpr n)) mphase +readHardSyncBandLimited :: Maybe BandLimitedId -> Maybe E -> BandLimitedId -> E -> E -> E +readHardSyncBandLimited msmoothShape mphase n slaveCps masterCps = smoothWave * readShape n phasorSlave slaveCps + where + (phasorMaster, syncMaster) = syncphasor masterCps 0 Nothing + (phasorSlave, syncSlave) = syncphasor slaveCps syncMaster mphase + + smoothWave = case msmoothShape of + Nothing -> 1 + Just shape -> readShape shape phasorMaster masterCps + + readShape shapeId phasor freq = tableikt phasor (vco2ft freq (bandLimitedIdToExpr shapeId)) + ---------------------------------------------------------- -- Midi @@ -431,12 +497,24 @@ newtype UdoPlugin = UdoPlugin { unUdoPlugin :: String } -tabQueuePlugin = UdoPlugin "tabQueue" -tabQueue2Plugin = UdoPlugin "tabQueue2" - addUdoPlugin :: UdoPlugin -> State [UdoPlugin] () addUdoPlugin a = modify (a :) getUdoPluginNames :: [UdoPlugin] -> [String] getUdoPluginNames xs = nub (fmap unUdoPlugin xs) +-- tabQueue + +tabQueuePlugin = UdoPlugin "tabQueue" +tabQueue2Plugin = UdoPlugin "tabQueue2" + +---------------------------------------------------------- +-- Steven Yi wonderful UDOs + +zdfPlugin = UdoPlugin "zdf" -- Zero delay filters +solinaChorusPlugin = UdoPlugin "solina_chorus" -- solina chorus +audaciouseqPlugin = UdoPlugin "audaciouseq" -- audacious 10 band EQ +adsr140Plugin = UdoPlugin "adsr140" -- adsr with retriggering +diodePlugin = UdoPlugin "diode" -- diode ladder filter +korg35Plugin = UdoPlugin "korg35" -- korg 35 filter +zeroDelayConvolutionPlugin = UdoPlugin "zero-delay-convolution" -- zero delay convolutio by Victor Lazzarini 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 @@ -33,6 +33,8 @@ guiInstrExp, listenKeyEvt, Key(..), KeyEvt(..), Guis(..), getKeyEventListener, + -- * Cabbage Guis + cabbage, -- * Hrtf pan simpleHrtfmove, simpleHrtfstat, -- * Udo plugins @@ -62,6 +64,8 @@ import Csound.Typed.GlobalState.Opcodes(hrtfmove, hrtfstat, primInstrId) import Csound.Typed.Gui.Gui(Panel(..), Win(..), GuiNode, GuiHandle(..), restoreTree, guiMap, mapGuiOnPanel, defText) +import qualified Csound.Typed.Gui.Cabbage.CabbageLang as Cabbage +import qualified Csound.Typed.Gui.Cabbage.Cabbage as Cabbage import qualified Csound.Typed.GlobalState.Elements as E(saveNamedInstr, addUdoPlugin) @@ -112,10 +116,11 @@ , userInstr0 :: Dep () , bandLimitedMap :: BandLimitedMap , cache :: Cache GE - , guis :: Guis } + , guis :: Guis + , cabbageGui :: Maybe Cabbage.Lang } 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 = History def def def def def def def def def def def def def def def (return ()) def def def def data Msg = Msg data MidiAssign = MidiAssign MidiType Channel InstrId @@ -194,11 +199,12 @@ sfTable :: History -> [(SfSpec, Int)] sfTable = M.toList . idMapContent . sfMap -saveBandLimitedWave :: BandLimited -> GE Int +saveBandLimitedWave :: BandLimited -> GE BandLimitedId saveBandLimitedWave = onBandLimitedMap . saveBandLimited where onBandLimitedMap = onHistory - (\a -> (genMap a, bandLimitedMap a)) - (\(gm, blm) h -> h { genMap = gm, bandLimitedMap = blm}) + (\a -> (bandLimitedMap a)) + (\(blm) h -> h { bandLimitedMap = blm}) + setTotalDur :: TotalDur -> GE () setTotalDur = onTotalDur . modify . const . Just where onTotalDur = onHistory totalDur (\a h -> h { totalDur = a }) @@ -491,8 +497,8 @@ keyEventInstrBody keyMap = execDepT $ do let keys = flKeyIn isChange = changed keys ==* 1 - when1 isChange $ do - whens (fmap (uncurry $ listenEvt keys) events) doNothing + when1 Kr isChange $ do + whens Kr (fmap (uncurry $ listenEvt keys) events) doNothing where doNothing = return () @@ -513,6 +519,11 @@ body <- keyEventInstrBody $ guiKeyEvents $ guis h return $ Just (Instr keyEventInstrId body) +----------------------------------------------- +-- cabbage + +cabbage :: Cabbage.Cab -> GE () +cabbage cab = modifyHistory $ \h -> h { cabbageGui = Just $ Cabbage.runCab cab } ----------------------------------------------- -- head pan 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 @@ -12,6 +12,7 @@ out, outs, safeOut, autoOff, turnoff, turnoff2, exitnow, -- * vco2 oscili, oscilikt, vco2ft, vco2ift, vco2init, ftgen, + syncphasor, tableikt, -- * OSC oscInit, oscListen, oscSend, -- * channels @@ -84,7 +85,7 @@ servantUpdateChnAlive pargId = do let sName = chnAliveName (pn pargId) kAlive <- chngetK sName - when1 (kAlive <* -10) $ do + when1 Kr (kAlive <* -10) $ do turnoff chnsetK (kAlive - 1) sName @@ -96,7 +97,7 @@ let sName = chnRetrigName (pn pargId) let retrigVal = pn $ pargId + 1 kRetrig <- chngetK sName - when1 (kRetrig /=* retrigVal) $ do + when1 Kr (kRetrig /=* retrigVal) $ do turnoff servantUpdateChnEvtLoop :: Monad m => Int -> DepT m () @@ -219,12 +220,12 @@ safeOut gainLevel = fmap (( * double gainLevel) . limiter) limiter :: E -> E -limiter x = opcs "compress" [(Ar, [Ar, Ar, Kr, Kr, Kr, Kr, Kr, Kr, Ir])] [x, 1, 0, 89, 89, 100, 0, 0, 0] +limiter x = opcs "compress" [(Ar, [Ar, Ar, Kr, Kr, Kr, Kr, Kr, Kr, Ir])] [x, 1, 0, 90, 90, 100, 0, 0, 0] autoOff :: Monad m => E -> [E] -> DepT m [E] autoOff dt a = do ihold - when1 (trig a) + when1 Kr (trig a) turnoff return a where @@ -300,6 +301,14 @@ vco2init :: [E] -> E vco2init = opcs "vco2init" [(Ir, repeat Ir)] + +syncphasor :: E -> E -> Maybe E -> (E, E) +syncphasor xcps asyncin mphase = getPair $ mopcs "syncphasor" ([Ar, Ar], [Xr, Ar, Ir]) $ case mphase of + Nothing -> [xcps, asyncin] + Just phase -> [xcps, asyncin, phase] + +tableikt :: E -> E -> E +tableikt xndx kfn = opcs "tableikt" [(Ar, [Xr, Kr, Ir, Ir, Ir])] [xndx, kfn, 1] ----------------------------------------------------------- -- OSC 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 @@ -34,7 +34,7 @@ , 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 + , csdTabFi :: Maybe TabFi -- ^ Default fidelity of the arrays } instance Default Options where @@ -134,4 +134,3 @@ idSone = "sone" idFarey = "farey" idWave = "wave" - diff --git a/src/Csound/Typed/Gui.hs b/src/Csound/Typed/Gui.hs --- a/src/Csound/Typed/Gui.hs +++ b/src/Csound/Typed/Gui.hs @@ -5,4 +5,3 @@ import Csound.Typed.Gui.Gui import Csound.Typed.Gui.Widget - diff --git a/src/Csound/Typed/Gui/Cab.hs b/src/Csound/Typed/Gui/Cab.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Gui/Cab.hs @@ -0,0 +1,25 @@ +module Csound.Typed.Gui.Cab( + Cab, CabProp, Col(..), cabbage, + + -- * Widgets + button, filebutton, infobutton, checkbox, combobox, csoundoutput, encoder, gentable, + hrange, vrange, form, groupbox, image, keyboard, label, hslider, vslider, + rslider, soundfiler, signaldisplay, textbox, texteditor, xypad, + + -- * Properties + bounds, channel, text1, text2, value, colour, colour0, colour1, backgroundcolour, textcolour, trackercolour, outlinecolour, + fontcolour, fontcolour0, fontcolour1, latched, identchannel, rotate, alpha, visible, caption, widgetarray, popuptext, + active, svgfile, populate, mode, file, shape, corners, channeltype, align, sliderincr, max, min, textbox', trackerthickness, + linethickness, range, range2, size, pluginid, guirefresh, plant, child, show, middlec, keywidth, scrollbars, fontstyle, + scrubberpos, zoom, displaytype, updaterate, wrap +) where + +import Prelude hiding (show, min, max) + +import Csound.Typed.Gui.Cabbage.Cabbage + +import qualified Csound.Typed.GlobalState as G +import Csound.Typed.GlobalState(SE) + +cabbage :: Cab -> SE () +cabbage = G.geToSe . G.cabbage diff --git a/src/Csound/Typed/Gui/Cabbage/Cabbage.hs b/src/Csound/Typed/Gui/Cabbage/Cabbage.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Gui/Cabbage/Cabbage.hs @@ -0,0 +1,256 @@ +{-# Language GeneralizedNewtypeDeriving #-} +module Csound.Typed.Gui.Cabbage.Cabbage( + Cab, CabProp, Col(..), runCab, + + -- * Widgets + button, filebutton, infobutton, checkbox, combobox, csoundoutput, encoder, gentable, + hrange, vrange, form, groupbox, image, keyboard, label, hslider, vslider, + rslider, soundfiler, signaldisplay, textbox, texteditor, xypad, + + -- * Properties + bounds, channel, text1, text2, value, colour, colour0, colour1, backgroundcolour, textcolour, trackercolour, outlinecolour, + fontcolour, fontcolour0, fontcolour1, latched, identchannel, rotate, alpha, visible, caption, widgetarray, popuptext, + active, svgfile, populate, mode, file, shape, corners, channeltype, align, sliderincr, max, min, textbox', trackerthickness, + linethickness, range, range2, size, pluginid, guirefresh, plant, child, show, middlec, keywidth, scrollbars, fontstyle, + scrubberpos, zoom, displaytype, updaterate, wrap + +) where + +import Prelude hiding (show, min, max) + +import Data.Maybe +import Control.Monad.Trans.Writer.Strict + +import Csound.Typed.Gui.Cabbage.CabbageLang + +type Cab = Cab' () +type CabProp = CabProp' () + +-- | The Cab is a monad for Cabbage markup language. +-- The markup description can be constructed in the same way as blaze-html markup. +newtype Cab' a = Cab' { unCab' :: Writer [Line] a } + deriving (Functor, Applicative, Monad) + +runCab :: Cab -> [Line] +runCab = snd . runWriter . unCab' + +newtype CabProp' a = CabProp' { unCabProp' :: Writer [Property] a } + deriving (Functor, Applicative, Monad) + +runCabProp :: CabProp -> [Property] +runCabProp = snd . runWriter . unCabProp' + +--------------------------------------- +-- widgets + +widget :: String -> CabProp -> Cab +widget name props = Cab' $ tell [Line name $ runCabProp props] + +--------------------------------------- + +button, filebutton, infobutton, checkbox, combobox, csoundoutput, encoder, gentable, + hrange, vrange, form, groupbox, image, keyboard, label, hslider, vslider, + rslider, soundfiler, signaldisplay, textbox, texteditor, xypad :: CabProp -> Cab + +button = widget "button" +filebutton = widget "filebutton" +infobutton = widget "infobutton" +checkbox = widget "checkbox" +combobox = widget "combobox" +csoundoutput = widget "csoundoutput" +encoder = widget "encoder" +gentable = widget "gentable" +hrange = widget "hrange" +vrange = widget "vrange" +form = widget "form" +groupbox = widget "groupbox" +image = widget "image" +keyboard = widget "keyboard" +label = widget "label" +hslider = widget "hslider" +vslider = widget "vslider" +rslider = widget "rslider" +soundfiler = widget "soundfiler" +signaldisplay = widget "signaldisplay" +textbox = widget "textbox" +texteditor = widget "texteditor" +xypad = widget "xypad" + +--------------------------------------- +-- properties + +mkProperty :: String -> [Arg] -> CabProp +mkProperty name args = CabProp' $ tell [Property name args] + +data Col = Hash String | Rgb Int Int Int + +colProp x = case x of + Hash a -> [StringArg a] + Rgb r g b -> fmap IntArg [r, g, b] + +boolProp x = IntArg $ if x then 1 else 0 + +bounds :: Int -> Int -> Int -> Int -> CabProp +bounds x y w h = mkProperty "bounds" (fmap IntArg [x, y, w, h]) + +channel :: String -> CabProp +channel name = mkProperty "channel" [StringArg name] + +text1 :: String -> CabProp +text1 name = mkProperty "text" [StringArg name] + +text2 :: String -> String -> CabProp +text2 name1 name2 = mkProperty "text" [StringArg name1, StringArg name2] + +value :: Float -> CabProp +value x = mkProperty "value" [FloatArg x] + +colour :: Col -> CabProp +colour col = mkProperty "colour" (colProp col) + +colour0 :: Col -> CabProp +colour0 col = mkProperty "colour:0" (colProp col) + +colour1 :: Col -> CabProp +colour1 col = mkProperty "colour:1" (colProp col) + +backgroundcolour :: Col -> CabProp +backgroundcolour col = mkProperty "backgroundcolour" (colProp col) + +textcolour :: Col -> CabProp +textcolour col = mkProperty "textcolour" (colProp col) + +trackercolour :: Col -> CabProp +trackercolour col = mkProperty "trackercolour" (colProp col) + +outlinecolour :: Col -> CabProp +outlinecolour col = mkProperty "outlinecolour" (colProp col) + +fontcolour :: Col -> CabProp +fontcolour col = mkProperty "fontcolour" (colProp col) + +fontcolour0 :: Col -> CabProp +fontcolour0 col = mkProperty "fontcolour:0" (colProp col) + +fontcolour1 :: Col -> CabProp +fontcolour1 col = mkProperty "fontcolour:1" (colProp col) + +latched :: Bool -> CabProp +latched b = mkProperty "latched" [boolProp b] + +identchannel :: String -> CabProp +identchannel s = mkProperty "identchannel" [StringArg s] + +rotate :: Float -> Float -> Float -> CabProp +rotate radians pivotx pivoty = mkProperty "rotate" $ fmap FloatArg [radians, pivotx, pivoty] + +alpha :: Float -> CabProp +alpha a = mkProperty "alpha" [FloatArg a] + +visible :: Bool -> CabProp +visible a = mkProperty "visible" [boolProp a] + +caption :: String -> CabProp +caption a = mkProperty "caption" [StringArg a] + +widgetarray :: String -> Int -> CabProp +widgetarray name n = mkProperty "widgetarray" [StringArg name, IntArg n] + +popuptext :: String -> CabProp +popuptext a = mkProperty "popuptext" [StringArg a] + +active :: Bool -> CabProp +active a = mkProperty "active" [boolProp a] + +svgfile :: String -> String -> CabProp +svgfile ty file = mkProperty "svgfile" (fmap StringArg [ty, file]) + +populate :: String -> String -> CabProp +populate filetype dir = mkProperty "populate" (fmap StringArg [filetype, dir]) + +mode :: String -> CabProp +mode a = mkProperty "mode" [StringArg a] + +file :: String -> CabProp +file a = mkProperty "file" [StringArg a] + +shape :: String -> CabProp +shape a = mkProperty "shape" [StringArg a] + +corners :: Float -> CabProp +corners a = mkProperty "corners" [FloatArg a] + +channeltype :: String -> CabProp +channeltype a = mkProperty "channeltype" [StringArg a] + +align :: String -> CabProp +align a = mkProperty "align" [StringArg a] + +sliderincr :: Float -> CabProp +sliderincr a = mkProperty "sliderincr" [FloatArg a] + +max :: Float -> CabProp +max a = mkProperty "max" [FloatArg a] + +min :: Float -> CabProp +min a = mkProperty "min" [FloatArg a] + +textbox' :: Bool -> CabProp +textbox' a = mkProperty "textbox" [boolProp a] + +trackerthickness :: Float -> CabProp +trackerthickness a = mkProperty "trackerthickness" [FloatArg a] + +linethickness :: Float -> CabProp +linethickness a = mkProperty "linethickness" [FloatArg a] + +range :: Float -> Float -> (Float, Float) -> CabProp +range min max value = range2 min max value Nothing Nothing + +range2 :: Float -> Float -> (Float, Float) -> Maybe Float -> Maybe Float -> CabProp +range2 min max value mskew mincr = mkProperty "range" $ catMaybes [Just $ FloatArg min, Just $ FloatArg max, Just $ (uncurry ColonArg) value, fmap FloatArg mskew, fmap FloatArg mincr] + +size :: Int -> Int -> CabProp +size w h = mkProperty "size" (fmap IntArg [w, h]) + +pluginid :: String -> CabProp +pluginid a = mkProperty "pluginid" [StringArg a] + +guirefresh :: Int -> CabProp +guirefresh a = mkProperty "guirefresh" [IntArg a] + +plant :: String -> CabProp +plant a = mkProperty "plant" [StringArg a] + +child :: Bool -> CabProp +child a = mkProperty "child" [boolProp a] + +show :: Bool -> CabProp +show a = mkProperty "show" [boolProp a] + +middlec :: Int -> CabProp +middlec a = mkProperty "middlec" [IntArg a] + +keywidth :: Int -> CabProp +keywidth a = mkProperty "keywidth" [IntArg a] + +scrollbars :: Bool -> CabProp +scrollbars a = mkProperty "scrollbars" [boolProp a] + +fontstyle :: String -> CabProp +fontstyle a = mkProperty "fontstyle" [StringArg a] + +scrubberpos :: Int -> CabProp +scrubberpos a = mkProperty "scrubberpos" [IntArg a] + +zoom :: Float -> CabProp +zoom a = mkProperty "zoom" [FloatArg a] + +displaytype :: String -> CabProp +displaytype a = mkProperty "displaytype" [StringArg a] + +updaterate :: Int -> CabProp +updaterate a = mkProperty "updaterate" [IntArg a] + +wrap :: Bool -> CabProp +wrap a = mkProperty "wrap" [boolProp a] diff --git a/src/Csound/Typed/Gui/Cabbage/CabbageLang.hs b/src/Csound/Typed/Gui/Cabbage/CabbageLang.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Gui/Cabbage/CabbageLang.hs @@ -0,0 +1,38 @@ +module Csound.Typed.Gui.Cabbage.CabbageLang( + Lang, Line(..), Property(..), Arg(..), ppCabbage +) where + +import Text.PrettyPrint.Leijen + +type Lang = [Line] + +data Line = Line + { lineDef :: String + , lineProperties :: [Property] + } + +data Property = Property + { propertyName :: String + , propertyArgs :: [Arg] + } + +data Arg = StringArg String | FloatArg Float | IntArg Int | ColonArg Float Float + +-------------------------------------------------- +-- pretty print + +ppCabbage :: Lang -> Doc +ppCabbage xs = vcat $ fmap ppLine xs + +ppLine :: Line -> Doc +ppLine (Line name props) = text name <+> hcat (punctuate comma (fmap ppProp props)) + +ppProp :: Property -> Doc +ppProp (Property name args) = text name <> tupled (fmap ppArg args) + +ppArg :: Arg -> Doc +ppArg x = case x of + StringArg s -> dquotes (text s) + FloatArg a -> float a + IntArg a -> int a + ColonArg a b -> float a <> colon <> float b 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 @@ -370,7 +370,7 @@ where instr ref = SE $ do val <- readVar ref - whens + whens Kr [ (val ==* 0, writeVar ref 1) ] (writeVar ref 0) turnoff diff --git a/src/Csound/Typed/Lib/StableMaps/Dynamic.hs b/src/Csound/Typed/Lib/StableMaps/Dynamic.hs deleted file mode 100644 --- a/src/Csound/Typed/Lib/StableMaps/Dynamic.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE TypeFamilies, Rank2Types #-} ------------------------------------------------------------------------------ --- | --- Module : System.Mem.StableName.Dynamic --- Copyright : (c) Edward Kmett 2010 --- License : BSD3 --- Maintainer : ekmett@gmail.com --- Stability : experimental --- Portability : GHC only --- --- Dynamic stable names are a way of performing fast (O(1)), not-quite-exact comparison between objects. --- --- Dynamic stable names solve the following problem: suppose you want to build a hash table with Haskell objects as keys, but you want to use pointer equality for comparison; maybe because the keys are large and hashing would be slow, or perhaps because the keys are infinite in size. We can't build a hash table using the address of the object as the key, because objects get moved around by the garbage collector, meaning a re-hash would be necessary after every garbage collection. ------------------------------------------------------------------------------ - -module Csound.Typed.Lib.StableMaps.Dynamic - ( DynamicStableName(..) - , hashDynamicStableName - , makeDynamicStableName - , wrapStableName - ) where - -import GHC.Prim - -import System.Mem.StableName (StableName, makeStableName, hashStableName) -import Unsafe.Coerce (unsafeCoerce) - -{-| - An abstract name for an object, that supports equality and hashing. - - Dynamic stable names have the following property: - - * If @sn1 :: DynamicStableName@ and @sn2 :: DynamicStableName@ and @sn1 == sn2@ - then @sn1@ and @sn2@ were created by calls to @makeStableName@ on - the same object. - - The reverse is not necessarily true: if two dynamic stable names are not - equal, then the objects they name may still be equal. Note in particular - that `makeDynamicStableName` may return a different `DynamicStableName` - after an object is evaluated. - - Dynamic Stable Names are similar to Stable Pointers ("Foreign.StablePtr"), - but differ in the following ways: - - * There is no @freeDynamicStableName@ operation, unlike "Foreign.StablePtr"s. - Dynamic Stable Names are reclaimed by the runtime system when they are no - longer needed. - - * There is no @deRefDynamicStableName@ operation. You can\'t get back from - a dynamic stable name to the original Haskell object. The reason for - this is that the existence of a stable name for an object does not - guarantee the existence of the object itself; it can still be garbage - collected. - --} - -newtype DynamicStableName = DynamicStableName (StableName Any) - --- | Makes a 'DynamicStableName' for an arbitrary object. The object passed as --- the first argument is not evaluated by 'makeDynamicStableName'. -makeDynamicStableName :: t -> IO DynamicStableName -makeDynamicStableName a = do - s <- makeStableName a - return (wrapStableName s) - --- | Convert a 'DynamicStableName' to an 'Int'. The 'Int' returned is not --- necessarily unique; several 'DynamicStableName's may map to the same 'Int' --- (in practice however, the chances of this are small, so the result --- of 'hashDynamicStableName' makes a good hash key). -hashDynamicStableName :: DynamicStableName -> Int -hashDynamicStableName (DynamicStableName sn) = hashStableName sn - -instance Eq DynamicStableName where - DynamicStableName sn1 == DynamicStableName sn2 = sn1 == sn2 - -wrapStableName :: StableName a -> DynamicStableName -wrapStableName s = DynamicStableName (unsafeCoerce s) diff --git a/src/Csound/Typed/Lib/StableMaps/Dynamic/Map.hs b/src/Csound/Typed/Lib/StableMaps/Dynamic/Map.hs deleted file mode 100644 --- a/src/Csound/Typed/Lib/StableMaps/Dynamic/Map.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE CPP #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Unsafe #-} -#endif -module Csound.Typed.Lib.StableMaps.Dynamic.Map - ( Map - , empty - , null - , singleton - , member - , notMember - , insert - , insertWith - , insertWith' - , lookup - , find - , findWithDefault - ) where - -import qualified Prelude -import Prelude hiding (lookup, null) -import Csound.Typed.Lib.StableMaps.Dynamic -import qualified Data.IntMap as IntMap -import Data.IntMap (IntMap) - -newtype Map a = Map { getMap :: IntMap [(DynamicStableName, a)] } - -empty :: Map a -empty = Map IntMap.empty - -null :: Map a -> Bool -null (Map m) = IntMap.null m - -singleton :: DynamicStableName -> a -> Map a -singleton k v = Map $ IntMap.singleton (hashDynamicStableName k) [(k,v)] - -member :: DynamicStableName -> Map a -> Bool -member k m = case lookup k m of - Nothing -> False - Just _ -> True - -notMember :: DynamicStableName -> Map a -> Bool -notMember k m = not $ member k m - -insert :: DynamicStableName -> a -> Map a -> Map a -insert k v = Map . IntMap.insertWith (++) (hashDynamicStableName k) [(k,v)] . getMap - --- | /O(log n)/. Insert with a function for combining the new value and old value. --- @'insertWith' f key value mp@ --- will insert the pair (key, value) into @mp@ if the key does not exist --- in the map. If the key does exist, the function will insert the pair --- @(key, f new_value old_value)@ -insertWith :: (a -> a -> a) -> DynamicStableName -> a -> Map a -> Map a -insertWith f k v = Map . IntMap.insertWith go (hashDynamicStableName k) [(k,v)] . getMap - where - go _ ((k',v'):kvs) - | k == k' = (k', f v v') : kvs - | otherwise = (k',v') : go undefined kvs - go _ [] = [] - --- | Same as 'insertWith', but with the combining function applied strictly. -insertWith' :: (a -> a -> a) -> DynamicStableName -> a -> Map a -> Map a -insertWith' f k v = Map . IntMap.insertWith go (hashDynamicStableName k) [(k,v)] . getMap - where - go _ ((k',v'):kvs) - | k == k' = let v'' = f v v' in v'' `seq` (k', v'') : kvs - | otherwise = (k', v') : go undefined kvs - go _ [] = [] - --- | /O(log n)/. Lookup the value at a key in the map. --- --- The function will return the corresponding value as a @('Just' value)@ --- or 'Nothing' if the key isn't in the map. -lookup :: DynamicStableName -> Map v -> Maybe v -lookup k (Map m) = do - pairs <- IntMap.lookup (hashDynamicStableName k) m - Prelude.lookup k pairs - -find :: DynamicStableName -> Map v -> v -find k m = case lookup k m of - Nothing -> error "Map.find: element not in the map" - Just x -> x - --- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns --- the value at key @k@ or returns the default value @def@ --- when the key is not in the map. -findWithDefault :: v -> DynamicStableName -> Map v -> v -findWithDefault dflt k m = maybe dflt id $ lookup k m diff --git a/src/Csound/Typed/Plugins.hs b/src/Csound/Typed/Plugins.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Plugins.hs @@ -0,0 +1,39 @@ +module Csound.Typed.Plugins( + adsr140, + audaciousEq, + + -- Solina chorus + solinaChorus, testSolinaChorus, + + -- One pole filters + zdf1, zlp1, zhp1, zap1, + + -- Two pole filters + zdf2, zlp, zbp, zhp, zdf2_notch, zbr, + + -- Ladder filter + zladder, + + -- Four poles filters + zdf4, zlp4, zbp4, zhp4, + + -- Eq-filters + peakEq, highShelf, lowShelf, + + -- Diode ladder filters + diode, linDiode, noNormDiode, + + -- Korg 35 filters + linKorg_lp, linKorg_hp, korg_lp, korg_hp, + + -- zero delay convolution + ZConvSpec(..), zconv, zconv' +) where + +import Csound.Typed.Plugins.Adsr140 +import Csound.Typed.Plugins.Zdf +import Csound.Typed.Plugins.Diode +import Csound.Typed.Plugins.Audaciouseq +import Csound.Typed.Plugins.Korg35 +import Csound.Typed.Plugins.SolinaChorus +import Csound.Typed.Plugins.ZeroDelayConvolution diff --git a/src/Csound/Typed/Plugins/Adsr140.hs b/src/Csound/Typed/Plugins/Adsr140.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Plugins/Adsr140.hs @@ -0,0 +1,25 @@ +module Csound.Typed.Plugins.Adsr140( + adsr140 +) where + +import Data.Boolean +import Control.Monad.Trans.Class + +import Csound.Dynamic + +import Csound.Typed.Types +import Csound.Typed.GlobalState +import qualified Csound.Typed.GlobalState.Elements as E(adsr140Plugin) + + +------------------------------------------------------------------------------- + +-- | Gated, Re-triggerable ADSR modeled after the Doepfer A-140 +-- opcode adsr140, a, aakkkk +-- +-- inputs: agate, aretrig, kattack, kdecay, ksustain, krelease +adsr140 :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Sig +adsr140 agate aretrig kattack kdecay ksustain krelease = fromGE $ do + addUdoPlugin E.adsr140Plugin + f <$> toGE agate <*> toGE aretrig <*> toGE kattack <*> toGE kdecay <*> toGE ksustain <*> toGE krelease + where f agate aretrig kattack kdecay ksustain krelease = opcs "adsr140" [(Ar, [Ar, Ar, Kr, Kr, Kr, Kr])] [agate, aretrig, kattack, kdecay, ksustain, krelease] diff --git a/src/Csound/Typed/Plugins/Audaciouseq.hs b/src/Csound/Typed/Plugins/Audaciouseq.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Plugins/Audaciouseq.hs @@ -0,0 +1,33 @@ +module Csound.Typed.Plugins.Audaciouseq( + audaciousEq +) where + +import Data.Boolean +import Control.Monad.Trans.Class + +import Csound.Dynamic + +import Csound.Typed.Types +import Csound.Typed.GlobalState +import qualified Csound.Typed.GlobalState.Elements as E(audaciouseqPlugin) + +------------------------------------------------------------------------------- + +-- | opcode audaciouseq, a, kkkkkkkkkka +-- +-- inputs: kgain1, kgain2, kgain3, kgain4, kgain5, +-- kgain6, kgain7, kgain8, kgain9, kgain10 ain +-- +-- 10-band EQ +-- Input: kgain1, kgain2, ... kgain10, asig +-- Output: aout +-- +-- 10 kgain arguments maps to each band +-- Bands are: 31.25, 52.6, 125, 500, 1000, +-- 2000, 4000, 8000, 16000 +-- +audaciousEq :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Sig +audaciousEq kgain1 kgain2 kgain3 kgain4 kgain5 kgain6 kgain7 kgain8 kgain9 kgain10 ain = fromGE $ do + addUdoPlugin E.audaciouseqPlugin + f <$> toGE ain <*> toGE kgain1 <*> toGE kgain2 <*> toGE kgain3 <*> toGE kgain4 <*> toGE kgain5 <*> toGE kgain6 <*> toGE kgain7 <*> toGE kgain8 <*> toGE kgain9 <*> toGE kgain10 + where f ain kgain1 kgain2 kgain3 kgain4 kgain5 kgain6 kgain7 kgain8 kgain9 kgain10 = opcs "audaciouseq" [(Ar, [Ar, Kr, Kr, Kr, Kr, Kr, Kr, Kr, Kr, Kr, Kr])] [ain, kgain1, kgain2, kgain3, kgain4, kgain5, kgain6, kgain7, kgain8, kgain9, kgain10] diff --git a/src/Csound/Typed/Plugins/Diode.hs b/src/Csound/Typed/Plugins/Diode.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Plugins/Diode.hs @@ -0,0 +1,75 @@ +module Csound.Typed.Plugins.Diode( + diode, linDiode, noNormDiode +) where + +import Data.Boolean +import Control.Monad.Trans.Class + +import Csound.Dynamic + +import Csound.Typed.Types +import Csound.Typed.GlobalState +import qualified Csound.Typed.GlobalState.Elements as E(diodePlugin) + +-- | Linear diode ladder filter. +-- +-- > linDiode centerFrequency resonance asig +-- +-- resonance ranges in the interval [0, 1] and higher. +-- self-resonance occurs at 1. +linDiode :: Sig -> Sig -> Sig -> Sig +linDiode cfq res ain = diodeLadder ain cfq (normReson res) 0 1 + +-- | Non-Linear normalized diode ladder filter. +-- +-- > diode saturation centerFrequency resonance asig +-- +-- resonance ranges in the interval [0, 1] and higher. +-- self-resonance occurs at 1. +-- +-- saturation ranges from 1 and higher (typical value: 4) +diode :: Sig -> Sig -> Sig -> Sig -> Sig +diode ksaturation cfq res ain = diodeLadder ain cfq (normReson res) 1 ksaturation + +-- | Non-Linear not normalized diode ladder filter. +-- +-- > noNormDiode saturation centerFrequency resonance asig +-- +-- resonance ranges in the interval [0, 1] and higher. +-- self-resonance occurs at 1. +-- +-- saturation ranges from 1 and higher (typical value: 4) +noNormDiode :: Sig -> Sig -> Sig -> Sig -> Sig +noNormDiode ksaturation cfq res ain = diodeLadder ain cfq (normReson res) 2 ksaturation + +normReson :: Sig -> Sig +normReson res = res * 17 + +------------------------------------------------------------------------------- + +-- | Diode Ladder Filter +-- +-- Based on code by Will Pirkle, presented in: +-- +-- http://www.willpirkle.com/Downloads/AN-6DiodeLadderFilter.pdf +-- +-- and in his book "Designing software synthesizer plug-ins in C++ : for +-- RackAFX, VST3, and Audio Units" +-- +-- UDO version by Steven Yi (2016.xx.xx) +-- +-- ARGS +-- ain - signal to filter +-- acf/kcf - cutoff frequency +-- ak/kk - k-value that controls resonance, self-resonance occurs at k=17; +-- knlp - use non-linear processing: +-- 0 - none +-- 1 - normalized (outputs to range +-1.0) +-- 2 - non-normalized (less expensive than normalized, range +-0.8) +-- ksaturation - saturation amount for non-linear processing +-- (default: 1.0, greater values lead to higher saturation) +diodeLadder :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig +diodeLadder ain xcf xk knlp ksaturation = fromGE $ do + addUdoPlugin E.diodePlugin + f <$> toGE ain <*> toGE xcf <*> toGE xk <*> toGE knlp <*> toGE ksaturation + where f ain xcf xk knlp ksaturation = opcs "diode_ladder" [(Ar, [Ar, Xr, Xr, Kr, Kr])] [ain, xcf, xk, knlp, ksaturation] diff --git a/src/Csound/Typed/Plugins/Korg35.hs b/src/Csound/Typed/Plugins/Korg35.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Plugins/Korg35.hs @@ -0,0 +1,99 @@ +module Csound.Typed.Plugins.Korg35( + linKorg_lp, linKorg_hp, korg_lp, korg_hp +) where + +import Data.Boolean +import Control.Monad.Trans.Class + +import Csound.Dynamic + +import Csound.Typed.Types +import Csound.Typed.GlobalState +import qualified Csound.Typed.GlobalState.Elements as E(korg35Plugin) + +-- | Linear korg 35 low pass filter (12 dB). +-- +-- > linDiode centerFrequency resonance asig +-- +-- resonance ranges in the interval [0, 1] and higher. +-- self-resonance occurs at 1. +linKorg_lp :: Sig -> Sig -> Sig -> Sig +linKorg_lp cfq res ain = k35_lpf ain cfq (normReson res) 0 1 + +-- | Linear korg 35 high pass filter (6 dB). +-- +-- > linDiode centerFrequency resonance asig +-- +-- resonance ranges in the interval [0, 1] and higher. +-- self-resonance occurs at 1. +linKorg_hp :: Sig -> Sig -> Sig -> Sig +linKorg_hp cfq res ain = k35_hpf ain cfq (normReson res) 0 1 + + +-- | Korg 35 low pass filter (12 dB). +-- +-- > diode saturation centerFrequency resonance asig +-- +-- resonance ranges in the interval [0, 1] and higher. +-- self-resonance occurs at 1. +-- +-- saturation ranges from 1 and higher (typical value: 4) +korg_lp :: Sig -> Sig -> Sig -> Sig -> Sig +korg_lp ksaturation cfq res ain = k35_lpf ain cfq (normReson res) 1 ksaturation + +-- | Korg 35 high pass filter (6 dB). +-- +-- > diode saturation centerFrequency resonance asig +-- +-- resonance ranges in the interval [0, 1] and higher. +-- self-resonance occurs at 1. +-- +-- saturation ranges from 1 and higher (typical value: 4) +korg_hp :: Sig -> Sig -> Sig -> Sig -> Sig +korg_hp ksaturation cfq res ain = k35_hpf ain cfq (normReson res) 1 ksaturation + +normReson :: Sig -> Sig +normReson res = res * 10 + +------------------------------------------------------------------------------- + +-- 12db/oct low-pass filter based on Korg 35 module +-- (found in MS-10 and MS-20). +-- +-- Based on code by Will Pirkle, presented in: +-- +-- http://www.willpirkle.com/Downloads/AN-5Korg35_V3.pdf +-- +-- [ARGS] +-- +-- ain - audio input +-- acutoff - frequency of cutoff +-- kQ - filter Q [1, 10.0] (k35-lpf will clamp to boundaries) +-- knonlinear - use non-linear processing +-- ksaturation - saturation for tanh distortion +k35_lpf :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig +k35_lpf ain acutoff kQ knonlinear ksaturation = fromGE $ do + addUdoPlugin E.korg35Plugin + f <$> toGE ain <*> toGE acutoff <*> toGE kQ <*> toGE knonlinear <*> toGE ksaturation + where f ain acutoff kQ knonlinear ksaturation = opcs "k35_lpf" [(Ar, [Ar, Xr, Kr, Kr, Kr])] [ain, acutoff, kQ, knonlinear, ksaturation] + + +-- 6db/oct high-pass filter based on Korg 35 module +-- (found in MS-10 and MS-20). +-- +-- Based on code by Will Pirkle, presented in: +-- +-- http://www.willpirkle.com/Downloads/AN-7Korg35HPF_V2.pdf +-- +-- [ARGS] +-- +-- ain - audio input +-- acutoff - frequency of cutoff +-- kQ - filter Q [1, 10.0] (k35_hpf will clamp to boundaries) +-- knonlinear - use non-linear processing +-- ksaturation - saturation for tanh distortion +k35_hpf :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig +k35_hpf ain acutoff kQ knonlinear ksaturation = fromGE $ do + addUdoPlugin E.korg35Plugin + f <$> toGE ain <*> toGE acutoff <*> toGE kQ <*> toGE knonlinear <*> toGE ksaturation + where f ain acutoff kQ knonlinear ksaturation = opcs "k35_hpf" [(Ar, [Ar, Xr, Kr, Kr, Kr])] [ain, acutoff, kQ, knonlinear, ksaturation] diff --git a/src/Csound/Typed/Plugins/SolinaChorus.hs b/src/Csound/Typed/Plugins/SolinaChorus.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Plugins/SolinaChorus.hs @@ -0,0 +1,60 @@ +module Csound.Typed.Plugins.SolinaChorus( + solinaChorus, testSolinaChorus +) where + +import Data.Boolean +import Control.Monad.Trans.Class + +import Csound.Dynamic + +import Csound.Typed.Types +import Csound.Typed.GlobalState +import qualified Csound.Typed.GlobalState.Elements as E(solinaChorusPlugin) + +-- Solina Chorus, based on Solina String Ensemble Chorus Module +-- +-- based on: +-- +-- J. Haible: Triple Chorus +-- http://jhaible.com/legacy/triple_chorus/triple_chorus.html +-- +-- > solinaChorus (lfo_amp1, lfo_freq1) (lfo_amp2, lfo_freq2) +-- +-- Author: Steven Yi +-- Date: 2016.05.22 +-- +-- Example +-- +-- > x = solinaChorus (0.6, 0.18) (0.2, 6) x +solinaChorus :: (Sig, Sig) -> (Sig, Sig) -> Sig -> Sig +solinaChorus (amp1, cps1) (amp2, cps2) ain = solina_chorus ain cps1 amp1 cps2 amp2 + +testSolinaChorus :: Sig -> Sig +testSolinaChorus x = solinaChorus (0.6, 0.18) (0.2, 6) x + +------------------------------------------------------------------------------- + +-- Solina Chorus, based on Solina String Ensemble Chorus Module +-- +-- based on: +-- +-- J. Haible: Triple Chorus +-- http://jhaible.com/legacy/triple_chorus/triple_chorus.html +-- +-- Hugo Portillo: Solina-V String Ensemble +-- http://www.native-instruments.com/en/reaktor-community/reaktor-user-library/entry/show/4525/ +-- +-- Parabola tabled shape borrowed from Iain McCurdy delayStereoChorus.csd: +-- http://iainmccurdy.org/CsoundRealtimeExamples/Delays/delayStereoChorus.csd +-- +-- Author: Steven Yi +-- Date: 2016.05.22 +-- +-- opcode solina_chorus, a, aKKKK +-- +-- aLeft, klfo_freq1, klfo_amp1, klfo_freq2, klfo_amp2 xin +solina_chorus :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig +solina_chorus aLeft klfo_freq1 klfo_amp1 klfo_freq2 klfo_amp2 = fromGE $ do + addUdoPlugin E.solinaChorusPlugin + f <$> toGE aLeft <*> toGE klfo_freq1 <*> toGE klfo_amp1 <*> toGE klfo_freq2 <*> toGE klfo_amp2 + where f aLeft klfo_freq1 klfo_amp1 klfo_freq2 klfo_amp2 = opcs "solina_chorus" [(Ar, [Ar, Kr, Kr, Kr, Kr])] [aLeft, klfo_freq1, klfo_amp1, klfo_freq2, klfo_amp2] diff --git a/src/Csound/Typed/Plugins/Zdf.hs b/src/Csound/Typed/Plugins/Zdf.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Plugins/Zdf.hs @@ -0,0 +1,209 @@ +-- Zero delay filters (implemented in Csound by Steven Yi) +module Csound.Typed.Plugins.Zdf( + -- One pole filters + zdf1, zlp1, zhp1, zap1, + + -- Two pole filters + zdf2, zlp, zbp, zhp, zdf2_notch, zbr, + + -- Ladder filter + zladder, + + -- Four poles filters + zdf4, zlp4, zbp4, zhp4, + + -- Eq-filters + peakEq, highShelf, lowShelf +) where + +import Data.Boolean +import Control.Monad.Trans.Class + +import Csound.Dynamic + +import Csound.Typed.Types +import Csound.Typed.GlobalState +import qualified Csound.Typed.GlobalState.Elements as E(zdfPlugin) + +------------------------------------------------------------------------------- +-- Haskell way (reorder arguments, split some funs) + +-- zdf_1pole + +zdf1 :: Sig -> Sig -> (Sig, Sig) +zdf1 cfq asig = zdf_1pole asig cfq + +zlp1 :: Sig -> Sig -> Sig +zlp1 cfq asig = lows + where (lows, _) = zdf_1pole asig cfq + +zhp1 :: Sig -> Sig -> Sig +zhp1 cfq asig = highs + where (_, highs) = zdf_1pole asig cfq + +-- zdf_allpass_1pole + +zap1 :: Sig -> Sig -> Sig +zap1 cfq asig = zdf_allpass_1pole asig cfq + +-- zdf_2pole + +-- outs: lp, bp, hp +zdf2 :: Sig -> Sig -> Sig -> (Sig, Sig, Sig) +zdf2 cfq q asig = zdf_2pole asig cfq q + +zlp :: Sig -> Sig -> Sig -> Sig +zlp cfq q asig = lows + where (lows, _, _) = zdf2 cfq q asig + +zbp :: Sig -> Sig -> Sig -> Sig +zbp cfq q asig = mids + where (_, mids, _) = zdf2 cfq q asig + +zhp :: Sig -> Sig -> Sig -> Sig +zhp cfq q asig = highs + where (_, _, highs) = zdf2 cfq q asig + +zdf2_notch :: Sig -> Sig -> Sig -> (Sig, Sig, Sig, Sig) +zdf2_notch cfq q asig = zdf_2pole_notch asig cfq q + +zbr cfq q asig = notch + where (_, _, _, notch) = zdf2_notch cfq q asig + +-- ladder + +zladder :: Sig -> Sig -> Sig -> Sig +zladder cfq q asig = zdf_ladder asig cfq q + +-- zdf_4pole + +zdf4 :: Sig -> Sig -> Sig -> (Sig, Sig, Sig, Sig, Sig, Sig) +zdf4 cfq q asig = zdf_4pole asig cfq q + +zlp4 :: Sig -> Sig -> Sig -> Sig +zlp4 cfq q asig = lows + where (_, _, _, lows, _, _) = zdf4 cfq q asig + +zbp4 :: Sig -> Sig -> Sig -> Sig +zbp4 cfq q asig = mids + where (_, _, _, _, mids, _) = zdf4 cfq q asig + +zhp4 :: Sig -> Sig -> Sig -> Sig +zhp4 cfq q asig = highs + where (_, _, _, _, _, highs) = zdf4 cfq q asig + +-- zdf_peak_eq +peakEq :: Sig -> Sig -> Sig -> Sig -> Sig +peakEq kcf kres kdB ain = zdf_peak_eq ain kcf kres kdB + +-- zdf_high_shelf_eq +highShelf :: Sig -> Sig -> Sig -> Sig +highShelf kcf kres ain = zdf_high_shelf_eq ain kcf kres + +-- zdf_low_shelf_eq +lowShelf :: Sig -> Sig -> Sig -> Sig +lowShelf kcf kres ain = zdf_low_shelf_eq ain kcf kres + +------------------------------------------------------------------------------- +-- Steven implementation + +-- 1-pole (6dB) lowpass/highpass filter +-- takes in a a-rate signal and cutoff value in frequency +-- +-- xout alp, ahp +zdf_1pole :: Sig -> Sig -> (Sig, Sig) +zdf_1pole asig cfq = toTuple $ fmap ($ 2) $ do + addUdoPlugin E.zdfPlugin + f <$> toGE asig <*> toGE cfq + where f asig cfq = mopcs "zdf_1pole" ([Ar, Ar], [Ar, Ar]) [asig, cfq] + +-- 1-pole allpass filter +-- takes in an a-rate signal and corner frequency where input +-- phase is shifted -90 degrees +zdf_allpass_1pole :: Sig -> Sig -> Sig +zdf_allpass_1pole asig cfq = fromGE $ do + addUdoPlugin E.zdfPlugin + f <$> toGE asig <*> toGE cfq + where f asig cfq = opcs "zdf_allpass_1pole" [(Ar, [Ar, Ar])] [asig, cfq] + +-- 2-pole (12dB) lowpass/highpass/bandpass filter +-- takes in a a-rate signal, cutoff value in frequency, and +-- Q factor for resonance +-- +-- xout alp, abp, ahp +zdf_2pole :: Sig -> Sig -> Sig -> (Sig, Sig, Sig) +zdf_2pole asig cfq q = toTuple $ fmap ($ 3) $ do + addUdoPlugin E.zdfPlugin + f <$> toGE asig <*> toGE cfq <*> toGE q + where f asig cfq q = mopcs "zdf_2pole" ([Ar, Ar, Ar], [Ar, Ar, Ar]) [asig, cfq, q] + +-- 2-pole (12dB) lowpass/highpass/bandpass/notch filter +-- takes in a a-rate signal, cutoff value in frequency, and +-- Q factor for resonance +-- +-- xout alp, abp, ahp, anotch +zdf_2pole_notch :: Sig -> Sig -> Sig -> (Sig, Sig, Sig, Sig) +zdf_2pole_notch asig cfq q = toTuple $ fmap ($ 4) $ do + addUdoPlugin E.zdfPlugin + f <$> toGE asig <*> toGE cfq <*> toGE q + where f asig cfq q = mopcs "zdf_2pole_notch" ([Ar, Ar, Ar, Ar], [Ar, Ar, Ar]) [asig, cfq, q] + +-- moog ladder +-- +-- opcode zdf_ladder, a, akk +-- +-- ain, kcf, kres xin +zdf_ladder :: Sig -> Sig -> Sig -> Sig +zdf_ladder asig cfq res = fromGE $ do + addUdoPlugin E.zdfPlugin + f <$> toGE asig <*> toGE cfq <*> toGE res + where f asig cfq res = opcs "zdf_ladder" [(Ar, [Ar, Ar, Ar])] [asig, cfq, res] + +-- 4-pole +-- +-- opcode zdf_4pole, aaaaaa, akk +-- ain, kcf, kres xin +-- +-- xout alp2, abp2, ahp2, alp4, abl4, abp4 +zdf_4pole :: Sig -> Sig -> Sig -> (Sig, Sig, Sig, Sig, Sig, Sig) +zdf_4pole asig cfq res = toTuple $ fmap ($ 6) $ do + addUdoPlugin E.zdfPlugin + f <$> toGE asig <*> toGE cfq <*> toGE res + where f asig cfq res = mopcs "zdf_4pole" ([Ar, Ar, Ar, Ar, Ar, Ar], [Ar, Ar, Ar]) [asig, cfq, res] + +-- 4-pole +-- +-- opcode zdf_4pole_hp, aaaaaa, akk +-- ain, kcf, kres xin +-- +-- xout alp2, abp2, ahp2, alp4, abl4, abp4 +zdf_4pole_hp :: Sig -> Sig -> Sig -> (Sig, Sig, Sig, Sig, Sig, Sig) +zdf_4pole_hp asig cfq res = toTuple $ fmap ($ 6) $ do + addUdoPlugin E.zdfPlugin + f <$> toGE asig <*> toGE cfq <*> toGE res + where f asig cfq res = mopcs "zdf_4pole_hp" ([Ar, Ar, Ar, Ar, Ar, Ar], [Ar, Ar, Ar]) [asig, cfq, res] + +-- ;; TODO - implement +-- opcode zdf_peak_eq, a, akkk +-- ain, kcf, kres, kdB xin +zdf_peak_eq :: Sig -> Sig -> Sig -> Sig -> Sig +zdf_peak_eq ain kcf kres kdB = fromGE $ do + addUdoPlugin E.zdfPlugin + f <$> toGE ain <*> toGE kcf <*> toGE kres <*> toGE kdB + where f ain kcf kres kdB = opcs "zdf_peak_eq" [(Ar, [Ar, Kr, Kr, Kr])] [ain, kcf, kres, kdB] + +-- opcode zdf_high_shelf_eq, a, akk +-- ain, kcf, kdB xin +zdf_high_shelf_eq :: Sig -> Sig -> Sig -> Sig +zdf_high_shelf_eq asig cfq res = fromGE $ do + addUdoPlugin E.zdfPlugin + f <$> toGE asig <*> toGE cfq <*> toGE res + where f asig cfq res = opcs "zdf_high_shelf_eq" [(Ar, [Ar, Kr, Kr])] [asig, cfq, res] + +-- opcode zdf_low_shelf_eq, a, akk +-- ain, kcf, kdB xin +zdf_low_shelf_eq :: Sig -> Sig -> Sig -> Sig +zdf_low_shelf_eq asig cfq res = fromGE $ do + addUdoPlugin E.zdfPlugin + f <$> toGE asig <*> toGE cfq <*> toGE res + where f asig cfq res = opcs "zdf_low_shelf_eq" [(Ar, [Ar, Kr, Kr])] [asig, cfq, res] diff --git a/src/Csound/Typed/Plugins/ZeroDelayConvolution.hs b/src/Csound/Typed/Plugins/ZeroDelayConvolution.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Typed/Plugins/ZeroDelayConvolution.hs @@ -0,0 +1,52 @@ +module Csound.Typed.Plugins.ZeroDelayConvolution( + ZConvSpec(..), zconv, zconv' +) where + +import Data.Boolean +import Data.Default +import Control.Monad.Trans.Class + +import Csound.Dynamic + +import Csound.Typed.Types +import Csound.Typed.GlobalState +import qualified Csound.Typed.GlobalState.Elements as E(zeroDelayConvolutionPlugin) + + +-- | Zero convolution specification +data ZConvSpec = ZConvSpec + { zconvPartSize :: D -- ^ first partition size in samples + , zconvRatio :: D -- ^ partition growth ratio + , zconvNp :: D -- ^ total number of partition sizes + } + +instance Default ZConvSpec where + def = ZConvSpec 64 4 6 + +------------------------------------------------------------------------------- + +-- | Zero delay convolution with default parameters. +-- +-- > zconv tabIR ain = ... +zconv :: Tab -> Sig -> Sig +zconv = zconv' def + +-- | zero delay convolution. +-- +-- > zconv' (ZConvSpec ipart irat inp) ifn ain +-- +-- Original UDO code by Victor Lazzarini. +-- +-- /************************************************** +-- asig ZConv ain,ipart,irat,inp,ifn +-- ain - input signal +-- ipart - first partition size in samples +-- irat - partition growth ratio +-- inp - total number of partition sizes +-- ifn - function table number containing the IR +-- **************************************************/ +zconv' :: ZConvSpec -> Tab -> Sig -> Sig +zconv' (ZConvSpec ipart irat inp) ifn ain = fromGE $ do + addUdoPlugin E.zeroDelayConvolutionPlugin + f <$> toGE ain <*> toGE ipart <*> toGE irat <*> toGE inp <*> toGE ifn + where f ain ipart irat inp ifn = opcs "ZConv" [(Ar, [Ar, Ir, Ir, Ir, Ir])] [ain, ipart, irat, inp, ifn] 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 @@ -17,6 +17,8 @@ import qualified Data.IntMap as IM import Control.Monad.IO.Class +import Text.PrettyPrint.Leijen(displayS, renderPretty) + import Csound.Dynamic hiding (csdFlags) import Csound.Typed.Types import Csound.Typed.GlobalState @@ -27,6 +29,7 @@ import Csound.Dynamic.Types.Flags import Csound.Typed.Gui.Gui(guiStmt, panelIsKeybdSensitive) +import Csound.Typed.Gui.Cabbage.CabbageLang(ppCabbage) toCsd :: Tuple a => Maybe Int -> Options -> SE a -> GE Csd @@ -77,16 +80,21 @@ hist2 <- getHistory let namedIntruments = fmap (\(name, body) -> Instr (InstrLabel name) body) $ unNamedInstrs $ namedInstrs hist2 let orc = Orc instr0 ((namedIntruments ++ ) $ maybeAppend keyEventListener $ fmap (uncurry Instr) $ instrsContent $ instrs hist2) - hist3 <- getHistory + hist3 <- getHistory let flags = reactOnMidi hist3 $ csdFlags opt sco = Sco (Just $ pureGetTotalDurForF0 $ totalDur hist3) (renderGens (genMap hist3) (writeGenMap hist3)) $ - ((fmap alwaysOn $ alwaysOnInstrs hist3) ++ (getNoteEvents $ notes hist3)) - return $ Csd flags orc sco + ((fmap alwaysOn $ alwaysOnInstrs hist3) ++ (getNoteEvents $ notes hist3)) + let plugins = getPlugins opt hist3 + return $ Csd flags orc sco plugins where renderGens gens writeGens = (fmap swap $ M.toList $ idMapContent gens) ++ writeGens maybeAppend ma = maybe id (:) ma getNoteEvents = fmap $ \(instrId, evt) -> (instrId, [evt]) + + getPlugins opt hist = case cabbageGui hist of + Nothing -> [] + Just x -> [(Plugin "Cabbage" (displayS (renderPretty 1 10000 $ ppCabbage x) ""))] getInstr0 :: Maybe Int -> Int -> Options -> Dep () -> History -> Dep () getInstr0 mnchnls_i nchnls opt udos hist = do 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 @@ -612,7 +612,7 @@ where elseIfs = mapM_ (\(p, body) -> elseBegin >> ifBegin p >> body) ifBegin :: BoolSig -> SE () -ifBegin a = fromDep_ $ D.ifBegin =<< lift (toGE a) +ifBegin a = fromDep_ $ D.ifBegin Kr =<< lift (toGE a) ifEnd :: SE () ifEnd = fromDep_ D.ifEnd @@ -644,7 +644,7 @@ where elseIfs = mapM_ (\(p, body) -> elseBegin >> ifBeginD p >> body) ifBeginD :: BoolD -> SE () -ifBeginD a = fromDep_ $ D.ifBegin =<< lift (toGE a) +ifBeginD a = fromDep_ $ D.ifBegin Ir =<< lift (toGE a) -- elseIfBegin :: BoolSig -> SE () -- elseIfBegin a = fromDep_ $ D.elseIfBegin =<< lift (toGE a) 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 @@ -164,6 +164,12 @@ instance Sigs Sig6 instance Sigs Sig8 +instance Sigs (Sig2, Sig2) +instance Sigs (Sig2, Sig2, Sig2) +instance Sigs (Sig2, Sig2, Sig2, Sig2) +instance Sigs (Sig2, Sig2, Sig2, Sig2, Sig2) +instance Sigs (Sig2, Sig2, Sig2, Sig2, Sig2, Sig2) + instance Sigs (Sig8, Sig8) instance Sigs (Sig8, Sig8, Sig8, Sig8) @@ -354,4 +360,47 @@ 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)