{-# 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,
LiveClip(..), ClipParam(..),
liveRow, liveRows,
ambiRow, ambiRowMp3
) where
import Control.Monad
import Data.Bool
import Data.Colour
import Data.Boolean
import Data.Default
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
import Csound.Tab
import qualified Csound.Typed.Plugins as P
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 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 <- 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) <- 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) -> 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 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 = 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) <- widget
return $ (guiGroup $ gsA ++ gBridge : gsB, fA >=> fBridge >=> fB)
where
getChain xs = do
(gs, fs) <- fmap unzip $ sequence xs
return (gs, foldl (\a b -> a >=> b) return fs)
fxGroup :: ([Gui] -> Gui) -> [Source (Fx a)] -> Source (Fx a)
fxGroup guiGroup as = do
(gs, fs) <- fmap unzip $ sequence 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) <- 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 :: (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) <- 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
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
liveRow :: [LiveClip] -> D -> D -> Sig -> Sig
liveRow clips iBpm iBeatDur kUserIndex = P.liveRow iTabSize iTabs iBpm iBeatDur kUserIndex iAuxParams
where
iTabSize = int $ length clips
iTabs = tabList $ fmap (wavLeft . liveClipFile) clips
iAuxParams = getAuxClipParams clips
liveRows :: [LiveClip] -> D -> D -> Sig -> Sig2
liveRows clips iBpm iBeatDur kUserIndex = P.liveRows iTabSize iLeftTabs iRightTabs iBpm iBeatDur kUserIndex iAuxParams
where
iTabSize = int $ length clips
iLeftTabs = tabList $ fmap (wavLeft . liveClipFile) clips
iRightTabs = tabList $ fmap (wavRight . liveClipFile) clips
iAuxParams = getAuxClipParams clips
data LiveClip = LiveClip
{ liveClipFile :: FilePath
, liveClipParam :: ClipParam
}
data ClipParam = ClipParam
{ clipParamSize :: !Int
, clipParamDel :: !Int
, clipParamTail :: !Int
, clipParamNext :: !Int
, clipParamRetrig :: !Bool
, clipParamVol :: !Double
}
instance Default ClipParam where
def = ClipParam
{ clipParamSize = -1
, clipParamDel = 0
, clipParamTail = 0
, clipParamNext = -1
, clipParamRetrig = False
, clipParamVol = 1
}
toClipParam :: ClipParam -> [Double]
toClipParam x =
[ fromIntegral $ clipParamSize x
, fromIntegral $ clipParamDel x
, fromIntegral $ clipParamTail x
, fromIntegral $ clipParamNext x
, bool 0 1 (clipParamRetrig x)
, clipParamVol x]
getAuxClipParams :: [LiveClip] -> Tab
getAuxClipParams xs = doubles $ fillTabToPowerOfTwo $
toClipParam . liveClipParam =<< xs
fillTabToPowerOfTwo :: [Double] -> [Double]
fillTabToPowerOfTwo xs = xs ++ replicate (nextPow - n) 0
where
n = length xs
nextPow
| frac == 0 = n
| otherwise = 2 ^ (integ + 1)
where
(integ, frac) = properFraction $ logBase 2 (fromIntegral n)
ambiRow :: [String] -> Sig -> Sig -> D -> SE Sig2
ambiRow files kSpeed kIndex iFadeTime = do
arr <- newGlobalCtrlArr [int $ length files]
zipWithM_ (\n f -> writeArr arr n $ text f) (fmap (sig . int) [0..]) files
return $ P.ambiRow arr kSpeed kIndex iFadeTime
ambiRowMp3 :: [String] -> Sig -> Sig -> D -> SE Sig2
ambiRowMp3 files kSpeed kIndex iFadeTime = do
arr <- newGlobalCtrlArr [int $ length files]
zipWithM_ (\n f -> writeArr arr n $ text f) (fmap (sig . int) [0..]) files
return $ P.ambiRowMp3 arr kSpeed kIndex iFadeTime