diff --git a/csound-sampler.cabal b/csound-sampler.cabal --- a/csound-sampler.cabal +++ b/csound-sampler.cabal @@ -1,5 +1,5 @@ name: csound-sampler -version: 0.0.2 +version: 0.0.3 license: BSD3 license-file: LICENSE author: Anton Kholomiov @@ -28,5 +28,8 @@ build-depends: base >= 4, base < 5, transformers >= 0.3, csound-expression >= 4.1.0 exposed-modules: Csound.Sam + Csound.Sam.Core + Csound.Sam.Ui Csound.Sam.Chord + diff --git a/src/Csound/Sam.hs b/src/Csound/Sam.hs --- a/src/Csound/Sam.hs +++ b/src/Csound/Sam.hs @@ -21,7 +21,10 @@ arpUp, arpDown, arpOneOf, arpFreqOf, arpUp1, arpDown1, arpOneOf1, arpFreqOf1, -- * Misc patterns - wall, forAirports, genForAirports + wall, forAirports, genForAirports, + + -- UIs + module Csound.Sam.Ui ) where import Control.Monad.Trans.Class @@ -29,76 +32,8 @@ import Control.Monad.Trans.Reader import Csound.Base - --- | The main type. A stereo sample. -type Sam = Sample Sig2 - -data Dur = Dur D | InfDur - --- | The Beats Per Minute measure (BPM). Almost all values are measured in BPMs. -type Bpm = D - --- | The generic type for samples. -newtype Sample a = Sam { unSam :: ReaderT Bpm SE (S a) - } deriving (Functor) - -instance Applicative Sample where - pure = Sam . pure . pure - (Sam rf) <*> (Sam ra) = Sam $ liftA2 (<*>) rf ra - -data S a = S - { samSig :: a - , samDur :: Dur - } deriving (Functor) - -instance Applicative S where - pure a = S a InfDur - (S f df) <*> (S a da) = S (f a) $ case (df, da) of - (Dur durF, Dur durA) -> Dur $ maxB durF durA - _ -> InfDur - -instance Num a => Num (Sample a) where - (+) = liftA2 (+) - (*) = liftA2 (*) - (-) = liftA2 (-) - negate = fmap negate - abs = fmap abs - signum = fmap signum - fromInteger = pure . fromInteger - -instance Fractional a => Fractional (Sample a) where - recip = fmap recip - fromRational = pure . fromRational - -instance SigSpace a => SigSpace (Sample a) where - mapSig f = fmap (mapSig f) - -instance RenderCsd Sam where - renderCsdBy opt sample = renderCsdBy opt (runSam (120 * 4) sample) - --- | Hides the effects inside sample. -liftSam :: Sample (SE a) -> Sample a -liftSam (Sam ra) = Sam $ do - a <- ra - lift $ fmap (\x -> a{ samSig = x}) $ samSig a - --- | Transforms the sample with BPM. -mapBpm :: (Bpm -> Sig2 -> Sig2) -> Sam -> Sam -mapBpm f (Sam ra) = Sam $ do - bpm <- ask - a <- ra - return $ a { samSig = f bpm $ samSig a } - --- | Lifts bind on stereo signals to samples. -bindSam :: (Sig2 -> SE Sig2) -> Sam -> Sam -bindSam f = liftSam . fmap f - --- | Lifts bind on stereo signals to samples with BPM. -bindBpm :: (Bpm -> Sig2 -> SE Sig2) -> Sam -> Sam -bindBpm f (Sam ra) = Sam $ do - bpm <- ask - a <- ra - lift $ fmap (\x -> a{ samSig = x}) $ f bpm $ samSig a +import Csound.Sam.Core +import Csound.Sam.Ui -- | Constructs sample from mono signal infSig1 :: Sig -> Sam @@ -236,9 +171,6 @@ toSecSig :: Bpm -> Sig -> Sig toSecSig bpm a = a * 60 / sig bpm - -runSam :: Bpm -> Sam -> SE Sig2 -runSam bpm x = fmap samSig $ runReaderT (unSam x) bpm addDur :: D -> Dur -> Dur addDur d x = case x of diff --git a/src/Csound/Sam/Core.hs b/src/Csound/Sam/Core.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Sam/Core.hs @@ -0,0 +1,87 @@ +-- | The core types/ They are not imported by default. +{-# Language DeriveFunctor, TypeSynonymInstances, FlexibleInstances #-} +module Csound.Sam.Core ( + Sam, runSam, Sample(..), S(..), Dur(..), Bpm, + liftSam, mapBpm, bindSam, bindBpm +) where + +import Control.Applicative +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class + +import Csound.Base + +-- | The main type. A stereo sample. +type Sam = Sample Sig2 + +instance RenderCsd Sam where + renderCsdBy opt sample = renderCsdBy opt (runSam (120 * 4) sample) + +runSam :: Bpm -> Sam -> SE Sig2 +runSam bpm x = fmap samSig $ runReaderT (unSam x) bpm + +data Dur = Dur D | InfDur + +-- | The Beats Per Minute measure (BPM). Almost all values are measured in BPMs. +type Bpm = D + +-- | The generic type for samples. +newtype Sample a = Sam { unSam :: ReaderT Bpm SE (S a) + } deriving (Functor) + +instance Applicative Sample where + pure = Sam . pure . pure + (Sam rf) <*> (Sam ra) = Sam $ liftA2 (<*>) rf ra + +data S a = S + { samSig :: a + , samDur :: Dur + } deriving (Functor) + +instance Applicative S where + pure a = S a InfDur + (S f df) <*> (S a da) = S (f a) $ case (df, da) of + (Dur durF, Dur durA) -> Dur $ maxB durF durA + _ -> InfDur + +instance Num a => Num (Sample a) where + (+) = liftA2 (+) + (*) = liftA2 (*) + (-) = liftA2 (-) + negate = fmap negate + abs = fmap abs + signum = fmap signum + fromInteger = pure . fromInteger + +instance Fractional a => Fractional (Sample a) where + recip = fmap recip + fromRational = pure . fromRational + +instance SigSpace a => SigSpace (Sample a) where + mapSig f = fmap (mapSig f) + +-- Lifters + +-- | Hides the effects inside sample. +liftSam :: Sample (SE a) -> Sample a +liftSam (Sam ra) = Sam $ do + a <- ra + lift $ fmap (\x -> a{ samSig = x}) $ samSig a + +-- | Transforms the sample with BPM. +mapBpm :: (Bpm -> Sig2 -> Sig2) -> Sam -> Sam +mapBpm f (Sam ra) = Sam $ do + bpm <- ask + a <- ra + return $ a { samSig = f bpm $ samSig a } + +-- | Lifts bind on stereo signals to samples. +bindSam :: (Sig2 -> SE Sig2) -> Sam -> Sam +bindSam f = liftSam . fmap f + +-- | Lifts bind on stereo signals to samples with BPM. +bindBpm :: (Bpm -> Sig2 -> SE Sig2) -> Sam -> Sam +bindBpm f (Sam ra) = Sam $ do + bpm <- ask + a <- ra + lift $ fmap (\x -> a{ samSig = x}) $ f bpm $ samSig a diff --git a/src/Csound/Sam/Ui.hs b/src/Csound/Sam/Ui.hs new file mode 100644 --- /dev/null +++ b/src/Csound/Sam/Ui.hs @@ -0,0 +1,266 @@ +-- | Graphical widgets for playing samples +module Csound.Sam.Ui( + freeSim, hfreeSim, freeSimWith, hfreeSimWith, + freeTog, hfreeTog, + sim, hsim, simWith, hsimWith, + tog, htog, + live, liveEf, + mixSam, uiSam, addGain +) where + +import Data.List(transpose) +import Control.Monad +import Control.Monad.Trans.Reader + +import Csound.Base +import Csound.Sam.Core + +groupToggles :: ([Sig2] -> Sig2) -> [Sam] -> [Evt D] -> Sam +groupToggles group sams ts = Sam $ reader $ \r -> + S (group $ zipWith (\sam t -> schedToggle (runSam r sam) t) sams ts) InfDur + +-- | A widget for playing several samples at the same time (aka `sim`ultaneously). +-- The prefix `free` means no syncronization. the samples start to play when the button is pressed. +freeSim :: [(String, Sam)] -> Source Sam +freeSim = genFreeSim ver + +-- | It's just like the function @freeSim@ but the visual representation is horizontal. +-- That's why there is a prefix @h@. +hfreeSim :: [(String, Sam)] -> Source Sam +hfreeSim = genFreeSim hor + +-- | It's just like the function `freeSim` but the user can +-- activate some samples right in the code. If the third +-- element is @True@ the sample is played. +freeSimWith :: [(String, Sam, Bool)] -> Source Sam +freeSimWith = genFreeSimInits ver + +-- | It's just like the function `freeSimWith` but the visual representation is horizontal. +-- That's why there is a prefix @h@. +hfreeSimWith :: [(String, Sam, Bool)] -> Source Sam +hfreeSimWith = genFreeSimInits hor + +genFreeSim :: ([Gui] -> Gui) -> [(String, Sam)] -> Source Sam +genFreeSim gcat as = genFreeSimInits gcat $ fmap (\(a, b) -> (a, b, False)) as + +genFreeSimInits :: ([Gui] -> Gui) -> [(String, Sam, Bool)] -> Source Sam +genFreeSimInits gcat as = source $ do + (guis, ts) <- fmap unzip $ zipWithM toggle names initVals + let res = groupToggles mean sams ts + return (gcat guis, res) + where + (names, sams, initVals) = unzip3 as + +-- | The widget to toggle between several samples (aka `tog`gle). +-- The prefix `free` means no syncronization. the samples start to play when the button is pressed. +freeTog :: [(String, Sam)] -> Source Sam +freeTog = genFreeTog ver + +-- | It's just like the function @freeTog@ but the visual representation is horizontal. +hfreeTog :: [(String, Sam)] -> Source Sam +hfreeTog = genFreeTog hor + +genFreeTog :: ([Gui] -> Gui) -> [(String, Sam)] -> Source Sam +genFreeTog gcat as = source $ do + (guis, writes, reads) <- fmap unzip3 $ mapM (flip setToggleSig False) names + curRef <- newGlobalSERef (0 :: Sig) + current <- readSERef curRef + zipWithM_ (\w i -> w $ ifB (current ==* i) 1 0) writes ids + zipWithM_ (\r i -> runEvt (snaps r) $ \x -> do + when1 (sig x ==* 0 &&* current ==* i) $ do + writeSERef curRef 0 + when1 (sig x ==* 1) $ do + writeSERef curRef i + ) reads ids + + let res = groupToggles sum sams $ fmap (snaps . (\i -> ifB (current ==* i) 1 0)) ids + return (gcat guis, res) + where + (names, sams) = unzip as + ids = fmap (sig . int) [1 .. length as] + + +genSim :: ([Gui] -> Gui) -> Int -> [(String, Sam)] -> Source Sam +genSim gcat numBeats as = genSimInits gcat numBeats $ fmap (\(a, b) -> (a, b, False)) as + +genSimInits :: ([Gui] -> Gui) -> Int -> [(String, Sam, Bool)] -> Source Sam +genSimInits gcat numBeats as = source $ do + (guis, writes, reads) <- fmap unzip3 $ zipWithM setToggleSig names initVals + curRefs <- mapM (const $ newGlobalSERef (0 :: Sig)) ids + currents <- mapM readSERef curRefs + zipWithM_ (\w val -> w val) writes currents + let mkReaders bpm = zipWithM_ (\r ref -> runEvt (syncBpm (bpm / int numBeats) $ snaps r) $ \x -> do + writeSERef ref (sig x) + ) reads curRefs + let res = bindBpm (\bpm x -> mkReaders bpm >> return x) $ groupToggles mean sams $ fmap snaps currents + return (gcat guis, res) + where + (names, sams, initVals) = unzip3 as + ids = fmap (sig . int) [1 .. length as] + +-- | A widget for playing several samples at the same time (aka `sim`ultaneously). +-- The first argument is about syncronization. +-- +-- > sim n nameAndSamples +-- +-- The samples are started only on every n'th beat. +-- The tempo is specified with rendering the sample (see the function @runSam@). +sim :: Int -> [(String, Sam)] -> Source Sam +sim = genSim ver + +-- | It's just like the function @sim@ but the visual representation is horizontal. +-- That's why there is a prefix @h@. +hsim :: Int -> [(String, Sam)] -> Source Sam +hsim = genSim hor + + +-- | It's just like the function `sim` but the user can +-- activate some samples right in the code. If the third +-- element is @True@ the sample is played. +simWith :: Int -> [(String, Sam, Bool)] -> Source Sam +simWith = genSimInits ver + +-- | It's just like the function `hsimWith` but the visual representation is horizontal. +-- That's why there is a prefix @h@. +hsimWith :: Int -> [(String, Sam, Bool)] -> Source Sam +hsimWith = genSimInits hor + + +genTog :: ([Gui] -> Gui) -> Int -> [(String, Sam)] -> Source Sam +genTog gcat numBeats as = fmap (\(g, x) -> (g, fst x)) $ genTogWithRef gcat numBeats as + +genTogWithRef :: ([Gui] -> Gui) -> Int -> [(String, Sam)] -> Source (Sam, SERef Sig) +genTogWithRef gcat numBeats as = source $ do + (guis, writes, reads) <- fmap unzip3 $ mapM (flip setToggleSig False) names + curRef <- newGlobalSERef (0 :: Sig) + current <- readSERef curRef + zipWithM_ (\w i -> w $ ifB (current ==* i) 1 0) writes ids + let mkReaders bpm = zipWithM_ (\r i -> runEvt (syncBpm (bpm / int numBeats) $ snaps r) $ \x -> do + when1 (sig x ==* 0 &&* current ==* i) $ do + writeSERef curRef 0 + when1 (sig x ==* 1) $ do + writeSERef curRef i + ) reads ids + + let res = bindBpm (\bpm x -> mkReaders bpm >> return x) $ groupToggles sum sams $ fmap (snaps . (\i -> ifB (current ==* i) 1 0)) ids + return (gcat guis, (res, curRef)) + where + (names, sams) = unzip as + ids = fmap (sig . int) [1 .. length as] + +-- | A widget to toggle playing of several samples. The switch +-- of the playing is synchronized with each n'th beat where +-- n is the first argument of the function. +tog :: Int -> [(String, Sam)] -> Source Sam +tog = genTog ver + +-- | It's just like the function @tog@ but the visual representation is horizontal. +-- That's why there is a prefix @h@. +htog :: Int -> [(String, Sam)] -> Source Sam +htog = genTog hor + +-- | The widget resembles the Ableton Live session view. +-- We create a matrix of samples. we can toggle the samples in +-- each row and we can start playing the whole row of samples. +-- +-- > live n groupNames samples +-- +-- The first argument is for synchroization. we can start samples +-- only on every n'th beat. The second argument gives names to the columns. +-- the length of the list is the number of columns. +-- the column represents samples that belong to the same group. +-- The third argument is a list of samples. It represents the matrix of samples +-- in row-wise fashion. +live :: Int -> [String] -> [Sam] -> Source Sam +live numBeats names sams = source $ do + (gVols, vols) <- fmap unzip $ mapM defSlider $ replicate n "vol" + (gs, xs) <- fmap unzip $ zipWithM (mkLiveRow numBeats) (zip names gVols) rows + let (sigs, refs) = unzip xs + (gMaster, masterVol) <- defSlider "master" + (g, proc) <- mkLiveSceneRow numBeats gMaster ids refs + return $ (hor $ g : gs, bindBpm (\bpm asig -> proc bpm >> return asig) $ mul masterVol $ mean $ zipWith mul vols sigs) + where + rows = transpose $ splitRows n sams + ids = fmap (sig . int) [1 .. length (head rows)] + n = length names + +mkLiveRow :: Int -> (String, Gui) -> [Sam] -> Source (Sam, SERef Sig) +mkLiveRow numBeats (name, gVol) xs = genTogWithRef (\xs -> ver $ xs ++ [gVol]) numBeats (zip (name : repeat "") xs) + +mkLiveSceneRow :: Int -> Gui -> [Sig] -> [SERef Sig] -> SE (Gui, D -> SE ()) +mkLiveSceneRow numBeats gMaster ids refs = do + (guis, writes, reads) <- fmap unzip3 $ mapM (flip setToggleSig False) names + curRef <- newGlobalSERef (0 :: Sig) + current <- readSERef curRef + zipWithM_ (\w i -> w $ ifB (current ==* i) 1 0) writes ids + let mkReaders bpm = zipWithM_ (\r i -> runEvt (syncBpm (bpm / int numBeats) $ snaps r) $ \x -> do + when1 (sig x ==* 0 &&* current ==* i) $ do + writeSERef curRef 0 + mapM_ (flip writeSERef 0) refs + when1 (sig x ==* 1) $ do + writeSERef curRef i + mapM_ (flip writeSERef i) refs + ) reads ids + + return (ver $ guis ++ [gMaster], mkReaders) + where + names = take len $ fmap show [1 ..] + len = length ids + +splitRows :: Int -> [a] -> [[a]] +splitRows n as + | length as < n = [] + | otherwise = take n as : splitRows n (drop n as) + +defSlider :: String -> Source Sig +defSlider tag = slider tag (linSpan 0 1) 0.5 + +-- | It's just like the function @live@ but we can provide the list +-- of effects for each column. The double value specifies the mix +-- between dry and wet signals. +liveEf :: Int -> [String] -> [Sam] -> (Double, FxFun) -> [(Double, FxFun)] -> Source Sam +liveEf numBeats names sams masterEff effs = source $ do + (gVols, vols) <- fmap unzip $ mapM defSlider $ replicate n "vol" + (gEffs, effCtrls) <- fmap unzip $ + mapM (\(tag, initVal) -> slider tag (linSpan 0 1) initVal) $ zip (replicate n "eff") (fmap fst effs) + let gCtrls = zipWith ctrlGui gEffs gVols + (gs, xs) <- fmap unzip $ zipWithM (mkLiveRow numBeats) (zip names gCtrls) rows + let (sigs, refs) = unzip xs + (gMaster, masterVol) <- defSlider "master" + (gMasterEff, masterEffCtrl) <- slider "eff" (linSpan 0 1) (fst masterEff) + (g, proc) <- mkLiveSceneRow numBeats (ctrlGui gMasterEff gMaster) ids refs + return $ (hor $ g : gs, bindBpm (\bpm asig -> proc bpm >> return asig) $ + mul masterVol $ appEff (snd masterEff) masterEffCtrl $ + mean $ zipWith mul vols $ zipWith (uncurry appEff) (zip (fmap snd effs) effCtrls) sigs) + where + rows = transpose $ splitRows n sams + ids = fmap (sig . int) [1 .. length (head rows)] + n = length names + + appEff f depth a = bindSam (\x -> fmap (\y -> y + (mul (1 - depth) x)) $ mul depth $ f x) a + + ctrlGui eff vol = sca 2.5 $ ver [eff, vol] + +-- | It's useful to convert samples to signals an insert +-- them in the widget @mixer@. +mixSam :: String -> Bpm -> Sam -> (String, SE Sig2) +mixSam name bpm sam = (name, runSam bpm sam) + +-- | Creates fx-unit from sampler widget. +-- +-- > uisam name isOn bpm samWidget +uiSam :: String -> Bool -> D -> Source Sam -> Source FxFun +uiSam name onOff bpm sam = uiSig name onOff (joinSource $ mapSource (runSam bpm) sam) + where + joinSource :: Source (SE Sig2) -> Source Sig2 + joinSource a = source $ do + (g, mres) <- a + res <- mres + return (g, res) + +-- | Adds gain slider on top of the widget. +addGain :: SigSpace a => Source a -> Source a +addGain x = source $ do + (g, asig) <- x + (gainGui, gain) <- slider "gain" (linSpan 0 1) 0.5 + return (ver [sca 0.15 gainGui, g], mul gain asig)