{-#Language BangPatterns, TupleSections, FlexibleContexts #-}
module Csound.Control.Evt(
Evt(..), Bam, Tick,
boolToEvt, evtToBool, evtToTrig, sigToEvt, evtToSig, stepper,
filterE, filterSE, accumSE, accumE, filterAccumE, filterAccumSE,
Snap, snapshot, readSnap, snaps, snaps2, sync, syncBpm,
metro, gaussTrig, dust, metroSig, dustSig, dustSig2, impulseE, changedE, triggerE, loadbang, impulse, metroE,
devt, eventList,
cycleE, iterateE, repeatE, appendE, mappendE, partitionE,
takeE, dropE, takeWhileE, dropWhileE,
splitToggle, toTog, toTog1,
Rnds,
oneOf, freqOf, freqAccum,
randDs, randList, randInts, randSkip, randSkipBy,
range, listAt,
every, masked
) where
import Data.Monoid
import Data.Default
import Data.Boolean
import Data.Tuple
import Temporal.Media
import Csound.Typed hiding (evtToBool)
import Csound.Typed.Opcode hiding (metro, dust, dust2)
import qualified Csound.Typed.Opcode as O(metro, dust, dust2)
import Csound.Types(atArg)
type Tick = Evt Unit
evtToSig :: D -> (Evt D) -> Sig
evtToSig initVal evts = retrigs (return . sig) $ fmap return $ devt initVal loadbang <> evts
evtToBool :: Evt a -> BoolSig
evtToBool a = ( ==* 1) $ changed $ return $ evtToSig 0 $ cycleE [1, 0] a
evtToTrig :: Evt a -> Sig
evtToTrig = (\b -> ifB b 1 0) . evtToBool
devt :: D -> Evt a -> Evt D
devt d = fmap (const d)
{-# DEPRECATED metroE "Use metro instead" #-}
metroE :: Sig -> Evt Unit
metroE = sigToEvt . O.metro
metro :: Sig -> Evt Unit
metro = sigToEvt . O.metro
metroSig :: Sig -> Sig
metroSig = O.metro
gaussTrig :: Sig -> Sig -> Tick
gaussTrig afreq adev = Evt $ \bam -> do
on <- gausstrig 1 (afreq * sig getBlockSize) adev
when1 (on >* 0.5) $ bam unit
dust :: Sig -> Tick
dust freq = Evt $ \bam -> do
on <- O.dust 1 (freq * sig getBlockSize)
when1 (on >* 0.5) $ bam unit
dustSig :: Sig -> SE Sig
dustSig freq = O.dust 1 (freq * sig getBlockSize)
dustSig2 :: Sig -> SE Sig
dustSig2 freq = O.dust2 1 (freq * sig getBlockSize)
loadbang :: Evt Unit
loadbang = impulseE 0
impulse :: D -> Sig
impulse dt = downsamp (mpulse (sig $ getBlockSize) 0 `withD` dt) `withD` getBlockSize
impulseE :: D -> Evt Unit
impulseE = sigToEvt . impulse
eventList :: [(D, D, a)] -> Evt (Sco a)
eventList es = fmap (const $ har $ fmap singleEvent es) loadbang
where singleEvent (start, duration, content) = del start $ str duration $ temp content
changedE :: [Sig] -> Evt Unit
changedE = sigToEvt . changed
triggerE :: Sig -> Sig -> Sig -> Evt Unit
triggerE a1 a2 a3 = sigToEvt $ trigger a1 a2 a3
syncBpm :: (Default a, Tuple a) => Sig -> Evt a -> Evt a
syncBpm dt = sync (dt / 60)
partitionE :: (a -> BoolD) -> Evt a -> (Evt a, Evt a)
partitionE p evts = (a, b)
where
a = filterE p evts
b = filterE (notB . p) evts
splitToggle :: Evt D -> (Evt D, Evt D)
splitToggle = swap . partitionE (==* 0)
snaps2 :: Sig2 -> Evt (D, D)
snaps2 (x, y) = snapshot const (x, y) trigger
where trigger = sigToEvt $ changed [x, y]
cycleE :: (Tuple a, Arg a) => [a] -> Evt b -> Evt a
cycleE vals evts = listAt vals $ range (0, int $ length vals) evts
listAt :: (Tuple a, Arg a) => [a] -> Evt D -> Evt a
listAt vals evt
| null vals = mempty
| otherwise = fmap (atArg vals) $ filterE within evt
where
within x = (x >=* 0) &&* (x `lessThan` len)
len = int $ length vals
range :: (D, D) -> Evt b -> Evt D
range (xMin, xMax) = iterateE xMin $ \x -> ifB ((x + 1) >=* xMax) xMin (x + 1)
randInts :: (D, D) -> Evt b -> Evt D
randInts (xMin, xMax) = accumSE (0 :: D) $ const $ \s -> fmap (, s) $ getRnd
where getRnd = fmap (int' . readSnap) $ random (sig $ int' xMin) (sig $ int' xMax)
randDs :: Evt b -> Evt D
randDs = accumSE (0 :: D) $ const $ \s -> fmap (, s) $ fmap readSnap $ random (0::D) 1
randList :: Int -> Evt b -> Evt [D]
randList n = accumSE (0 :: D) $ const $ \s -> fmap (, s) $
sequence $ replicate n $ fmap readSnap $ random (0::D) 1
randSkip :: Sig -> Evt a -> Evt a
randSkip d = filterSE (const $ fmap (<=* ir d) $ random (0::D) 1)
randSkipBy :: (a -> Sig) -> Evt a -> Evt a
randSkipBy d = filterSE (\x -> fmap (<=* ir (d x)) $ random (0::D) 1)
iterateE :: (Tuple a) => a -> (a -> a) -> Evt b -> Evt a
iterateE s0 f = accumE s0 (const phi)
where phi s = (s, f s)
repeatE :: Tuple a => a -> Evt b -> Evt a
repeatE a = fmap (const a)
appendE :: Tuple a => a -> (a -> a -> a) -> Evt a -> Evt a
appendE empty append = accumE empty phi
where phi a s = let s1 = s `append` a in (s1, s1)
mappendE :: (Monoid a, Tuple a) => Evt a -> Evt a
mappendE = appendE mempty mappend
oneOf :: (Tuple a, Arg a) => [a] -> Evt b -> Evt a
oneOf vals evt = listAt vals $ randInts (0, int $ length vals) evt
type Rnds a = [(Sig, a)]
freqOf :: (Tuple a, Arg a) => Rnds a -> Evt b -> Evt a
freqOf rnds evt = fmap (takeByWeight accs vals) $ randDs evt
where
accs = accumWeightList $ fmap fst rnds
vals = fmap snd rnds
takeByWeight :: (Tuple a, Arg a) => [Sig] -> [a] -> D -> a
takeByWeight accumWeights vals at =
guardedArg (zipWith (\w val -> (at `lessThan` ir w, val)) accumWeights vals) (last vals)
accumWeightList :: Num a => [a] -> [a]
accumWeightList = go 0
where go !s xs = case xs of
[] -> []
a:as -> a + s : go (a + s) as
freqAccum :: (Tuple s, Tuple (b, s), Arg (b, s))
=> s -> (a -> s -> Rnds (b, s)) -> Evt a -> Evt b
freqAccum s0 f = accumSE s0 $ \a s ->
let rnds = f a s
accs = accumWeightList $ fmap fst rnds
vals = fmap snd rnds
in fmap (takeByWeight accs vals . readSnap) $ random (0 :: D) 1
every :: (Tuple a, Arg a) => Int -> [Int] -> Evt a -> Evt a
every empties beats = masked mask
where mask = (fmap (\x -> if x then 1 else 0) $ (replicate empties False) ++ patternToMask beats)
masked :: (Tuple a, Arg a) => [D] -> Evt a -> Evt a
masked ms = filterAccumE 0 $ \a s ->
let n = int $ length ms
s1 = ifB (s + 1 `lessThan` n) (s + 1) 0
in (atArg ms s ==* 1, a, s1)
patternToMask :: [Int] -> [Bool]
patternToMask xs = case xs of
[] -> []
a:as -> single a ++ patternToMask as
where single n
| n <= 0 = []
| otherwise = True : replicate (n - 1) False
togGen :: D -> Tick -> Evt D
togGen n = accumE n (\_ s -> let v = (mod' (s + 1) 2) in (v, v))
toTog :: Tick -> Evt D
toTog = togGen 1
toTog1 :: Tick -> Evt D
toTog1 = togGen 0
mkRow :: Evt a -> Evt (a, D)
mkRow = accumE (0 :: D) (\a s -> ((a, s), s + 1) )
filterRow :: (D -> BoolD) -> Evt a -> Evt a
filterRow p = fmap fst . filterE (p . snd) . mkRow
takeE :: Int -> Evt a -> Evt a
takeE n = filterRow ( `lessThan` int n)
dropE :: Int -> Evt a -> Evt a
dropE n = filterRow ( >=* int n)
takeWhileE :: (a -> BoolD) -> Evt a -> Evt a
takeWhileE p = fmap fst . filterE snd . accumE (1 :: D) (\a s -> let s1 = s ==* 1 &&* p a in ((a, s1), ifB s1 1 0))
dropWhileE :: (a -> BoolD) -> Evt a -> Evt a
dropWhileE p = fmap fst . filterE (notB . snd) . accumE (1 :: D) (\a s -> let s1 = s ==* 1 &&* p a in ((a, s1), ifB s1 1 0))