module Csound.Air.Live (
mixer, hmixer, mixMono,
FxFun, FxUI(..), fxBox,
fxColor, fxVer, fxHor, fxSca, fxApp,
uiDistort, uiChorus, uiFlanger, uiPhaser, uiDelay, uiEcho,
uiFilter, uiReverb, uiGain, uiWhite, uiPink, uiFx, uiRoom,
uiHall, uiCave, uiSig, uiMix,
AdsrBound(..), AdsrInit(..),
linAdsr, expAdsr,
classicWaves,
masterVolume, masterVolumeKnob
) where
import Control.Monad
import Data.Colour
import Data.Boolean
import qualified Data.Colour.Names as C
import Csound.Typed
import Csound.Typed.Gui
import Csound.Control.Gui(funnyRadio, mapSource)
import Csound.Typed.Opcode hiding (space)
import Csound.SigSpace
import Csound.Air.Wave
import Csound.Air.Fx
import Csound.Air.Misc
type FxFun = Sig2 -> SE Sig2
instance SigSpace FxFun where
mapSig f g = fmap (mapSig f) . g
mixer :: [(String, SE Sig2)] -> Source Sig2
mixer = genMixer (ver, hor)
hmixer :: [(String, SE Sig2)] -> Source Sig2
hmixer = genMixer (hor, ver)
genMixer :: ([Gui] -> Gui, [Gui] -> Gui) -> [(String, SE Sig2)] -> Source Sig2
genMixer (parentGui, childGui) as = source $ do
gTags <- mapM box names
(gs, vols) <- fmap unzip $ mapM (const $ defSlider "") names
(gMutes, mutes) <- fmap unzip $ mapM (const $ toggleSig "" False) names
gMasterTag <- box "master"
(gMaster, masterVol) <- defSlider ""
(gMasterMute, masterMute) <- toggleSig "" False
let g = parentGui $ zipWith3 (\tag slid mute -> childGui [sca 0.8 tag, sca 8 slid, sca 1.1 mute])
(gMasterTag : gTags) (gMaster : gs) (gMasterMute : gMutes)
muteVols = zipWith appMute mutes vols
masterMuteVol = appMute masterMute masterVol
res <- mul masterMuteVol $ mean $ zipWith mul muteVols sigs
return (g, res)
where
(names, sigs) = unzip as
appMute mute vol = (port (1 mute) 0.05) * vol
mixMono :: String -> Sig -> (String, SE Sig2)
mixMono name asig = (name, return (asig, asig))
defSlider :: String -> Source Sig
defSlider tag = slider tag (linSpan 0 1) 0.5
class FxUI a where
applyFxArgs :: a -> [Sig] -> Sig2 -> SE Sig2
arityFx :: a -> Int
instance FxUI (Sig2 -> Sig2) where
applyFxArgs f _ x = return $ f x
arityFx = const 0
instance FxUI FxFun where
applyFxArgs f _ x = f x
arityFx = const 0
instance FxUI a => FxUI (Sig -> a) where
applyFxArgs f (a:as) x = applyFxArgs (f a) as x
arityFx f = 1 + arityFx (proxy f)
where
proxy :: (a -> b) -> b
proxy _ = undefined
fxBox :: FxUI a => String -> a -> Bool -> [(String, Double)] -> Source FxFun
fxBox name fx onOff args = source $ do
(gOff0, off) <- toggleSig name onOff
let gOff = setFontSize 25 gOff0
offRef <- newGlobalSERef (0 :: Sig)
writeSERef offRef off
let (names, initVals) = unzip $ take (arityFx fx) args
(gs, as) <- fmap unzip $ mapM (\(name, initVal) -> slider name (linSpan 0 1) initVal) $ zip names initVals
let f x = do
ref <- newSERef (0 :: Sig, 0 :: Sig)
goff <- readSERef offRef
writeSERef ref x
when1 (goff ==* 1) $ do
x2 <- readSERef ref
writeSERef ref =<< applyFxArgs fx as x2
res <- readSERef ref
return res
let gui = setBorder UpBoxBorder $ go (length names) gOff gs
return (gui, f)
where
go n gOff gs
| n == 0 = gOff
| n < 4 = f (gs ++ replicate (4 n) space)
| otherwise = f gs
where f xs = uiGroupGui gOff (ver xs)
uiGroupGui :: Gui -> Gui -> Gui
uiGroupGui a b =ver [sca 1.7 a, sca 8 b]
sourceColor2 :: Color -> Source a -> Source a
sourceColor2 col a = source $ do
(g, x) <- a
return (setColor2 col g, x)
fxColor :: Color -> Source a -> Source a
fxColor = sourceColor2
fxGroup :: ([Gui] -> Gui) -> [Source FxFun] -> Source FxFun
fxGroup guiGroup as = do
(gs, fs) <- fmap unzip $ sequence as
return (guiGroup gs, foldl (\a b -> a >=> b) return fs)
fxSca :: Double -> Source FxFun -> Source FxFun
fxSca d a = fxGroup (\xs -> sca d $ head xs) [a]
fxHor :: [Source FxFun] -> Source FxFun
fxHor = fxGroup hor
fxVer :: [Source FxFun] -> Source FxFun
fxVer = fxGroup ver
fxApp :: FxFun -> Source FxFun -> Source FxFun
fxApp f = mapSource (>=> f)
uiDistort :: Bool -> Double -> Double -> Double -> Source FxFun
uiDistort isOn level drive tone = sourceColor2 C.red $ fxBox "Distortion" fxDistort2 isOn
[("level", level), ("drive", drive), ("tone", tone)]
uiChorus :: Bool -> Double -> Double -> Double -> Double -> Source FxFun
uiChorus isOn mix rate depth width = sourceColor2 C.coral $ fxBox "Chorus" stChorus2 isOn
[("mix",mix), ("rate",rate), ("depth",depth), ("width",width)]
uiFlanger :: Bool -> Double -> Double -> Double -> Double -> Double -> Source FxFun
uiFlanger isOn mix fback rate depth delay = sourceColor2 C.indigo $ fxBox "Flanger" fxFlanger2 isOn
[("mix", mix), ("fback", fback), ("rate",rate), ("depth",depth), ("delay",delay)]
uiPhaser :: Bool -> Double -> Double -> Double -> Double -> Double -> Source FxFun
uiPhaser isOn mix fback rate depth freq = sourceColor2 C.orange $ fxBox "Phaser" fxPhaser2 isOn
[("mix", mix), ("fback", fback), ("rate",rate), ("depth",depth), ("freq", freq)]
uiDelay :: Bool -> Double -> Double -> Double -> Double -> Source FxFun
uiDelay isOn mix fback time tone = sourceColor2 C.dodgerblue $ fxBox "Delay" analogDelay2 isOn
[("mix",mix), ("fback",fback), ("time",time), ("tone",tone)]
uiEcho :: Bool -> D -> Double -> Double -> Source FxFun
uiEcho isOn maxDelTime time fback = sourceColor2 C.deepskyblue $ fxBox "Echo" (fxEcho2 maxDelTime) isOn
[("time", time), ("fback", fback)]
uiFilter :: Bool -> Double -> Double -> Double -> Source FxFun
uiFilter isOn lpf hpf gain = fxBox "Filter" fxFilter2 isOn
[("lpf",lpf), ("hpf",hpf), ("gain",gain)]
uiReverb :: Bool -> Double -> Double -> Source FxFun
uiReverb isOn mix depth = sourceColor2 C.forestgreen $ fxBox "Reverb" (\mix depth asig -> mul (1 mix) asig + mul mix (rever2 depth asig)) isOn
[("mix", mix), ("depth", depth)]
uiGain :: Bool -> Double -> Source FxFun
uiGain isOn gain = sourceColor2 C.black $ fxBox "Gain" fxGain isOn [("gain", gain)]
uiWhite :: Bool -> Double -> Double -> Source FxFun
uiWhite isOn freq depth = sourceColor2 C.dimgray $ fxBox "White" fxWhite2 isOn
[("freq", freq), ("depth", depth)]
uiPink :: Bool -> Double -> Double -> Source FxFun
uiPink isOn freq depth = sourceColor2 C.deeppink $ fxBox "Pink" fxPink2 isOn
[("freq", freq), ("depth", depth)]
uiFx :: FxUI a => String -> a -> Bool -> Source FxFun
uiFx name f isOn = fxBox name f isOn []
uiRoom :: Bool -> Source FxFun
uiRoom isOn = sourceColor2 C.limegreen $ uiFx "Room" smallRoom2 isOn
uiHall :: Bool -> Source FxFun
uiHall isOn = sourceColor2 C.mediumseagreen $ uiFx "Hall" largeHall2 isOn
uiCave :: Bool -> Source FxFun
uiCave isOn = sourceColor2 C.darkviolet $ uiFx "Cave" magicCave2 isOn
uiMidi :: Bool -> [(String, Msg -> SE Sig2)] -> Source FxFun
uiMidi isOn as = sourceColor2 C.forestgreen $ undefined
uiSig :: String -> Bool -> Source Sig2 -> Source FxFun
uiSig name onOff widget = source $ do
(gs, asig) <- widget
(gOff0, off) <- toggleSig name onOff
let gOff = setFontSize 25 gOff0
f x = return $ x + mul (portk off 0.05) asig
return (setBorder UpBoxBorder $ uiGroupGui gOff gs, f)
uiMix :: Bool -> [(String, SE Sig2)] -> Source FxFun
uiMix onOff as = sourceColor2 C.blue $ uiSig "Mix" onOff (mixer as)
data AdsrBound = AdsrBound
{ attBound :: Double
, decBound :: Double
, relBound :: Double }
data AdsrInit = AdsrInit
{ attInit :: Double
, decInit :: Double
, susInit :: Double
, relInit :: Double }
expEps :: Fractional a => a
expEps = 0.00001
linAdsr :: String -> AdsrBound -> AdsrInit -> Source Sig
linAdsr = genAdsr $ \a d s r -> linsegr [0, a, 1, d, s] r 0
expAdsr :: String -> AdsrBound -> AdsrInit -> Source Sig
expAdsr = genAdsr $ \a d s r -> expsegr [double expEps, a, 1, d, s] r (double expEps)
genAdsr :: (D -> D -> D -> D -> Sig)
-> String -> AdsrBound -> AdsrInit -> Source Sig
genAdsr mkAdsr name b inits = source $ do
(gatt, att) <- knob "A" (linSpan expEps $ attBound b) (attInit inits)
(gdec, dec) <- knob "D" (linSpan expEps $ decBound b) (decInit inits)
(gsus, sus) <- knob "S" (linSpan expEps 1) (susInit inits)
(grel, rel) <- knob "R" (linSpan expEps $ relBound b) (relInit inits)
let val = mkAdsr (ir att) (ir dec) (ir sus) (ir rel)
gui <- setTitle name $ hor [gatt, gdec, gsus, grel]
return (gui, val)
classicWaves :: String -> Int -> Source (Sig -> Sig)
classicWaves name initVal = funnyRadio name
[ ("osc", osc)
, ("tri", tri)
, ("sqr", sqr)
, ("saw", saw)]
initVal
masterVolume :: Source Sig
masterVolume = slider "master" uspan 0.5
masterVolumeKnob :: Source Sig
masterVolumeKnob = knob "master" uspan 0.5