{-# Language ScopedTypeVariables, TypeFamilies, TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-}
module Csound.Air.Live (
mixer, hmixer, mixMono,
fxBox, uiBox,
fxColor, fxVer, fxHor, fxGrid, fxSca, fxMap, fxApply, atFx,
fxHorMS, fxVerMS, fxGridMS,
fromMonoFx,
hinstrChooser, vinstrChooser,
hmidiChooser, vmidiChooser,
uiDistort, uiChorus, uiFlanger, uiPhaser, uiDelay, uiEcho, uiFilter, uiReverb,
uiGain, uiCompress, uiWhite, uiPink, uiFx, uiDry,
uiSig, uiMix, uiMidi,
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 qualified Data.Colour.SRGB as C
import Csound.Typed
import Csound.Typed.Gui
import Csound.Control.Midi
import Csound.Control.Evt
import Csound.Control.Instr
import Csound.Control.Gui
import Csound.Typed.Opcode hiding (space)
import Csound.SigSpace
import Csound.Air.Wave
import Csound.Air.Fx
import Csound.Air.Patch
import Csound.Air.Misc
mixer :: (Sigs a) => [(String, SE a)] -> Source a
mixer = genMixer (ver, hor)
hmixer :: (Sigs a) => [(String, SE a)] -> Source a
hmixer = genMixer (hor, ver)
genMixer :: (Sigs a) => ([Gui] -> Gui, [Gui] -> Gui) -> [(String, SE a)] -> Source a
genMixer (parentGui, childGui) as = source $ do
gTags <- mapM (unDisplay . box) names
(gs, vols) <- fmap unzip $ mapM (const $ unSource $ defSlider "") names
(gMutes, mutes) <- fmap unzip $ mapM (const $ unSource $ toggleSig "" False) names
gMasterTag <- unDisplay $ box "master"
(gMaster, masterVol) <- unSource $ defSlider ""
(gMasterMute, masterMute) <- unSource $ 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 <- fmap (mul masterMuteVol . mean) $ zipWithM (\v ain -> fmap (mul v) ain) 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
fxBox :: forall a. Sigs a => String -> ([Sig] -> Fx a) -> Bool -> [(String, Double)] -> Source (Fx a)
fxBox name fx onOff args = source $ do
(gOff0, off) <- unSource $ toggleSig name onOff
let gOff = setFontSize 25 gOff0
offRef <- newGlobalRef (0 :: Sig)
writeRef offRef off
let (names, initVals) = unzip args
(gs, as) <- fmap unzip $ mapM (\(name, initVal) -> unSource $ slider name (linSpan 0 1) initVal) $ zip names initVals
let f x = do
ref <- newRef (0 :: a)
goff <- readRef offRef
writeRef ref x
when1 (goff ==* 1) $ do
x2 <- readRef ref
writeRef ref =<< fx as x2
res <- readRef 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)
uiBox :: (Sigs a) => String -> Source (Fx a) -> Bool -> Source (Fx a)
uiBox name fx onOff = mapGuiSource (setBorder UpBoxBorder) $ vlift2' uiOnOffSize uiBoxSize go off fx
where
off = mapGuiSource (setFontSize 25) $ toggleSig name onOff
go off fx arg = fmap (mul off) $ fx arg
uiOnOffSize = 1.7
uiBoxSize = 8
uiGroupGui :: Gui -> Gui -> Gui
uiGroupGui a b =ver [sca uiOnOffSize a, sca uiBoxSize b]
sourceColor2 :: Color -> Source a -> Source a
sourceColor2 col (Source a) = source $ do
(g, x) <- a
return (setColor2 col g, x)
fxColor :: Color -> Source a -> Source a
fxColor = sourceColor2
fxGroupMS :: ([Gui] -> Gui) -> [Source Fx1] -> Maybe (Source (Sig -> SE Sig2)) -> [Source Fx2] -> Source (Sig -> SE Sig2)
fxGroupMS guiGroup as bridge bs = Source $ do
(gsA, fA) <- getChain as
(gsB, fB) <- getChain bs
case bridge of
Nothing -> return $ (guiGroup $ gsA ++ gsB, fA >=> fB . fromMono)
Just widget -> do
(gBridge, fBridge) <- unSource widget
return $ (guiGroup $ gsA ++ gBridge : gsB, fA >=> fBridge >=> fB)
where
getChain xs = do
(gs, fs) <- fmap unzip $ sequence $ fmap unSource xs
return (gs, foldl (\a b -> a >=> b) return fs)
fxGroup :: ([Gui] -> Gui) -> [Source (Fx a)] -> Source (Fx a)
fxGroup guiGroup as = Source $ do
(gs, fs) <- fmap unzip $ sequence $ fmap unSource as
return (guiGroup gs, foldl (\a b -> a >=> b) return fs)
fxSca :: Double -> Source (Fx a) -> Source (Fx a)
fxSca d a = fxGroup (\xs -> sca d $ head xs) [a]
fxHor :: [Source (Fx a)] -> Source (Fx a)
fxHor = fxGroup hor
fxVer :: [Source (Fx a)] -> Source (Fx a)
fxVer = fxGroup ver
fxGrid :: Int -> [Source (Fx a)] -> Source (Fx a)
fxGrid columnsSize fxs = fxGroup (grid columnsSize) fxs
fxHorMS :: [Source Fx1] -> Maybe (Source (Sig -> SE Sig2)) -> [Source Fx2] -> Source (Sig -> SE Sig2)
fxHorMS = fxGroupMS hor
fxVerMS :: [Source Fx1] -> Maybe (Source (Sig -> SE Sig2)) -> [Source Fx2] -> Source (Sig -> SE Sig2)
fxVerMS = fxGroupMS ver
fxGridMS :: Int -> [Source Fx1] -> Maybe (Source (Sig -> SE Sig2)) -> [Source Fx2] -> Source (Sig -> SE Sig2)
fxGridMS columnSize = fxGroupMS (grid columnSize)
fxApply :: Source (a -> SE b) -> a -> Source b
fxApply fx a = joinSource $ lift1 (\f -> f a) fx
fxMap :: Fx a -> Source (Fx a) -> Source (Fx a)
fxMap f = mapSource (>=> f)
atFx :: Source (Fx a) -> Patch a -> Source (Patch a)
atFx uiFx patch = lift1 (\fx -> addPostFx 1 fx patch) uiFx
uiDistort :: Sigs a => Bool -> Double -> Double -> Double -> Source (Fx a)
uiDistort isOn level drive tone = mapSource bindSig $ sourceColor2 C.red $ fxBox "Distortion" (\[level, drive, tone] -> return . fxDistort level drive tone) isOn
[("level", level), ("drive", drive), ("tone", tone)]
uiChorus :: Bool -> Double -> Double -> Double -> Double -> Source Fx2
uiChorus isOn mix rate depth width = sourceColor2 C.coral $ fxBox "Chorus" (\[mix, rate, depth, width] -> return . stChorus2 mix rate depth width) isOn
[("mix",mix), ("rate",rate), ("depth",depth), ("width",width)]
uiDry :: (Sigs a) => Source (Fx a)
uiDry = fxBox "Thru" (\[] -> return) True []
uiFlanger :: Sigs a => Bool -> Double -> Double -> Double -> Double -> Source (Fx a)
uiFlanger isOn rate depth delay fback = mapSource bindSig $ sourceColor2 C.indigo $ fxBox "Flanger" (\[fback, rate, depth, delay] -> return . fxFlanger fback rate depth delay) isOn
[("rate",rate), ("depth",depth), ("delay",delay), ("fback", fback)]
uiPhaser :: Sigs a => Bool -> Double -> Double -> Double -> Double -> Source (Fx a)
uiPhaser isOn rate depth freq fback = mapSource bindSig $ sourceColor2 C.orange $ fxBox "Phaser" (\[rate, depth, frequency, feedback] -> return . fxPhaser rate depth frequency feedback) isOn
[("rate",rate), ("depth",depth), ("freq", freq), ("fback", fback)]
uiDelay :: Sigs a => Bool -> Double -> Double -> Double -> Double -> Source (Fx a)
uiDelay isOn mix fback time tone = mapSource bindSig $ sourceColor2 C.dodgerblue $ fxBox "Delay" (\[mix, fback, time, tone] -> return . analogDelay mix fback time tone) isOn
[("mix",mix), ("fback",fback), ("time",time), ("tone",tone)]
uiEcho :: Sigs a => Bool -> D -> Double -> Double -> Source (Fx a)
uiEcho isOn maxDelTime time fback = mapSource bindSig $ sourceColor2 C.deepskyblue $ fxBox "Echo" (\[time, fback] -> return . fxEcho maxDelTime time fback) isOn
[("time", time), ("fback", fback)]
uiFilter :: Sigs a => Bool -> Double -> Double -> Double -> Source (Fx a)
uiFilter isOn lpf hpf gain = mapSource bindSig $ fxBox "Filter" (\[lpf, hpf, gain] -> return . fxFilter lpf hpf gain) isOn
[("lpf",lpf), ("hpf",hpf), ("gain",gain)]
uiReverb :: Bool -> Double -> Double -> Source Fx2
uiReverb isOn mix depth = sourceColor2 C.forestgreen $ fxBox "Reverb" (\[mix, depth] asig -> return $ cfd mix asig (rever2 depth asig)) isOn
[("mix", mix), ("depth", depth)]
uiGain :: Sigs a => Double -> Source (Fx a)
uiGain gain = mapSource bindSig $ sourceColor2 C.black $ fxBox "Gain" (\[vol] -> return . fxGain vol) True [("gain", gain)]
uiWhite :: Sigs a => Bool -> Double -> Double -> Source (Fx a)
uiWhite isOn freq depth = mapSource bindSig $ sourceColor2 C.dimgray $ fxBox "White" (\[freq, depth] -> fxWhite freq depth) isOn
[("freq", freq), ("depth", depth)]
uiPink :: Sigs a => Bool -> Double -> Double -> Source (Fx a)
uiPink isOn freq depth = mapSource bindSig $ sourceColor2 C.deeppink $ fxBox "Pink" (\[freq, depth] -> fxPink freq depth) isOn
[("freq", freq), ("depth", depth)]
uiFx :: Sigs a => String -> Fx a -> Bool -> Source (Fx a)
uiFx name f isOn = fxBox name (\[] -> f) isOn []
uiMidi :: (Sigs a) => [(String, Msg -> SE a)] -> Int -> Source (Fx a)
uiMidi xs initVal = sourceColor2 C.forestgreen $ uiBox "Midi" fx True
where fx = lift1 (\aout arg -> return $ aout + arg) $ vmidiChooser xs initVal
uiSig :: (Sigs a) => String -> Bool -> Source a -> Source (Fx a)
uiSig name onOff widget = source $ do
(gs, asig) <- unSource widget
(gOff0, off) <- unSource $ 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 :: (Sigs a) => Bool -> [(String, SE a)] -> Source (Fx a)
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) <- unSource $ knob "A" (linSpan expEps $ attBound b) (attInit inits)
(gdec, dec) <- unSource $ knob "D" (linSpan expEps $ decBound b) (decInit inits)
(gsus, sus) <- unSource $ knob "S" (linSpan expEps 1) (susInit inits)
(grel, rel) <- unSource $ 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
genMidiChooser chooser xs initVal = joinSource $ lift1 midi $ chooser xs initVal
hmidiChooser :: Sigs a => [(String, Msg -> SE a)] -> Int -> Source a
hmidiChooser = genMidiChooser hinstrChooser
vmidiChooser :: Sigs a => [(String, Msg -> SE a)] -> Int -> Source a
vmidiChooser = genMidiChooser vinstrChooser
hinstrChooser :: (Sigs b) => [(String, a -> SE b)] -> Int -> Source (a -> SE b)
hinstrChooser = genInstrChooser hradioSig
vinstrChooser :: (Sigs b) => [(String, a -> SE b)] -> Int -> Source (a -> SE b)
vinstrChooser = genInstrChooser vradioSig
genInstrChooser :: (Sigs b) => ([String] -> Int -> Source Sig) -> [(String, a -> SE b)] -> Int -> Source (a -> SE b)
genInstrChooser widget xs initVal = lift1 (routeInstr instrs) $ widget names initVal
where (names, instrs) = unzip xs
routeInstr :: Sigs b => [a -> SE b] -> Sig -> (a -> SE b)
routeInstr instrs instrId arg = fmap sum $ mapM ( $ arg) $ zipWith (\n instr -> playWhen (sig (int n) ==* instrId) instr) [0 ..] instrs
uiCompress :: Sigs a => Double -> Double -> Double -> Double -> Double -> Double -> Double -> Source (Fx a)
uiCompress initThresh initLoknee initHiknee initRatio initAtt initRel initGain = mapSource bindSig $ paintTo orange $ fxBox "Compress" fx True
[("thresh", initThresh), ("loknee", initLoknee), ("hiknee", initHiknee), ("ratio", initRatio), ("att", initAtt), ("rel", initRel), ("gain", initGain)]
where
fx [thresh, loknee, hiknee, ratio, att, rel, gain] = return . fxCompress thresh (loknee, hiknee) ratio (att, rel) gain
paintTo = fxColor . C.sRGB24read
orange = "#FF851B"
fromMonoFx :: Sigs a => (Sig -> Sig) -> Fx a
fromMonoFx f = \asig2 -> bindSig (return . f) asig2