tidal 1.0.7 → 1.0.8
raw patch · 23 files changed
+1239/−680 lines, 23 filesdep +template-haskelldep ~transformers
Dependencies added: template-haskell
Dependency ranges changed: transformers
Files
- CHANGELOG.md +21/−0
- src/Sound/Tidal/Chords.hs +5/−2
- src/Sound/Tidal/Control.hs +23/−23
- src/Sound/Tidal/Core.hs +21/−18
- src/Sound/Tidal/EspGrid.hs +4/−4
- src/Sound/Tidal/MiniTidal.hs +199/−275
- src/Sound/Tidal/MiniTidal/TH.hs +18/−0
- src/Sound/Tidal/MiniTidal/Token.hs +122/−0
- src/Sound/Tidal/Params.hs +61/−2
- src/Sound/Tidal/ParseBP.hs +29/−33
- src/Sound/Tidal/Pattern.hs +56/−61
- src/Sound/Tidal/Scales.hs +30/−5
- src/Sound/Tidal/Simple.hs +2/−2
- src/Sound/Tidal/Tempo.hs +34/−40
- src/Sound/Tidal/UI.hs +168/−157
- src/Sound/Tidal/Utils.hs +3/−3
- src/Sound/Tidal/Version.hs +1/−1
- test/Sound/Tidal/PatternTest.hs +2/−2
- test/Sound/Tidal/ScalesTest.hs +318/−0
- test/Sound/Tidal/UITest.hs +68/−0
- test/Test.hs +2/−0
- tidal.cabal +8/−8
- tidal.el +44/−44
CHANGELOG.md view
@@ -1,5 +1,26 @@ # TidalCycles log of changes ++## 1.0.8 (trying to get back to doing these, +## see also https://tidalcycles.org/index.php/Changes_in_Tidal_1.0.x +## for earlier stuff)++* Add 'to', 'toArg' and 'from' controls for new superdirt routing experiments - @telephon+* Fixes for squeezeJoin (nee unwrap') - @bgold-cosmos+* Simplify `cycleChoose`, it is now properly discrete (one event per cycle) - @yaxu+* The return of `<>`, `infix alias for overlay` - @yaxu+* Fix for `wedge` to allow 0 and 1 as first parameter - @XiNNiW+* Support for new spectral fx - @madskjeldgaard+* Fix for _euclidInv - @dktr0+* `chordList` for listing chords - @XiNNiW+* new function `soak` - @XiNNiW+* tempo fixes - @bgold-cosmos+* miniTidal developments - @dktr0+* potentially more efficient euclidean patternings - @dktr0+* unit tests for euclid - @yaxu+* fix for `sometimesBy` - @yaxu++ ## 0.9.10 (and earlier missing versions from this log) * arpg, a function to arpeggiate
src/Sound/Tidal/Chords.hs view
@@ -110,13 +110,13 @@ ("maj", major), ("minor", minor), ("min", minor),+ ("aug", aug),+ ("dim", dim), ("major7", major7), ("maj7", major7), ("dom7", dom7), ("minor7", minor7), ("min7", minor7),- ("aug", aug),- ("dim", dim), ("dim7", dim7), ("one", one), ("1", one),@@ -181,4 +181,7 @@ chordL :: Num a => Pattern String -> Pattern [a] chordL p = (\name -> fromMaybe [] $ lookup name chordTable) <$> p++chordList :: String+chordList = unwords $ map fst (chordTable :: [(String, [Int])])
src/Sound/Tidal/Control.hs view
@@ -59,13 +59,13 @@ chop = tParam _chop chopArc :: Arc -> Int -> [Arc]-chopArc (Arc s e) n = map (\i -> (Arc (s + (e-s)*(fromIntegral i/fromIntegral n)) (s + (e-s)*((fromIntegral $ i+1)/fromIntegral n)))) [0 .. n-1]+chopArc (Arc s e) n = map (\i -> Arc (s + (e-s)*(fromIntegral i/fromIntegral n)) (s + (e-s)*(fromIntegral (i+1) / fromIntegral n))) [0 .. n-1] _chop :: Int -> ControlPattern -> ControlPattern-_chop n p = withEvents (concatMap chopEvent) p+_chop n = withEvents (concatMap chopEvent) where -- for each part, chopEvent :: Event ControlMap -> [Event ControlMap]- chopEvent (Event w p' v) = map (\a -> chomp v (length $ chopArc w n) a) $ arcs w p'+ chopEvent (Event w p' v) = map (chomp v (length $ chopArc w n)) $ arcs w p' -- cut whole into n bits, and number them arcs w' p' = numberedArcs p' $ chopArc w' n -- each bit is a new whole, with part that's the intersection of old part and new whole@@ -83,8 +83,8 @@ e = fromMaybe 1 $ do v' <- Map.lookup "end" v getF v' d = e-b- b' = (((fromIntegral i)/(fromIntegral n')) * d) + b- e' = (((fromIntegral $ i+1)/(fromIntegral n')) * d) + b+ b' = ((fromIntegral i/fromIntegral n') * d) + b+ e' = ((fromIntegral (i+1) / fromIntegral n') * d) + b {- -- A simpler definition than the above, but this version doesn't chop@@ -125,11 +125,11 @@ striate = tParam _striate _striate :: Int -> ControlPattern -> ControlPattern-_striate n p = fastcat $ map (\i -> offset i) [0 .. n-1]- where offset i = (mergePlayRange ((fromIntegral i / fromIntegral n), (fromIntegral (i+1) / fromIntegral n))) <$> p+_striate n p = fastcat $ map offset [0 .. n-1]+ where offset i = mergePlayRange (fromIntegral i / fromIntegral n, fromIntegral (i+1) / fromIntegral n) <$> p mergePlayRange :: (Double, Double) -> ControlMap -> ControlMap-mergePlayRange (b,e) cm = Map.insert "begin" (VF $ (b*d')+b') $ Map.insert "end" (VF $ (e*d')+b') $ cm+mergePlayRange (b,e) cm = Map.insert "begin" (VF $ (b*d')+b') $ Map.insert "end" (VF $ (e*d')+b') cm where b' = fromMaybe 0 $ Map.lookup "begin" cm >>= getF e' = fromMaybe 1 $ Map.lookup "end" cm >>= getF d' = e' - b'@@ -158,9 +158,9 @@ striate' = striateBy _striateBy :: Int -> Double -> ControlPattern -> ControlPattern-_striateBy n f p = fastcat $ map (\i -> offset (fromIntegral i)) [0 .. n-1]+_striateBy n f p = fastcat $ map (offset . fromIntegral) [0 .. n-1] where offset i = p # P.begin (pure (slot * i) :: Pattern Double) # P.end (pure ((slot * i) + f) :: Pattern Double)- slot = (1 - f) / (fromIntegral n)+ slot = (1 - f) / fromIntegral n @@ -177,7 +177,7 @@ gap = tParam _gap _gap :: Int -> ControlPattern -> ControlPattern -_gap n p = (_fast (toRational n) $ cat [pure 1, silence]) |>| ( _chop n p)+_gap n p = _fast (toRational n) (cat [pure 1, silence]) |>| _chop n p {- | `weave` applies a function smoothly over an array of different patterns. It uses an `OscPattern` to@@ -188,7 +188,7 @@ @ -} weave :: Time -> ControlPattern -> [ControlPattern] -> ControlPattern-weave t p ps = weave' t p (map (\x -> (x #)) ps)+weave t p ps = weave' t p (map (#) ps) {- | `weaveWith` is similar in that it blends functions at the same time at different amounts over a pattern:@@ -199,7 +199,7 @@ -} weaveWith :: Time -> Pattern a -> [Pattern a -> Pattern a] -> Pattern a weaveWith t p fs | l == 0 = silence- | otherwise = _slow t $ stack $ map (\(i, f) -> (fromIntegral i % l) `rotL` (_fast t $ f (_slow t p))) (zip [0 :: Int ..] fs)+ | otherwise = _slow t $ stack $ map (\(i, f) -> (fromIntegral i % l) `rotL` _fast t (f (_slow t p))) (zip [0 :: Int ..] fs) where l = fromIntegral $ length fs weave' :: Time -> Pattern a -> [Pattern a -> Pattern a] -> Pattern a@@ -219,7 +219,7 @@ @ -} interlace :: ControlPattern -> ControlPattern -> ControlPattern-interlace a b = weave 16 (P.shape $ (sine * 0.9)) [a, b]+interlace a b = weave 16 (P.shape (sine * 0.9)) [a, b] {- {- | Just like `striate`, but also loops each sample chunk a number of times specified in the second argument.@@ -249,8 +249,8 @@ slice :: Pattern Int -> Pattern Int -> ControlPattern -> ControlPattern slice pN pI p = P.begin b # P.end e # p- where b = (\i n -> (div' i n)) <$> pI <* pN- e = (\i n -> (div' i n) + (div' 1 n)) <$> pI <* pN+ where b = div' <$> pI <* pN+ e = (\i n -> div' i n + div' 1 n) <$> pI <* pN div' num den = fromIntegral (num `mod` den) / fromIntegral den _slice :: Int -> Int -> ControlPattern -> ControlPattern@@ -305,13 +305,13 @@ -} smash :: Pattern Int -> [Pattern Time] -> ControlPattern -> Pattern ControlMap-smash n xs p = slowcat $ map (\x -> slow x p') xs+smash n xs p = slowcat $ map (`slow` p') xs where p' = striate n p {- | an altenative form to `smash` is `smash'` which will use `chop` instead of `striate`. -} smash' :: Int -> [Pattern Time] -> ControlPattern -> Pattern ControlMap-smash' n xs p = slowcat $ map (\x -> slow x p') xs+smash' n xs p = slowcat $ map (`slow` p') xs where p' = _chop n p @@ -335,9 +335,9 @@ stut = tParam3 _stut _stut :: Integer -> Double -> Rational -> ControlPattern -> ControlPattern-_stut count feedback steptime p = stack (p:(map (\x -> (((x%1)*steptime) `rotR` (p |* P.gain (pure $ scalegain (fromIntegral x))))) [1..(count-1)]))- where scalegain x- = ((+feedback) . (*(1-feedback)) . (/(fromIntegral count)) . ((fromIntegral count)-)) x+_stut count feedback steptime p = stack (p:map (\x -> ((x%1)*steptime) `rotR` (p |* P.gain (pure $ scalegain (fromIntegral x)))) [1..(count-1)])+ where scalegain+ = (+feedback) . (*(1-feedback)) . (/ fromIntegral count) . (fromIntegral count -) {- | Instead of just decreasing volume to produce echoes, @stut'@ allows to apply a function for each step and overlays the result delayed by the given time. @@ -366,7 +366,7 @@ _cX :: (Arc -> Value -> [Event a]) -> [a] -> String -> Pattern a _cX f ds s = Pattern Analog $- \(State a m) -> maybe (map (\d -> (Event a a d)) ds) (f a) $ Map.lookup s m+ \(State a m) -> maybe (map (Event a a) ds) (f a) $ Map.lookup s m _cF :: [Double] -> String -> Pattern Double _cF = _cX f@@ -410,7 +410,7 @@ _cP ds s = innerJoin $ _cX f ds s where f a (VI v) = [Event a a (parseBP_E $ show v)] f a (VF v) = [Event a a (parseBP_E $ show v)]- f a (VS v) = [Event a a (parseBP_E $ v)]+ f a (VS v) = [Event a a (parseBP_E v)] cP :: (Enumerable a, Parseable a) => Pattern a -> String -> Pattern a cP d = _cP [d] cP_ :: (Enumerable a, Parseable a) => String -> Pattern a
src/Sound/Tidal/Core.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} module Sound.Tidal.Core where @@ -25,7 +25,7 @@ -- | @sine@ returns a 'Pattern' of continuous 'Fractional' values following a -- sinewave with frequency of one cycle, and amplitude from 0 to 1. sine :: Fractional a => Pattern a-sine = sig $ \t -> ((sin_rat $ (pi :: Double) * 2 * (fromRational t)) + 1) / 2+sine = sig $ \t -> (sin_rat ((pi :: Double) * 2 * fromRational t) + 1) / 2 where sin_rat = fromRational . toRational . sin -- | @cosine@ is a synonym for @0.25 ~> sine@.@@ -47,7 +47,7 @@ -- | @square@ is the equivalent of 'sine' for square waves. square :: (Fractional a) => Pattern a square = sig $- \t -> fromIntegral $ ((floor $ (mod' (fromRational t :: Double) 1) * 2) :: Integer)+ \t -> fromIntegral ((floor $ mod' (fromRational t :: Double) 1 * 2) :: Integer) -- | @envL@ is a 'Pattern' of continuous 'Double' values, representing -- a linear interpolation between 0 and 1 during the first cycle, then@@ -63,11 +63,11 @@ -- | 'Equal power' version of 'env', for gain-based transitions envEq :: Pattern Double-envEq = sig $ \t -> sqrt (sin (pi/2 * (max 0 $ min (fromRational (1-t)) 1)))+envEq = sig $ \t -> sqrt (sin (pi/2 * max 0 (min (fromRational (1-t)) 1))) -- | Equal power reversed envEqR :: Pattern Double-envEqR = sig $ \t -> sqrt (cos (pi/2 * (max 0 $ min (fromRational (1-t)) 1)))+envEqR = sig $ \t -> sqrt (cos (pi/2 * max 0 (min (fromRational (1-t)) 1))) -- ** Pattern algebra @@ -118,11 +118,11 @@ a %| b = mod' <$> a *> b (|>|) :: (Applicative a, Unionable b) => a b -> a b -> a b-a |>| b = (flip union) <$> a <*> b+a |>| b = flip union <$> a <*> b (|> ) :: Unionable a => Pattern a -> Pattern a -> Pattern a-a |> b = (flip union) <$> a <* b+a |> b = flip union <$> a <* b ( >|) :: Unionable a => Pattern a -> Pattern a -> Pattern a-a >| b = (flip union) <$> a *> b+a >| b = flip union <$> a *> b (|<|) :: (Applicative a, Unionable b) => a b -> a b -> a b a |<| b = union <$> a <*> b@@ -222,16 +222,20 @@ where total = sum $ map fst tps arrange :: Time -> [(Time, Pattern a)] -> [(Time, Time, Pattern a)] arrange _ [] = []- arrange t ((t',p):tps') = (t,t+t',p):(arrange (t+t') tps')+ arrange t ((t',p):tps') = (t,t+t',p) : arrange (t+t') tps' -- | 'overlay' combines two 'Pattern's into a new pattern, so that -- their events are combined over time. overlay :: Pattern a -> Pattern a -> Pattern a -- Analog if they're both analog-overlay p@(Pattern Analog _) p'@(Pattern Analog _) = Pattern Analog $ \st -> (query p st) ++ (query p' st)+overlay p@(Pattern Analog _) p'@(Pattern Analog _) = Pattern Analog $ \st -> query p st ++ query p' st -- Otherwise digital. Won't really work to have a mixture.. Hmm-overlay p p' = Pattern Digital $ \st -> (query p st) ++ (query p' st)+overlay p p' = Pattern Digital $ \st -> query p st ++ query p' st +-- | An infix alias of @overlay@+(<>) :: Pattern a -> Pattern a -> Pattern a+(<>) = overlay+ -- | 'stack' combines a list of 'Pattern's into a new pattern, so that -- their events are combined over time. stack :: [Pattern a] -> Pattern a@@ -264,7 +268,7 @@ _fast :: Time -> Pattern a -> Pattern a _fast r p | r == 0 = silence- | r < 0 = rev $ _fast (0-r) p+ | r < 0 = rev $ _fast (negate r) p | otherwise = withResultTime (/ r) $ withQueryTime (* r) p -- | Slow down a pattern by the given time pattern@@ -292,8 +296,7 @@ mapParts (mirrorArc (midCycle $ arc st)) $ map makeWholeRelative (query p st- {arc =- (mirrorArc (midCycle $ arc st) (arc st))+ {arc = mirrorArc (midCycle $ arc st) (arc st) }) } where makeWholeRelative :: Event a -> Event a@@ -303,7 +306,7 @@ makeWholeAbsolute (Event (Arc s e) p'@(Arc s' e') v) = Event (Arc (s'-e) (e'+s)) p' v midCycle :: Arc -> Time- midCycle (Arc s _) = (sam s) + 0.5+ midCycle (Arc s _) = sam s + 0.5 mapParts :: (Arc -> Arc) -> [Event a] -> [Event a] mapParts f es = (\(Event w p' v) -> Event w (f p') v) <$> es -- | Returns the `mirror image' of a 'Arc' around the given point in time@@ -328,7 +331,7 @@ zoomArc :: Arc -> Pattern a -> Pattern a zoomArc (Arc s e) p = splitQueries $- withResultArc (mapCycle ((/d) . (subtract s))) $ withQueryArc (mapCycle ((+s) . (*d))) p+ withResultArc (mapCycle ((/d) . subtract s)) $ withQueryArc (mapCycle ((+s) . (*d))) p where d = e-s -- | @fastGap@ is similar to 'fast' but maintains its cyclic@@ -372,12 +375,12 @@ every' np op f p = do { n <- np; o <- op; _every' n o f p } _every' :: Int -> Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-_every' n o f = when ((== o) . (`mod` n)) f+_every' n o = when ((== o) . (`mod` n)) -- | @foldEvery ns f p@ applies the function @f@ to @p@, and is applied for -- each cycle in @ns@. foldEvery :: [Int] -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-foldEvery ns f p = foldr ($) p (map (\x -> _every x f) ns)+foldEvery ns f p = foldr (`_every` f) p ns {-| Only `when` the given test function returns `True` the given pattern
src/Sound/Tidal/EspGrid.hs view
@@ -17,16 +17,16 @@ n :: Integer <- datum_integral (d!!4) let nanos = (t1*1000000000) + t2 return $ \t -> t { - atTime = ((realToFrac nanos)/1000000000), + atTime = realToFrac nanos / 1000000000, atCycle = fromIntegral n, cps = bpm/60, paused = on == 0 } changeTempo :: MVar Tempo -> Packet -> IO () -changeTempo t (Packet_Message msg) = do +changeTempo t (Packet_Message msg) = case parseEspTempo (messageDatum msg) of - Just f -> takeMVar t >>= (\x -> putMVar t (f x)) + Just f -> takeMVar t >>= putMVar t . f Nothing -> putStrLn "Warning: Unable to parse message (likely from EspGrid) as Tempo" changeTempo _ _ = putStrLn "Serious error: Can only process Packet_Message" @@ -36,7 +36,7 @@ _ <- forkIO $ forever $ do _ <- sendMessage socket $ Message "/esp/tempo/q" [] response <- waitAddress socket "/esp/tempo/r" - changeTempo t response + Sound.Tidal.EspGrid.changeTempo t response threadDelay 200000 return ()
src/Sound/Tidal/MiniTidal.hs view
@@ -1,21 +1,19 @@-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances, TemplateHaskell #-} module Sound.Tidal.MiniTidal (miniTidal,miniTidalIO,main) where -import Data.Functor.Identity (Identity)-import Text.Parsec.Language (haskellDef)-import Text.Parsec.Prim (ParsecT,parserZero)+import Text.Parsec.Prim (parserZero) import Text.ParserCombinators.Parsec-import qualified Text.ParserCombinators.Parsec.Token as P import Control.Monad (forever)-import Control.Applicative (liftA2)--- import Data.List (intercalate)--- import Data.Bool (bool)--- import Data.Ratio+import Control.Applicative (liftA2)+-- import Language.Haskell.TH import Sound.Tidal.Context (Pattern,ControlMap,ControlPattern,Enumerable,Parseable,Time,Arc,TPat,Stream) import qualified Sound.Tidal.Context as T+import Sound.Tidal.MiniTidal.Token+import Sound.Tidal.MiniTidal.TH + -- This is depended upon by Estuary, and changes to its type will cause problems downstream for Estuary. miniTidal :: String -> Either ParseError (Pattern ControlMap) miniTidal = parse miniTidalParser "miniTidal"@@ -86,12 +84,8 @@ listTransformationArg :: MiniTidal a => Parser [Pattern a -> Pattern a] listTransformationArg = try $ parensOrNot $ brackets (commaSep transformation) --- d1 $ spread ($) [density 2, rev, slow 2, striate 3, (# speed "0.8")] $ sound "[bd*2 [~ bd]] [sn future]*2 cp jvbass*4"--- spread ((a -> b) -> a -> b) -> [ControlPattern -> ControlPattern] -> ControlPattern -> ControlPattern-- silence :: Parser (Pattern a)-silence = function "silence" >> return T.silence+silence = $(function "silence") instance MiniTidal ControlMap where literal = parserZero@@ -104,65 +98,66 @@ controlPatternMergeOperator :: Parser (ControlPattern -> ControlPattern -> ControlPattern) controlPatternMergeOperator = choice [- op "#" >> return (T.#),- op "|>" >> return (T.|>),- op "<|" >> return (T.<|),- op "|>|" >> return (T.|>|),- op "|<|" >> return (T.|<),- op "|+|" >> return (T.|+|),- op "|-|" >> return (T.|-|),- op "|*|" >> return (T.|*|),- op "|/|" >> return (T.|/|)+ $(op "#"),+ $(op "|>"),+ $(op "<|"),+ $(op "|>"),+ $(op "|<|"),+ $(op "|+|"),+ $(op "|-|"),+ $(op "|*|"),+ $(op "|/|") ] specificControlPatterns :: Parser ControlPattern specificControlPatterns = choice [ try $ parens specificControlPatterns,- (function "coarse" >> return T.coarse) <*> patternArg,- (function "cut" >> return T.cut) <*> patternArg,- (function "n" >> return T.n) <*> patternArg,- (function "up" >> return T.up) <*> patternArg,- (function "speed" >> return T.speed) <*> patternArg,- (function "pan" >> return T.pan) <*> patternArg,- (function "shape" >> return T.shape) <*> patternArg,- (function "gain" >> return T.gain) <*> patternArg,- (function "accelerate" >> return T.accelerate) <*> patternArg,- (function "bandf" >> return T.bandf) <*> patternArg,- (function "bandq" >> return T.bandq) <*> patternArg,- (function "begin" >> return T.begin) <*> patternArg,- (function "crush" >> return T.crush) <*> patternArg,- (function "cutoff" >> return T.cutoff) <*> patternArg,- (function "delayfeedback" >> return T.delayfeedback) <*> patternArg,- (function "delaytime" >> return T.delaytime) <*> patternArg,- (function "delay" >> return T.delay) <*> patternArg,- (function "end" >> return T.end) <*> patternArg,- (function "hcutoff" >> return T.hcutoff) <*> patternArg,- (function "hresonance" >> return T.hresonance) <*> patternArg,- (function "resonance" >> return T.resonance) <*> patternArg,- (function "shape" >> return T.shape) <*> patternArg,- (function "loop" >> return T.loop) <*> patternArg,- (function "s" >> return T.s) <*> patternArg,- (function "sound" >> return T.sound) <*> patternArg,- (function "vowel" >> return T.vowel) <*> patternArg,- (function "unit" >> return T.unit) <*> patternArg,- (function "note" >> return T.note) <*> patternArg+ $(function "coarse") <*> patternArg,+ $(function "cut") <*> patternArg,+ $(function "n") <*> patternArg,+ $(function "up") <*> patternArg,+ $(function "speed") <*> patternArg,+ $(function "pan") <*> patternArg,+ $(function "shape") <*> patternArg,+ $(function "gain") <*> patternArg,+ $(function "accelerate") <*> patternArg,+ $(function "bandf") <*> patternArg,+ $(function "bandq") <*> patternArg,+ $(function "begin") <*> patternArg,+ $(function "crush") <*> patternArg,+ $(function "cutoff") <*> patternArg,+ $(function "delayfeedback") <*> patternArg,+ $(function "delaytime") <*> patternArg,+ $(function "delay") <*> patternArg,+ $(function "end") <*> patternArg,+ $(function "hcutoff") <*> patternArg,+ $(function "hresonance") <*> patternArg,+ $(function "resonance") <*> patternArg,+ $(function "shape") <*> patternArg,+ $(function "loop") <*> patternArg,+ $(function "s") <*> patternArg,+ $(function "sound") <*> patternArg,+ $(function "vowel") <*> patternArg,+ $(function "unit") <*> patternArg,+ $(function "note") <*> patternArg ] genericComplexPattern :: MiniTidal a => Parser (Pattern a) genericComplexPattern = choice [ try $ parens genericComplexPattern, lp_p <*> listPatternArg,- l_p <*> listLiteralArg+ l_p <*> listLiteralArg,+ pInt_p <*> patternArg ] p_p_noArgs :: Parser (Pattern a -> Pattern a) p_p_noArgs = choice [- function "brak" >> return T.brak,- function "rev" >> return T.rev,- function "palindrome" >> return T.palindrome,- function "stretch" >> return T.stretch,- function "loopFirst" >> return T.loopFirst,- function "degrade" >> return T.degrade+ $(function "brak"),+ $(function "rev"),+ $(function "palindrome"),+ $(function "stretch"),+ $(function "loopFirst"),+ $(function "degrade") ] p_p :: (MiniTidal a, MiniTidal a) => Parser (Pattern a -> Pattern a)@@ -184,6 +179,7 @@ lTime_p_p <*> listLiteralArg ] +lt_p_p :: MiniTidal a => Parser ([t -> Pattern a] -> t -> Pattern a) lt_p_p = choice [ try $ parens lt_p_p, spreads <*> (nestedParens $ reservedOp "$" >> return ($))@@ -191,18 +187,18 @@ l_p :: MiniTidal a => Parser ([a] -> Pattern a) l_p = choice [- function "listToPat" >> return T.listToPat,- function "choose" >> return T.choose,- function "cycleChoose" >> return T.cycleChoose+ $(function "listToPat"),+ $(function "choose"),+ $(function "cycleChoose") ] lp_p :: MiniTidal a => Parser ([Pattern a] -> Pattern a) lp_p = choice [- function "stack" >> return T.stack,- function "fastcat" >> return T.fastcat,- function "slowcat" >> return T.slowcat,- function "cat" >> return T.cat,- function "randcat" >> return T.randcat+ $(function "stack"),+ $(function "fastcat"),+ $(function "slowcat"),+ $(function "cat"),+ $(function "randcat") ] pInt_p :: MiniTidal a => Parser (Pattern Int -> Pattern a)@@ -215,102 +211,110 @@ p_p_p = choice [ try $ parens p_p_p, liftA2 <$> binaryFunctions,- function "overlay" >> return T.overlay,- function "append" >> return T.append,+ $(function "overlay"),+ $(function "append"), vTime_p_p_p <*> literalArg, pInt_p_p_p <*> patternArg ] +pTime_p_p :: MiniTidal a => Parser (Pattern Time -> Pattern a -> Pattern a) pTime_p_p = choice [ try $ parens pTime_p_p,- function "fast" >> return T.fast,- function "fastGap" >> return T.fastGap,- function "density" >> return T.density,- function "slow" >> return T.slow,- function "trunc" >> return T.trunc,- function "fastGap" >> return T.fastGap,- function "densityGap" >> return T.densityGap,- function "sparsity" >> return T.sparsity,- function "trunc" >> return T.trunc,- function "linger" >> return T.linger,- function "segment" >> return T.segment,- function "discretise" >> return T.discretise,- function "timeLoop" >> return T.timeLoop,- function "swing" >> return T.swing,+ $(function "fast"),+ $(function "fastGap"),+ $(function "density"),+ $(function "slow"),+ $(function "trunc"),+ $(function "fastGap"),+ $(function "densityGap"),+ $(function "sparsity"),+ $(function "trunc"),+ $(function "linger"),+ $(function "segment"),+ $(function "discretise"),+ $(function "timeLoop"),+ $(function "swing"), pTime_pTime_p_p <*> patternArg ] +lTime_p_p :: MiniTidal a => Parser ([Time] -> Pattern a -> Pattern a) lTime_p_p = choice [ try $ parens lTime_p_p,+ $(function "spaceOut"), spreads <*> parens vTime_p_p -- re: spread ] +spreads :: MiniTidal a => Parser ((b -> t -> Pattern a) -> [b] -> t -> Pattern a) spreads = choice [- function "spread" >> return T.spread,- function "slowspread" >> return T.slowspread,- function "fastspread" >> return T.fastspread+ $(function "spread"),+ $(function "slowspread"),+ $(function "fastspread") ] +pInt_p_p :: MiniTidal a => Parser (Pattern Int -> Pattern a -> Pattern a) pInt_p_p = choice [ try $ parens pInt_p_p,- function "iter" >> return T.iter,- function "iter'" >> return T.iter',- function "ply" >> return T.ply,- function "substruct'" >> return T.substruct',- function "slowstripe" >> return T.slowstripe,+ $(function "iter"),+ $(function "iter'"),+ $(function "ply"),+ $(function "substruct'"),+ $(function "slowstripe"),+ $(function "shuffle"),+ $(function "scramble"), pInt_pInt_p_p <*> patternArg ] -pString_p_p = function "substruct" >> return T.substruct+pString_p_p :: MiniTidal a => Parser (Pattern String -> Pattern a -> Pattern a)+pString_p_p = $(function "substruct") +pDouble_p_p :: MiniTidal a => Parser (Pattern Double -> Pattern a -> Pattern a) pDouble_p_p = choice [ try $ parens pDouble_p_p,- function "degradeBy" >> return T.degradeBy,- function "unDegradeBy" >> return T.unDegradeBy,+ $(function "degradeBy"),+ $(function "unDegradeBy"), vInt_pDouble_p_p <*> literalArg ] +vTime_p_p :: MiniTidal a => Parser (Time -> Pattern a -> Pattern a) vTime_p_p = choice [ try $ parens vTime_p_p,- function "rotL" >> return T.rotL,- function "rotR" >> return T.rotR,+ $(function "rotL"),+ $(function "rotR"), vTime_vTime_p_p <*> literalArg ] -vInt_p_p = choice [- function "shuffle" >> return T.shuffle,- function "scramble" >> return T.scramble,- function "repeatCycles" >> return T.repeatCycles- ]+vInt_p_p :: MiniTidal a => Parser (Int -> Pattern a -> Pattern a)+vInt_p_p = $(function "repeatCycles") +vTimeTime_p_p :: MiniTidal a => Parser ((Time,Time) -> Pattern a -> Pattern a) vTimeTime_p_p = choice [- function "compress" >> return T.compressArc,- function "zoom" >> return T.zoomArc,- function "compressTo" >> return T.compressArcTo+ $(function "compress"),+ $(function "zoom"),+ $(function "compressTo") ] +t_p_p :: MiniTidal a => Parser ((Pattern a -> Pattern a) -> Pattern a -> Pattern a) t_p_p = choice [ try $ parens t_p_p,- function "sometimes" >> return T.sometimes,- function "often" >> return T.often,- function "rarely" >> return T.rarely,- function "almostNever" >> return T.almostNever,- function "almostAlways" >> return T.almostAlways,- function "never" >> return T.never,- function "always" >> return T.always,- function "superimpose" >> return T.superimpose,- function "someCycles" >> return T.someCycles,- function "somecycles" >> return T.somecycles,+ $(function "sometimes"),+ $(function "often"),+ $(function "rarely"),+ $(function "almostNever"),+ $(function "almostAlways"),+ $(function "never"),+ $(function "always"),+ $(function "superimpose"),+ $(function "someCycles"), pInt_t_p_p <*> patternArg, pDouble_t_p_p <*> patternArg, lvInt_t_p_p <*> listLiteralArg, vInt_t_p_p <*> literalArg,- vDouble_t_p_p <*> literalArg+ vDouble_t_p_p <*> literalArg,+ vTimeTime_t_p_p <*> literalArg ] -lvTime_p_p = function "spaceOut" >> return T.spaceOut--lpInt_p_p = function "distrib" >> return T.distrib+lpInt_p_p :: MiniTidal a => Parser ([Pattern Int] -> Pattern a -> Pattern a)+lpInt_p_p = $(function "distrib") lp_p_p :: MiniTidal a => Parser ([Pattern a] -> Pattern a -> Pattern a) lp_p_p = choice [@@ -318,69 +322,86 @@ try $ spreads <*> parens p_p_p ] +l_pInt_p :: MiniTidal a => Parser ([a] -> Pattern Int -> Pattern a) l_pInt_p = choice [ try $ parens l_pInt_p, vInt_l_pInt_p <*> literalArg ] -vInt_l_pInt_p = function "fit" >> return T.fit+vInt_l_pInt_p :: MiniTidal a => Parser (Int -> [a] -> Pattern Int -> Pattern a)+vInt_l_pInt_p = $(function "fit") -vTime_p_p_p = function "wedge" >> return T.wedge+vTime_p_p_p :: MiniTidal a => Parser (Time -> Pattern a -> Pattern a -> Pattern a)+vTime_p_p_p = $(function "wedge") -vInt_pDouble_p_p = function "degradeOverBy" >> return T.degradeOverBy+vInt_pDouble_p_p :: MiniTidal a => Parser (Int -> Pattern Double -> Pattern a -> Pattern a)+vInt_pDouble_p_p = $(function "degradeOverBy") +pInt_t_p_p :: MiniTidal a => Parser (Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a) pInt_t_p_p = choice [ try $ parens pInt_t_p_p,- function "every" >> return T.every,+ $(function "every"), pInt_pInt_t_p_p <*> patternArg ] -pDouble_t_p_p = function "sometimesBy" >> return T.sometimesBy+pDouble_t_p_p :: MiniTidal a => Parser (Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)+pDouble_t_p_p = $(function "sometimesBy") -lvInt_t_p_p = function "foldEvery" >> return T.foldEvery+lvInt_t_p_p :: MiniTidal a => Parser ([Int] -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)+lvInt_t_p_p = $(function "foldEvery") -vTime_vTime_p_p = function "playFor" >> return T.playFor+vTime_vTime_p_p :: MiniTidal a => Parser (Time -> Time -> Pattern a -> Pattern a)+vTime_vTime_p_p = $(function "playFor") -vTimeTime_t_p_p = function "within" >> return T.withinArc+vTimeTime_t_p_p :: MiniTidal a => Parser ((Time,Time) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)+vTimeTime_t_p_p = $(function "within") +vInt_t_p_p :: MiniTidal a => Parser (Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a) vInt_t_p_p = choice [ try $ parens vInt_t_p_p,- function "chunk" >> return T.chunk,+ $(function "chunk"), vInt_vInt_t_p_p <*> literalArg ] -vDouble_t_p_p = choice [- function "someCyclesBy" >> return T.someCyclesBy,- function "somecyclesBy" >> return T.somecyclesBy- ]+vDouble_t_p_p :: MiniTidal a => Parser (Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)+vDouble_t_p_p = $(function "someCyclesBy") +pInt_pInt_p_p :: MiniTidal a => Parser (Pattern Int -> Pattern Int -> Pattern a -> Pattern a) pInt_pInt_p_p = choice [ try $ parens pInt_pInt_p_p,- function "euclid" >> return T.euclid,- function "euclidInv" >> return T.euclidInv,+ $(function "euclid"),+ $(function "euclidInv"), vInt_pInt_pInt_p_p <*> literalArg ] -pTime_pTime_p_p = function "swingBy" >> return T.swingBy+pTime_pTime_p_p :: MiniTidal a => Parser (Pattern Time -> Pattern Time -> Pattern a -> Pattern a)+pTime_pTime_p_p = $(function "swingBy") -pInt_pInt_t_p_p = function "every'" >> return T.every'+pInt_pInt_t_p_p :: MiniTidal a => Parser (Pattern Int -> Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)+pInt_pInt_t_p_p = $(function "every'") -vInt_vInt_t_p_p = function "whenmod" >> return T.whenmod+vInt_vInt_t_p_p :: MiniTidal a => Parser (Int -> Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)+vInt_vInt_t_p_p = $(function "whenmod") +pInt_p_p_p :: MiniTidal a => Parser (Pattern Int -> Pattern a -> Pattern a -> Pattern a) pInt_p_p_p = choice [ try $ parens pInt_p_p_p, pInt_pInt_p_p_p <*> patternArg ] -pInt_pInt_p_p_p = function "euclidFull" >> return T.euclidFull+pInt_pInt_p_p_p :: MiniTidal a => Parser (Pattern Int -> Pattern Int -> Pattern a -> Pattern a -> Pattern a)+pInt_pInt_p_p_p = $(function "euclidFull") +vInt_pInt_pInt_p_p :: MiniTidal a => Parser (Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a) vInt_pInt_pInt_p_p = choice [ try $ parens vInt_pInt_pInt_p_p, pTime_vInt_pInt_pInt_p_p <*> patternArg ] -pTime_vInt_pInt_pInt_p_p = function "fit'" >> return T.fit'+pTime_vInt_pInt_pInt_p_p :: MiniTidal a => Parser (Pattern Time -> Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a)+pTime_vInt_pInt_pInt_p_p = $(function "fit'") +pControl_pControl :: Parser (ControlPattern -> ControlPattern) pControl_pControl = choice [ try $ parens pControl_pControl, pInt_pControl_pControl <*> patternArg,@@ -389,41 +410,48 @@ tControl_pControl_pControl <*> transformationArg ] -tControl_pControl_pControl = function "jux" >> return T.jux+tControl_pControl_pControl :: Parser ((ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern)+tControl_pControl_pControl = $(function "jux") +pInt_pControl_pControl :: Parser (Pattern Int -> ControlPattern -> ControlPattern) pInt_pControl_pControl = choice [- function "chop" >> return T.chop,- function "striate" >> return T.striate+ $(function "chop"),+ $(function "striate") ] +pDouble_pControl_pControl :: Parser (Pattern Double -> ControlPattern -> ControlPattern) pDouble_pControl_pControl = choice [ try $ parens pDouble_pControl_pControl, pInt_pDouble_pControl_pControl <*> patternArg ] -pInt_pDouble_pControl_pControl = function "striate'" >> return T.striate'+pInt_pDouble_pControl_pControl :: Parser (Pattern Int -> Pattern Double -> ControlPattern -> ControlPattern)+pInt_pDouble_pControl_pControl = $(function "striate'") +pTime_pControl_pControl :: Parser (Pattern Time -> ControlPattern -> ControlPattern) pTime_pControl_pControl = choice [ try $ parens pTime_pControl_pControl, pDouble_pTime_pControl_pControl <*> patternArg ] +pDouble_pTime_pControl_pControl :: Parser (Pattern Double -> Pattern Time -> ControlPattern -> ControlPattern) pDouble_pTime_pControl_pControl = choice [ try $ parens pDouble_pTime_pControl_pControl, pInteger_pDouble_pTime_pControl_pControl <*> patternArg ] -pInteger_pDouble_pTime_pControl_pControl = function "stut" >> return T.stut+pInteger_pDouble_pTime_pControl_pControl :: Parser (Pattern Integer -> Pattern Double -> Pattern Time -> ControlPattern -> ControlPattern)+pInteger_pDouble_pTime_pControl_pControl = $(function "stut") simpleDoublePatterns :: Parser (Pattern Double) simpleDoublePatterns = choice [- function "rand" >> return T.rand,- function "sine" >> return T.sine,- function "saw" >> return T.saw,- function "isaw" >> return T.isaw,- function "tri" >> return T.tri,- function "square" >> return T.square,- function "cosine" >> return T.cosine+ $(function "rand"),+ $(function "sine"),+ $(function "saw"),+ $(function "isaw"),+ $(function "tri"),+ $(function "square"),+ $(function "cosine") ] binaryNumFunctions :: Num a => Parser (a -> a -> a)@@ -481,6 +509,17 @@ mergeOperator = parserZero binaryFunctions = parserZero +instance MiniTidal (Time,Time) where+ literal = do+ xs <- parens (commaSep1 literal)+ if length xs == 2 then return ((xs!!0),(xs!!1)) else unexpected "(Time,Time) must contain exactly two values"+ simplePattern = pure <$> literal+ transformationWithArguments = p_p_noArgs+ transformationWithoutArguments = p_p+ complexPattern = atom <*> literal+ mergeOperator = parserZero+ binaryFunctions = parserZero+ instance MiniTidal String where literal = stringLiteral simplePattern = parseBP'@@ -491,150 +530,35 @@ binaryFunctions = parserZero fractionalMergeOperator :: Fractional a => Parser (Pattern a -> Pattern a -> Pattern a)-fractionalMergeOperator = op "/" >> return (/)+fractionalMergeOperator = opParser "/" >> return (/) numMergeOperator :: Num a => Parser (Pattern a -> Pattern a -> Pattern a) numMergeOperator = choice [- op "+" >> return (+),- op "-" >> return (-),- op "*" >> return (*)+ opParser "+" >> return (+),+ opParser "-" >> return (-),+ opParser "*" >> return (*) ] enumComplexPatterns :: (Enum a, Num a, MiniTidal a) => Parser (Pattern a) enumComplexPatterns = choice [- (function "run" >> return T.run) <*> patternArg,- (function "scan" >> return T.scan) <*> patternArg+ $(function "run") <*> patternArg,+ $(function "scan") <*> patternArg ] numComplexPatterns :: (Num a, MiniTidal a) => Parser (Pattern a) numComplexPatterns = choice [- (function "irand" >> return T.irand) <*> literal,- (function "toScale'" >> return T.toScale') <*> literalArg <*> listLiteralArg <*> patternArg,- (function "toScale" >> return T.toScale) <*> listLiteralArg <*> patternArg+ $(function "irand") <*> literal,+ $(function "toScale'") <*> literalArg <*> listLiteralArg <*> patternArg,+ $(function "toScale") <*> listLiteralArg <*> patternArg ] intComplexPatterns :: Parser (Pattern Int) intComplexPatterns = choice [- (function "randStruct" >> return T.randStruct) <*> literalArg+ $(function "randStruct") <*> literalArg ] atom :: Applicative m => Parser (a -> m a)-atom = (function "pure" <|> function "atom" <|> function "return") >> return (pure)--double :: Parser Double-double = choice [- parens $ symbol "-" >> float >>= return . (* (-1)),- parens double,- try float,- try $ fromIntegral <$> integer- ]--int :: Parser Int-int = try $ parensOrNot $ fromIntegral <$> integer--function :: String -> Parser ()-function x = reserved x <|> try (parens (function x))--op :: String -> Parser ()-op x = reservedOp x <|> try (parens (op x))--parensOrNot :: Parser a -> Parser a-parensOrNot p = p <|> try (parens (parensOrNot p))--nestedParens :: Parser a -> Parser a-nestedParens p = try (parens p) <|> try (parens (nestedParens p))--applied :: Parser a -> Parser a-applied p = op "$" >> p--appliedOrNot :: Parser a -> Parser a-appliedOrNot p = applied p <|> p--parensOrApplied :: Parser a -> Parser a-parensOrApplied p = try (parens p) <|> try (applied p)--tokenParser :: P.TokenParser a-tokenParser = P.makeTokenParser $ haskellDef {- P.reservedNames = ["chop","striate","striate'","stut","jux","brak","rev",- "palindrome","fast","density","slow","iter","iter'","trunc","swingBy","every","whenmod",- "append","append'","silence","s","sound","n","up","speed","vowel","pan","shape","gain",- "accelerate","bandf","bandq","begin","coarse","crush","cut","cutoff","delayfeedback",- "delaytime","delay","end","hcutoff","hresonance","loop","resonance","shape","unit",- "sine","saw","isaw","fit","irand","tri","square","rand",- "pure","return","stack","fastcat","slowcat","cat","atom","overlay","run","scan","fast'",- "fastGap","densityGap","sparsity","rotL","rotR","playFor","every'","foldEvery",- "cosine","superimpose","trunc","linger","zoom","compress","sliceArc","within","within'",- "revArc","euclid","euclidFull","euclidInv","distrib","wedge","prr","preplace","prep","preplace1",- "protate","prot","prot1","discretise","segment","struct","substruct","compressTo",- "substruct'","stripe","slowstripe","stretch","fit'","chunk","loopFirst","timeLoop","swing",- "choose","degradeBy","unDegradeBy","degradeOverBy","sometimesBy","sometimes","often",- "rarely","almostNever","almostAlways","never","always","someCyclesBy","somecyclesBy",- "someCycles","somecycles","substruct'","repeatCycles","spaceOut","fill","ply","shuffle",- "scramble","breakUp","degrade","randcat","randStruct","toScale'","toScale","cycleChoose",- "d1","d2","d3","d4","d5","d6","d7","d8","d9","t1","t2","t3","t4","t5","t6","t7","t8","t9",- "cps","xfadeIn","note","spread","slowspread","fastspread"],- P.reservedOpNames = ["+","-","*","/","<~","~>","#","|+|","|-|","|*|","|/|","$","\"","|>","<|","|>|","|<|"]- }--{- Not currently in use-angles :: ParsecT String u Identity a -> ParsecT String u Identity a-angles = P.angles tokenParser-braces :: ParsecT String u Identity a -> ParsecT String u Identity a-braces = P.braces tokenParser-charLiteral :: ParsecT String u Identity Char-charLiteral = P.charLiteral tokenParser-colon :: ParsecT String u Identity String-colon = P.colon tokenParser-comma :: ParsecT String u Identity String-comma = P.comma tokenParser-decimal :: ParsecT String u Identity Integer-decimal = P.decimal tokenParser-dot :: ParsecT String u Identity String-dot = P.dot tokenParser-hexadecimal :: ParsecT String u Identity Integer-hexadecimal = P.hexadecimal tokenParser-identifier :: ParsecT String u Identity String-identifier = P.identifier tokenParser-lexeme :: ParsecT String u Identity a -> ParsecT String u Identity a-lexeme = P.lexeme tokenParser-naturalOrFloat :: ParsecT String u Identity (Either Integer Double)-naturalOrFloat = P.naturalOrFloat tokenParser-natural :: ParsecT String u Identity Integer-natural = P.natural tokenParser-octal :: ParsecT String u Identity Integer-octal = P.octal tokenParser-operator :: ParsecT String u Identity String-operator = P.operator tokenParser-semi :: ParsecT String u Identity String-semi = P.semi tokenParser-semiSep1 :: ParsecT String u Identity a -> ParsecT String u Identity [a]-semiSep1 = P.semiSep1 tokenParser-semiSep :: ParsecT String u Identity a -> ParsecT String u Identity [a]-semiSep = P.semiSep tokenParser--}--brackets :: ParsecT String u Identity a -> ParsecT String u Identity a-brackets = P.brackets tokenParser-commaSep1 :: ParsecT String u Identity a -> ParsecT String u Identity [a]-commaSep1 = P.commaSep1 tokenParser-commaSep :: ParsecT String u Identity a -> ParsecT String u Identity [a]-commaSep = P.commaSep tokenParser-float :: ParsecT String u Identity Double-float = P.float tokenParser-integer :: ParsecT String u Identity Integer-integer = P.integer tokenParser-parens :: ParsecT String u Identity a -> ParsecT String u Identity a-parens = P.parens tokenParser-reservedOp :: String -> ParsecT String u Identity ()-reservedOp = P.reservedOp tokenParser-reserved :: String -> ParsecT String u Identity ()-reserved = P.reserved tokenParser-stringLiteral :: ParsecT String u Identity String-stringLiteral = P.stringLiteral tokenParser-symbol :: String -> ParsecT String u Identity String-symbol = P.symbol tokenParser-whiteSpace :: ParsecT String u Identity ()-whiteSpace = P.whiteSpace tokenParser+atom = (functionParser "pure" <|> functionParser "atom" <|> functionParser "return") >> return (pure) parseBP' :: (Enumerable a, Parseable a) => Parser (Pattern a) parseBP' = parseTPat' >>= return . T.toPat
+ src/Sound/Tidal/MiniTidal/TH.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE TemplateHaskell #-}++module Sound.Tidal.MiniTidal.TH where++import Language.Haskell.TH+import Sound.Tidal.MiniTidal.Token++op :: String -> Q Exp+op x = do -- op "x" >> return T.x+ let y = appE [|opParser|] $ return (LitE $ StringL x)+ let z = appE [|return|] $ return (VarE $ mkName $ "T." ++ x)+ uInfixE y [|(>>)|] z++function :: String -> Q Exp+function x = do -- function "x" >> return T.x+ let y = appE [|functionParser|] $ return (LitE $ StringL x)+ let z = appE [|return|] $ return (VarE $ mkName $ "T." ++ x)+ uInfixE y [|(>>)|] z
+ src/Sound/Tidal/MiniTidal/Token.hs view
@@ -0,0 +1,122 @@+module Sound.Tidal.MiniTidal.Token where++import Data.Functor.Identity (Identity)+import Text.Parsec.Prim (ParsecT,parserZero)+import Text.ParserCombinators.Parsec+import Text.Parsec.Language (haskellDef)+import qualified Text.ParserCombinators.Parsec.Token as P++tokenParser :: P.TokenParser a+tokenParser = P.makeTokenParser $ haskellDef {+ P.reservedNames = ["chop","striate","striate'","stut","jux","brak","rev",+ "palindrome","fast","density","slow","iter","iter'","trunc","swingBy","every","whenmod",+ "append","append'","silence","s","sound","n","up","speed","vowel","pan","shape","gain",+ "accelerate","bandf","bandq","begin","coarse","crush","cut","cutoff","delayfeedback",+ "delaytime","delay","end","hcutoff","hresonance","loop","resonance","shape","unit",+ "sine","saw","isaw","fit","irand","tri","square","rand",+ "pure","return","stack","fastcat","slowcat","cat","atom","overlay","run","scan","fast'",+ "fastGap","densityGap","sparsity","rotL","rotR","playFor","every'","foldEvery",+ "cosine","superimpose","trunc","linger","zoom","compress","sliceArc","within","within'",+ "revArc","euclid","euclidFull","euclidInv","distrib","wedge","prr","preplace","prep","preplace1",+ "protate","prot","prot1","discretise","segment","struct","substruct","compressTo",+ "substruct'","stripe","slowstripe","stretch","fit'","chunk","loopFirst","timeLoop","swing",+ "choose","degradeBy","unDegradeBy","degradeOverBy","sometimesBy","sometimes","often",+ "rarely","almostNever","almostAlways","never","always","someCyclesBy","somecyclesBy",+ "someCycles","somecycles","substruct'","repeatCycles","spaceOut","fill","ply","shuffle",+ "scramble","breakUp","degrade","randcat","randStruct","toScale'","toScale","cycleChoose",+ "d1","d2","d3","d4","d5","d6","d7","d8","d9","t1","t2","t3","t4","t5","t6","t7","t8","t9",+ "cps","xfadeIn","note","spread","slowspread","fastspread"],+ P.reservedOpNames = ["+","-","*","/","<~","~>","#","|+|","|-|","|*|","|/|","$","\"","|>","<|","|>|","|<|"]+ }++{- Not currently in use+angles :: ParsecT String u Identity a -> ParsecT String u Identity a+angles = P.angles tokenParser+braces :: ParsecT String u Identity a -> ParsecT String u Identity a+braces = P.braces tokenParser+charLiteral :: ParsecT String u Identity Char+charLiteral = P.charLiteral tokenParser+colon :: ParsecT String u Identity String+colon = P.colon tokenParser+comma :: ParsecT String u Identity String+comma = P.comma tokenParser+decimal :: ParsecT String u Identity Integer+decimal = P.decimal tokenParser+dot :: ParsecT String u Identity String+dot = P.dot tokenParser+hexadecimal :: ParsecT String u Identity Integer+hexadecimal = P.hexadecimal tokenParser+identifier :: ParsecT String u Identity String+identifier = P.identifier tokenParser+lexeme :: ParsecT String u Identity a -> ParsecT String u Identity a+lexeme = P.lexeme tokenParser+naturalOrFloat :: ParsecT String u Identity (Either Integer Double)+naturalOrFloat = P.naturalOrFloat tokenParser+natural :: ParsecT String u Identity Integer+natural = P.natural tokenParser+octal :: ParsecT String u Identity Integer+octal = P.octal tokenParser+operator :: ParsecT String u Identity String+operator = P.operator tokenParser+semi :: ParsecT String u Identity String+semi = P.semi tokenParser+semiSep1 :: ParsecT String u Identity a -> ParsecT String u Identity [a]+semiSep1 = P.semiSep1 tokenParser+semiSep :: ParsecT String u Identity a -> ParsecT String u Identity [a]+semiSep = P.semiSep tokenParser+-}++brackets :: ParsecT String u Identity a -> ParsecT String u Identity a+brackets = P.brackets tokenParser+commaSep1 :: ParsecT String u Identity a -> ParsecT String u Identity [a]+commaSep1 = P.commaSep1 tokenParser+commaSep :: ParsecT String u Identity a -> ParsecT String u Identity [a]+commaSep = P.commaSep tokenParser+float :: ParsecT String u Identity Double+float = P.float tokenParser+integer :: ParsecT String u Identity Integer+integer = P.integer tokenParser+parens :: ParsecT String u Identity a -> ParsecT String u Identity a+parens = P.parens tokenParser+reservedOp :: String -> ParsecT String u Identity ()+reservedOp = P.reservedOp tokenParser+reserved :: String -> ParsecT String u Identity ()+reserved = P.reserved tokenParser+stringLiteral :: ParsecT String u Identity String+stringLiteral = P.stringLiteral tokenParser+symbol :: String -> ParsecT String u Identity String+symbol = P.symbol tokenParser+whiteSpace :: ParsecT String u Identity ()+whiteSpace = P.whiteSpace tokenParser++functionParser :: String -> Parser ()+functionParser x = reserved x <|> try (parens (functionParser x))++opParser :: String -> Parser ()+opParser x = reservedOp x <|> try (parens (opParser x))++double :: Parser Double+double = choice [+ parens $ symbol "-" >> float >>= return . (* (-1)),+ parens double,+ try float,+ try $ fromIntegral <$> integer+ ]++int :: Parser Int+int = try $ parensOrNot $ fromIntegral <$> integer++parensOrNot :: Parser a -> Parser a+parensOrNot p = p <|> try (parens (parensOrNot p))++nestedParens :: Parser a -> Parser a+nestedParens p = try (parens p) <|> try (parens (nestedParens p))++applied :: Parser a -> Parser a+applied p = opParser "$" >> p++appliedOrNot :: Parser a -> Parser a+appliedOrNot p = applied p <|> p++parensOrApplied :: Parser a -> Parser a+parensOrApplied p = try (parens p) <|> try (applied p)
src/Sound/Tidal/Params.hs view
@@ -44,6 +44,16 @@ pS :: String -> Pattern String -> ControlPattern pS name = fmap (Map.singleton name . VS) +-- | patterns for internal sound routing+toArg :: Pattern String -> ControlPattern+toArg = pS "toArg"++from :: Pattern Double -> ControlPattern+from = pF "from"++to :: Pattern Double -> ControlPattern+to = pF "to"+ -- | a pattern of numbers that speed up (or slow down) samples while they play. accelerate :: Pattern Double -> ControlPattern accelerate = pF "accelerate"@@ -385,6 +395,55 @@ distort :: Pattern Double -> ControlPattern distort = pF "distort" +-- Spectral freeze+freeze :: Pattern Double -> ControlPattern+freeze = pF "freeze"++-- Spectral delay+xsdelay :: Pattern Double -> ControlPattern+xsdelay = pF "xsdelay"++tsdelay :: Pattern Double -> ControlPattern+tsdelay = pF "tsdelay"++-- Spectral conform+real :: Pattern Double -> ControlPattern+real = pF "real"++imag :: Pattern Double -> ControlPattern+imag = pF "imag"++-- Spectral enhance+enhance :: Pattern Double -> ControlPattern+enhance = pF "enhance"++partials :: Pattern Double -> ControlPattern+partials = pF "partials"++-- Spectral comb+comb :: Pattern Double -> ControlPattern+comb = pF "comb"++-- Spectral smear+smear :: Pattern Double -> ControlPattern+smear = pF "smear"++-- Spectral scramble+scram :: Pattern Double -> ControlPattern+scram = pF "scram"++-- Spectral binshift+binshift :: Pattern Double -> ControlPattern+binshift = pF "binshift"++-- High pass sort of spectral filter+hbrick :: Pattern Double -> ControlPattern+hbrick = pF "hbrick"++-- Low pass sort of spectral filter+lbrick :: Pattern Double -> ControlPattern+lbrick = pF "lbrick"+ -- aliases att, bpf, bpq, chdecay, ctf, ctfg, delayfb, delayt, det, gat, hg, hpf, hpq, lag, lbd, lch, lcl, lcp, lcr, lfoc, lfoi , lfop, lht, llt, loh, lpf, lpq, lsn, ohdecay, phasdp, phasr, pit1, pit2, pit3, por, rel, sz, sag, scl, scp@@ -443,10 +502,10 @@ voi = voice midinote :: Pattern Double -> ControlPattern-midinote = note . ((subtract 60) <$>)+midinote = note . (subtract 60 <$>) drum :: Pattern String -> ControlPattern-drum = n . ((subtract 60) . drumN <$>)+drum = n . (subtract 60 . drumN <$>) drumN :: Num a => String -> a drumN "bd" = 36
src/Sound/Tidal/ParseBP.hs view
@@ -73,15 +73,15 @@ TPat_pE n k s thing -> doEuclid (toPat n) (toPat k) (toPat s) (toPat thing) TPat_Foot -> error "Can't happen, feet (.'s) only used internally.."- TPat_EnumFromTo a b -> unwrap $ fromTo <$> (toPat a) <*> (toPat b)+ TPat_EnumFromTo a b -> unwrap $ fromTo <$> toPat a <*> toPat b -- TPat_EnumFromThenTo a b c -> unwrap $ fromThenTo <$> (toPat a) <*> (toPat b) <*> (toPat c) _ -> silence durations :: [TPat a] -> [(Int, TPat a)] durations [] = []-durations ((TPat_Elongate n):xs) = (n, TPat_Silence):(durations xs)-durations (a:(TPat_Elongate n):xs) = (n+1,a):(durations xs)-durations (a:xs) = (1,a):(durations xs)+durations (TPat_Elongate n : xs) = (n, TPat_Silence) : durations xs+durations (a : TPat_Elongate n : xs) = (n+1,a) : durations xs+durations (a:xs) = (1,a) : durations xs parseBP :: (Enumerable a, Parseable a) => String -> Either ParseError (Pattern a) parseBP s = toPat <$> parseTPat s@@ -111,8 +111,8 @@ doEuclid = euclidOff instance Enumerable Double where- fromTo a b = enumFromTo' a b- fromThenTo a b c = enumFromThenTo' a b c+ fromTo = enumFromTo'+ fromThenTo = enumFromThenTo' instance Parseable String where tPatParser = pVocable@@ -135,24 +135,24 @@ doEuclid = euclidOff instance Enumerable Int where- fromTo a b = enumFromTo' a b- fromThenTo a b c = enumFromThenTo' a b c+ fromTo = enumFromTo'+ fromThenTo = enumFromThenTo' instance Parseable Integer where tPatParser = pIntegral doEuclid = euclidOff instance Enumerable Integer where- fromTo a b = enumFromTo' a b- fromThenTo a b c = enumFromThenTo' a b c+ fromTo = enumFromTo'+ fromThenTo = enumFromThenTo' instance Parseable Rational where tPatParser = pRational doEuclid = euclidOff instance Enumerable Rational where- fromTo a b = enumFromTo' a b- fromThenTo a b c = enumFromThenTo' a b c+ fromTo = enumFromTo'+ fromThenTo = enumFromThenTo' enumFromTo' :: (Ord a, Enum a) => a -> a -> Pattern a enumFromTo' a b | a > b = fastFromList $ reverse $ enumFromTo b a@@ -232,7 +232,7 @@ -} parseRhythm :: Parseable a => Parser (TPat a) -> String -> Either ParseError (TPat a)-parseRhythm f input = parse (pSequence f') "" input+parseRhythm f = parse (pSequence f') "" where f' = f <|> do symbol "~" <?> "rest" return TPat_Silence@@ -253,7 +253,7 @@ return (length ps, ps') elongate :: [TPat a] -> TPat a-elongate xs | any (isElongate) xs = TPat_TimeCat xs+elongate xs | any isElongate xs = TPat_TimeCat xs | otherwise = TPat_Cat xs where isElongate (TPat_Elongate _) = True isElongate _ = False@@ -270,7 +270,7 @@ -- could use splitOn here but `TPat a` isn't a member of `EQ`.. splitFeet :: [TPat t] -> [[TPat t]] splitFeet [] = []-splitFeet pats = foot:(splitFeet pats')+splitFeet pats = foot : splitFeet pats' where (foot, pats') = takeFoot pats takeFoot [] = ([], []) takeFoot (TPat_Foot:pats'') = ([], pats'')@@ -291,7 +291,7 @@ pts <- pStretch pt <|> pReplicate pt'' spaces- return $ pts+ return pts pPolyIn :: Parseable a => Parser (TPat a) -> Parser (TPat a) pPolyIn f = do ps <- brackets (pSequence f `sepBy` symbol ",")@@ -312,16 +312,15 @@ spaces pMult $ TPat_Stack $ scale' (Just 1) ps where scale' _ [] = []- scale' base (pats@((n,_):_)) = map (\(n',pat) -> TPat_Density (TPat_Atom $ fromIntegral (fromMaybe n base)/ fromIntegral n') pat) pats+ scale' base pats@((n,_):_) = map (\(n',pat) -> TPat_Density (TPat_Atom $ fromIntegral (fromMaybe n base)/ fromIntegral n') pat) pats -pString :: Parser (String)+pString :: Parser String pString = do c <- (letter <|> oneOf "0123456789") <?> "charnum" cs <- many (letter <|> oneOf "0123456789:.-_") <?> "string" return (c:cs) pVocable :: Parser (TPat String)-pVocable = do v <- pString- return $ TPat_Atom v+pVocable = TPat_Atom <$> pString pDouble :: Parser (TPat Double) pDouble = do f <- choice [intOrFloat, parseNote] <?> "float"@@ -366,7 +365,7 @@ do char '\'' i <- integer <?> "chord range" let chord' = take (fromIntegral i) $ concatMap (\x -> map (+ x) chord) [0,12..]- return $ chord'+ return chord' <|> return chord parseNote :: Num a => Parser a@@ -392,7 +391,7 @@ ] fromNote :: Num a => Pattern String -> Pattern a-fromNote pat = (\s -> either (const 0) id $ parse parseNote "" s) <$> pat+fromNote pat = either (const 0) id . parse parseNote "" <$> pat pColour :: Parser (TPat ColourD) pColour = do name <- many1 letter <?> "colour name"@@ -402,18 +401,16 @@ pMult :: TPat a -> Parser (TPat a) pMult thing = do char '*' spaces- r <- (pRational <|> pPolyIn pRational <|> pPolyOut pRational)+ r <- pRational <|> pPolyIn pRational <|> pPolyOut pRational return $ TPat_Density r thing <|> do char '/' spaces- r <- (pRational <|> pPolyIn pRational <|> pPolyOut pRational)+ r <- pRational <|> pPolyIn pRational <|> pPolyOut pRational return $ TPat_Slow r thing <|> return thing -- pRand :: TPat a -> Parser (TPat a) pRand thing = do char '?' spaces@@ -421,7 +418,7 @@ <|> return thing pE :: TPat a -> Parser (TPat a)-pE thing = do (n,k,s) <- parens (pair)+pE thing = do (n,k,s) <- parens pair pure $ TPat_pE n k s thing <|> return thing where pair :: Parser (TPat Int, TPat Int, TPat Int)@@ -441,7 +438,7 @@ do extras <- many $ do char '!' -- if a number is given (without a space)slow 2 $ fast -- replicate that number of times- n <- ((read <$> many1 digit) <|> return (2 :: Int))+ n <- (read <$> many1 digit) <|> return (2 :: Int) spaces thing' <- pRand thing -- -1 because we already have parsed the original one@@ -451,10 +448,10 @@ pStretch :: TPat a -> Parser [TPat a] pStretch thing = do char '@'- n <- ((read <$> many1 digit) <|> return 1)+ n <- (read <$> many1 digit) <|> return 1 return $ map (\x -> TPat_Zoom (Arc (x%n) ((x+1)%n)) thing) [0 .. (n-1)] -pRatio :: Parser (Rational)+pRatio :: Parser Rational pRatio = do s <- sign n <- natural result <- do char '%'@@ -465,14 +462,13 @@ frac <- many1 digit -- A hack, but not sure if doing this -- numerically would be any faster..- return (toRational $ ((read $ show n ++ "." ++ frac) :: Double))+ return (toRational ((read $ show n ++ "." ++ frac) :: Double)) <|> return (n%1) return $ applySign s result pRational :: Parser (TPat Rational)-pRational = do r <- pRatio- return $ TPat_Atom r+pRational = TPat_Atom <$> pRatio {- pDensity :: Parser (Rational)
src/Sound/Tidal/Pattern.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveFunctor #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -12,7 +11,7 @@ import Data.Data (Data) -- toConstr import Data.List (delete, findIndex, sort, intercalate) import qualified Data.Map.Strict as Map-import Data.Maybe (isJust, fromJust, catMaybes, fromMaybe)+import Data.Maybe (isJust, fromJust, catMaybes, fromMaybe, mapMaybe) import Data.Ratio (numerator, denominator) import Data.Typeable (Typeable) @@ -87,14 +86,14 @@ -- | The arc of the whole cycle that the given time value falls within timeToCycleArc :: Time -> Arc-timeToCycleArc t = (Arc (sam t) ((sam t) + 1))+timeToCycleArc t = Arc (sam t) (sam t + 1) -- | A list of cycle numbers which are included in the given arc cyclesInArc :: Integral a => Arc -> [a] cyclesInArc (Arc s e) | s > e = [] | s == e = [floor s]- | otherwise = [floor s .. (ceiling e)-1]+ | otherwise = [floor s .. ceiling e-1] -- | A list of arcs of the whole cycles which are included in the given arc cycleArcsInArc :: Arc -> [Arc]@@ -104,7 +103,7 @@ arcCycles :: Arc -> [Arc] arcCycles (Arc s e) | s >= e = [] | sam s == sam e = [Arc s e]- | otherwise = (Arc s (nextSam s)) : (arcCycles (Arc (nextSam s) e))+ | otherwise = Arc s (nextSam s) : arcCycles (Arc (nextSam s) e) -- | Like arcCycles, but returns zero-width arcs arcCyclesZW :: Arc -> [Arc]@@ -114,7 +113,7 @@ -- | Similar to 'fmap' but time is relative to the cycle (i.e. the -- sam of the start of the arc) mapCycle :: (Time -> Time) -> Arc -> Arc-mapCycle f (Arc s e) = Arc (sam' + (f $ s - sam')) (sam' + (f $ e - sam'))+mapCycle f (Arc s e) = Arc (sam' + f (s - sam')) (sam' + f (e - sam')) where sam' = sam s -- | @isIn a t@ is @True@ if @t@ is inside@@ -134,7 +133,7 @@ type Event a = EventF (ArcF Time) a instance Bifunctor EventF where- bimap f g (Event w p e) = (Event (f w) (f p) (g e))+ bimap f g (Event w p e) = Event (f w) (f p) (g e) instance {-# OVERLAPPING #-} Show a => Show (Event a) where show (Event (Arc ws we) a@(Arc ps pe) e) =@@ -151,16 +150,16 @@ -- | Compares two lists of events, attempting to combine fragmented events in the process -- for a 'truer' compare compareDefrag :: (Ord a) => [Event a] -> [Event a] -> Bool-compareDefrag as bs = (sort $ defragParts as) == (sort $ defragParts bs)+compareDefrag as bs = sort (defragParts as) == sort (defragParts bs) -- | Returns a list of events, with any adjacent parts of the same whole combined defragParts :: Eq a => [Event a] -> [Event a] defragParts [] = []-defragParts (e:[]) = (e:[])-defragParts (e:es) | isJust i = defraged:(defragParts (delete e' es))- | otherwise = e:(defragParts es)+defragParts [e] = [e]+defragParts (e:es) | isJust i = defraged : defragParts (delete e' es)+ | otherwise = e : defragParts es where i = findIndex (isAdjacent e) es- e' = es !! (fromJust i)+ e' = es !! fromJust i defraged = Event (whole e) u (value e) u = hull (part e) (part e') @@ -168,9 +167,9 @@ isAdjacent :: Eq a => Event a -> Event a -> Bool isAdjacent e e' = (whole e == whole e') && (value e == value e')- && (((stop $ part e) == (start $ part e'))+ && ((stop (part e) == start (part e')) ||- ((stop $ part e') == (start $ part e))+ (stop (part e') == start (part e)) ) -- | Get the onset of an event's 'whole'@@ -197,7 +196,7 @@ eventValue = value eventHasOnset :: Event a -> Bool-eventHasOnset e = (start $ whole e) == (start $ part e)+eventHasOnset e = start (whole e) == start (part e) toEvent :: (((Time, Time), (Time, Time)), a) -> Event a toEvent (((ws, we), (ps, pe)), v) = Event (Arc ws we) (Arc ps pe) v@@ -231,7 +230,7 @@ instance Functor Pattern where -- | apply a function to all the values in a pattern- fmap f p = p {query = (fmap (fmap f)) . query p}+ fmap f p = p {query = fmap (fmap f) . query p} instance Applicative Pattern where -- | Repeat the given value once per cycle, forever@@ -239,7 +238,7 @@ map (\a' -> Event a' (sect a a') v) $ cycleArcsInArc a (<*>) pf@(Pattern Digital _) px@(Pattern Digital _) = Pattern Digital q- where q st = catMaybes $ concat $ map match $ query pf st+ where q st = catMaybes $ concatMap match $ query pf st where match (Event fWhole fPart f) = map@@ -254,7 +253,7 @@ where match (Event fWhole fPart f) = map- (\e -> (Event fWhole fPart (f (value e))))+ (Event fWhole fPart . f . value) (query px $ st {arc = pure (start fPart)}) (<*>) pf@(Pattern Analog _) px@(Pattern Digital _) = Pattern Digital q@@ -262,15 +261,15 @@ where match (Event xWhole xPart x) = map- (\e -> (Event xWhole xPart ((value e) x)))- (query pf st {arc = (pure (start xPart))})+ (\e -> Event xWhole xPart (value e x))+ (query pf st {arc = pure (start xPart)}) (<*>) pf px = Pattern Analog q where q st = concatMap match $ query pf st where match ef = map- (\ex -> (Event (arc st) (arc st) ((value ef) (value ex))))+ (Event (arc st) (arc st) . value ef . value) (query px st) -- | Like <*>, but the structure only comes from the left@@ -280,7 +279,7 @@ where match (Event fWhole fPart f) = map- (\e -> (Event fWhole fPart (f (value e)))) $+ (Event fWhole fPart . f . value) $ query px $ st {arc = xQuery fWhole} xQuery (Arc s _) = pure s -- for discrete events, match with the onset @@ -289,7 +288,7 @@ where match (Event fWhole fPart f) = map- (\e -> (Event fWhole fPart (f (value e)))) $+ (Event fWhole fPart . f . value) $ query px st -- for continuous events, use the original query -- | Like <*>, but the structure only comes from the right@@ -299,7 +298,7 @@ where match (Event xWhole xPart x) = map- (\e -> (Event xWhole xPart ((value e) x))) $+ (\e -> Event xWhole xPart (value e x)) $ query pf $ fQuery xWhole fQuery (Arc s _) = st {arc = pure s} -- for discrete events, match with the onset @@ -308,7 +307,7 @@ where match (Event xWhole xPart x) = map- (\e -> (Event xWhole xPart ((value e) x))) $+ (\e -> Event xWhole xPart (value e x)) $ query pf st -- for continuous events, use the original query infixl 4 <*, *>@@ -331,9 +330,7 @@ unwrap pp = pp {query = q} where q st = concatMap (\(Event w p v) ->- catMaybes $- map (munge w p) $- query v st {arc = p})+ mapMaybe (munge w p) $ query v st {arc = p}) (query pp st) munge ow op (Event iw ip v') = do@@ -346,10 +343,8 @@ innerJoin :: Pattern (Pattern a) -> Pattern a innerJoin pp = pp {query = q} where q st = concatMap- (\(Event _ p v) ->- catMaybes $- map munge $- query v st {arc = p})+ (\(Event _ p v) -> mapMaybe munge $ query v st {arc = p}+ ) (query pp st) where munge (Event iw ip v) = do@@ -363,9 +358,8 @@ outerJoin pp = pp {query = q} where q st = concatMap (\(Event w p v) ->- catMaybes $- map (munge w p) $- query v st {arc = (pure (start w))})+ mapMaybe (munge w p) $ query v st {arc = pure (start w)}+ ) (query pp st) where munge ow op (Event _ _ v') = do@@ -375,18 +369,18 @@ -- | Like @unwrap@, but cycles of the inner patterns are compressed to fit the -- timespan of the outer whole (or the original query if it's a continuous pattern?) -- TODO - what if a continuous pattern contains a discrete one, or vice-versa?-unwrapSqueeze :: Pattern (Pattern a) -> Pattern a-unwrapSqueeze pp = pp {query = q}+squeezeJoin :: Pattern (Pattern a) -> Pattern a+squeezeJoin pp = pp {query = q} where q st = concatMap (\(Event w p v) ->- catMaybes $- map (munge w p) $- query (compressArc w v) st {arc = p})+ mapMaybe (munge w p) $ query (compressArc (cycleArc w) v) st {arc = p}+ ) (query pp st) munge oWhole oPart (Event iWhole iPart v) = do w' <- subArc oWhole iWhole p' <- subArc oPart iPart return (Event w' p' v)+ cycleArc (Arc s e) = Arc (cyclePos s) (cyclePos s + (e-s)) noOv :: String -> a noOv meth = error $ meth ++ ": not supported for patterns"@@ -397,18 +391,19 @@ instance TolerantEq Value where (VS a) ~== (VS b) = a == b (VI a) ~== (VI b) = a == b- (VF a) ~== (VF b) = (abs (a - b)) < 0.000001+ (VF a) ~== (VF b) = abs (a - b) < 0.000001 _ ~== _ = False instance TolerantEq ControlMap where- a ~== b = (Map.differenceWith (\a' b' -> if a' ~== b' then Nothing else Just a') a b) == Map.empty+ a ~== b = Map.differenceWith (\a' b' -> if a' ~== b' then Nothing else Just a') a b == Map.empty instance TolerantEq (Event ControlMap) where (Event w p x) ~== (Event w' p' x') = w == w' && p == p' && x ~== x' -instance TolerantEq a => TolerantEq ([a]) where- as ~== bs = (length as == length bs) && (and $ map (\(a,b) -> a ~== b) $ zip as bs)+instance TolerantEq a => TolerantEq [a] where+ as ~== bs = (length as == length bs) && all (uncurry (~==)) (zip as bs) + instance Eq (Pattern a) where (==) = noOv "(==)" @@ -491,13 +486,13 @@ isIEEE = noOv "isIEEE" atan2 = liftA2 atan2 -instance Num (ControlMap) where- negate = ((applyFIS negate negate id) <$>)+instance Num ControlMap where+ negate = (applyFIS negate negate id <$>) (+) = Map.unionWith (fNum2 (+) (+)) (*) = Map.unionWith (fNum2 (*) (*)) fromInteger i = Map.singleton "n" $ VI $ fromInteger i- signum = ((applyFIS signum signum id) <$>)- abs = ((applyFIS abs abs id) <$>)+ signum = (applyFIS signum signum id <$>)+ abs = (applyFIS abs abs id <$>) instance Fractional ControlMap where recip = fmap (applyFIS recip id id)@@ -507,21 +502,21 @@ showPattern a p = intercalate "\n" $ map show $ queryArc p a instance (Show a) => Show (Pattern a) where- show p = showPattern (Arc 0 1) p+ show = showPattern (Arc 0 1) instance Show Value where show (VS s) = ('"':s) ++ "\"" show (VI i) = show i show (VF f) = show f ++ "f" -instance {-# OVERLAPPING #-} Show (ControlMap) where+instance {-# OVERLAPPING #-} Show ControlMap where show m = intercalate ", " $ map (\(name, v) -> name ++ ": " ++ show v) $ Map.toList m prettyRat :: Rational -> String prettyRat r | unit == 0 && frac > 0 = showFrac (numerator frac) (denominator frac) | otherwise = show unit ++ showFrac (numerator frac) (denominator frac) where unit = floor r :: Int- frac = (r - (toRational unit))+ frac = r - toRational unit showFrac :: Integer -> Integer -> String showFrac 0 _ = ""@@ -624,7 +619,7 @@ -- | @withPart f p@ returns a new @Pattern@ with function @f@ applied -- to the part. withPart :: (Arc -> Arc) -> Pattern a -> Pattern a-withPart f = withEvent (\(Event w p v) -> (Event w (f p) v))+withPart f = withEvent (\(Event w p v) -> Event w (f p) v) -- | Apply one of three functions to a Value, depending on its type applyFIS :: (Double -> Double) -> (Int -> Int) -> (String -> String) -> Value -> Value@@ -660,7 +655,7 @@ | otherwise = s `rotR` _fastGap (1/(e-s)) p compressArcTo :: Arc -> Pattern a -> Pattern a-compressArcTo (Arc s e) p = compressArc (Arc (cyclePos s) (e-(sam s))) p+compressArcTo (Arc s e) = compressArc (Arc (cyclePos s) (e - sam s)) _fastGap :: Time -> Pattern a -> Pattern a _fastGap 0 _ = empty@@ -672,7 +667,7 @@ -- zero width queries of the next sam should return zero in this case.. f st@(State a _) | start a' == nextSam (start a) = [] | otherwise = query p st {arc = a'}- where mungeQuery t = sam t + (min 1 $ r' * cyclePos t)+ where mungeQuery t = sam t + min 1 (r' * cyclePos t) a' = (\(Arc s e) -> Arc (mungeQuery s) (mungeQuery e)) a -- | Shifts a pattern back in time by the given amount, expressed in cycles@@ -681,25 +676,25 @@ -- | Shifts a pattern forward in time by the given amount, expressed in cycles rotR :: Time -> Pattern a -> Pattern a-rotR t = rotL (0-t)+rotR t = rotL (negate t) -- ** Event filters -- | Remove events from patterns that to not meet the given test filterValues :: (a -> Bool) -> Pattern a -> Pattern a-filterValues f p = p {query = (filter (f . value)) . query p}+filterValues f p = p {query = filter (f . value) . query p} -- | Turns a pattern of 'Maybe' values in to a pattern of values, -- dropping the events of 'Nothing'. filterJust :: Pattern (Maybe a) -> Pattern a-filterJust p = fromJust <$> (filterValues (isJust) p)+filterJust p = fromJust <$> filterValues isJust p -- formerly known as playWhen filterWhen :: (Time -> Bool) -> Pattern a -> Pattern a filterWhen test p = p {query = filter (test . wholeStart) . query p} playFor :: Time -> Time -> Pattern a -> Pattern a-playFor s e = filterWhen (\t -> and [t >= s, t < e])+playFor s e = filterWhen (\t -> (t >= s) && (t < e)) -- ** Temporal parameter helpers @@ -713,7 +708,7 @@ tParam3 f a b c p = innerJoin $ (\x y z -> f x y z p) <$> a <*> b <*> c tParamSqueeze :: (a -> Pattern b -> Pattern c) -> (Pattern a -> Pattern b -> Pattern c)-tParamSqueeze f tv p = unwrapSqueeze $ (`f` p) <$> tv+tParamSqueeze f tv p = squeezeJoin $ (`f` p) <$> tv -- | Mark values in the first pattern which match with at least one -- value in the second pattern.@@ -722,6 +717,6 @@ where q st = map match $ query pb st where match (Event xWhole xPart x) =- Event xWhole xPart (or $ (map (f x) (as $ start xWhole)), x)+ Event xWhole xPart (any (f x) (as $ start xWhole), x) as s = map value $ query pa $ fQuery s- fQuery s = st {arc = (Arc s s)}+ fQuery s = st {arc = Arc s s}
src/Sound/Tidal/Scales.hs view
@@ -1,7 +1,6 @@ module Sound.Tidal.Scales (scale, scaleList) where import Data.Maybe-import Data.List (intercalate) import Sound.Tidal.Pattern import Sound.Tidal.Utils@@ -104,9 +103,9 @@ melodicMajor :: Num a => [a] melodicMajor = [0,2,4,5,7,8,10] bartok :: Num a => [a]-bartok = [0,2,4,5,7,8,10]+bartok = melodicMajor hindu :: Num a => [a]-hindu = [0,2,4,5,7,8,10]+hindu = melodicMajor -- raga modes todi :: Num a => [a]@@ -150,6 +149,22 @@ diminished2 :: Num a => [a] diminished2 = [0,2,3,5,6,8,9,11] +-- modes of limited transposition+messiaen1 :: Num a => [a]+messiaen1 = whole'+messiaen2 :: Num a => [a]+messiaen2 = diminished+messiaen3 :: Num a => [a]+messiaen3 = [0, 2, 3, 4, 6, 7, 8, 10, 11]+messiaen4 :: Num a => [a]+messiaen4 = [0, 1, 2, 5, 6, 7, 8, 11]+messiaen5 :: Num a => [a]+messiaen5 = [0, 1, 5, 6, 7, 11]+messiaen6 :: Num a => [a]+messiaen6 = [0, 2, 4, 5, 6, 8, 10, 11]+messiaen7 :: Num a => [a]+messiaen7 = [0, 1, 2, 3, 5, 6, 7, 8, 9, 11]+ -- 12 note scales chromatic :: Num a => [a] chromatic = [0,1,2,3,4,5,6,7,8,9,10,11]@@ -157,10 +172,10 @@ scale :: Num a => Pattern String -> Pattern Int -> Pattern a scale sp p = (\n scaleName -> noteInScale (fromMaybe [0] $ lookup scaleName scaleTable) n) <$> p <*> sp where octave s x = x `div` length s- noteInScale s x = (s !!! x) + (fromIntegral $ 12 * octave s x)+ noteInScale s x = (s !!! x) + fromIntegral (12 * octave s x) scaleList :: String-scaleList = intercalate " " $ map fst (scaleTable :: [(String, [Int])])+scaleList = unwords $ map fst (scaleTable :: [(String, [Int])]) scaleTable :: Num a => [(String, [a])] scaleTable = [("minPent", minPent),@@ -181,6 +196,7 @@ ("zhi", zhi), ("yu", yu), ("whole", whole'),+ ("wholetone", whole'), ("augmented", augmented), ("augmented2", augmented2), ("hexMajor7", hexMajor7),@@ -221,7 +237,16 @@ ("neapolitanMajor", neapolitanMajor), ("locrianMajor", locrianMajor), ("diminished", diminished),+ ("octatonic", diminished), ("diminished2", diminished2),+ ("octatonic2", diminished2),+ ("messiaen1", messiaen1),+ ("messiaen2", messiaen2),+ ("messiaen3", messiaen3),+ ("messiaen4", messiaen4),+ ("messiaen5", messiaen5),+ ("messiaen6", messiaen6),+ ("messiaen7", messiaen7), ("chromatic", chromatic) ]
src/Sound/Tidal/Simple.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} module Sound.Tidal.Simple where @@ -9,7 +9,7 @@ import Sound.Tidal.Pattern (ControlPattern) import GHC.Exts ( IsString(..) ) -instance {-# OVERLAPPING #-} IsString (ControlPattern) where+instance {-# OVERLAPPING #-} IsString ControlPattern where fromString = s . parseBP_E crunch :: ControlPattern -> ControlPattern
src/Sound/Tidal/Tempo.hs view
@@ -37,30 +37,24 @@ starting :: Bool } -resetCycles :: MVar Tempo -> IO (Tempo)-resetCycles tempoMV = do t <- O.time- tempo <- takeMVar tempoMV- let tempo' = tempo {atTime = t,- atCycle = (-0.5)- }- sendTempo tempo'- putMVar tempoMV $ tempo'- return tempo'---setCps :: MVar Tempo -> O.Time -> IO (Tempo)-setCps tempoMV newCps = do t <- O.time+changeTempo :: MVar Tempo -> (O.Time -> Tempo -> Tempo) -> IO Tempo+changeTempo tempoMV f = do t <- O.time tempo <- takeMVar tempoMV- let c = timeToCycles tempo t- tempo' = tempo {atTime = t,- atCycle = c,- cps = newCps- }+ let tempo' = f t $ tempo sendTempo tempo'- -- TODO - should we set the tempo ASAP rather than waiting for (possibly failing) network round trip?- putMVar tempoMV $ tempo'+ putMVar tempoMV tempo' return tempo' ++resetCycles :: MVar Tempo -> IO Tempo+resetCycles tempoMV = changeTempo tempoMV (\t tempo -> tempo {atTime = t, atCycle = 0})++setCps :: MVar Tempo -> O.Time -> IO Tempo+setCps tempoMV newCps = changeTempo tempoMV (\t tempo -> tempo {atTime = t,+ atCycle = timeToCycles tempo t,+ cps = newCps+ })+ defaultTempo :: O.Time -> O.UDP -> N.SockAddr -> Tempo defaultTempo t local remote = Tempo {atTime = t, atCycle = 0,@@ -75,9 +69,9 @@ -- | Returns the given time in terms of -- cycles relative to metrical grid of a given Tempo timeToCycles :: Tempo -> O.Time -> Rational-timeToCycles tempo t = (atCycle tempo) + (toRational cycleDelta)- where delta = t - (atTime tempo)- cycleDelta = (realToFrac $ cps tempo) * delta+timeToCycles tempo t = atCycle tempo + toRational cycleDelta+ where delta = t - atTime tempo+ cycleDelta = realToFrac (cps tempo) * delta {- getCurrentCycle :: MVar Tempo -> IO Rational@@ -94,7 +88,7 @@ let st = State {ticks = 0, start = s, nowTime = s,- nowArc = (P.Arc 0 0),+ nowArc = P.Arc 0 0, starting = True } clockTid <- forkIO $ loop tempoMV st@@ -104,14 +98,14 @@ tempo <- readMVar tempoMV let frameTimespan = cFrameTimespan config -- 'now' comes from clock ticks, nothing to do with cycles- logicalT ticks' = start st + (fromIntegral ticks') * frameTimespan- logicalNow = logicalT $ (ticks st) + 1+ logicalT ticks' = start st + fromIntegral ticks' * frameTimespan+ logicalNow = logicalT $ ticks st + 1 -- the tempo is just used to convert logical time to cycles e = timeToCycles tempo logicalNow- s = if (starting st) && (synched tempo)- then (timeToCycles tempo (logicalT $ ticks st))- else (P.stop $ nowArc st)- st' = st {ticks = (ticks st) + 1, nowArc = P.Arc s e,+ s = if starting st && synched tempo+ then timeToCycles tempo (logicalT $ ticks st)+ else P.stop $ nowArc st+ st' = st {ticks = ticks st + 1, nowArc = P.Arc s e, starting = not (synched tempo) } t <- O.time@@ -128,24 +122,24 @@ (remote_addr:_) <- N.getAddrInfo Nothing (Just hostname) Nothing local <- O.udpServer "127.0.0.1" tempoClientPort let (N.SockAddrInet _ a) = N.addrAddress remote_addr- remote = N.SockAddrInet (fromIntegral port) (a)+ remote = N.SockAddrInet (fromIntegral port) a t = defaultTempo s local remote -- Send to clock port from same port that's listened to O.sendTo local (O.p_message "/hello" []) remote -- Make tempo mvar tempoMV <- newMVar t -- Listen to tempo changes- tempoChild <- (forkIO $ listenTempo local tempoMV)+ tempoChild <- forkIO $ listenTempo local tempoMV return (tempoMV, tempoChild) sendTempo :: Tempo -> IO () sendTempo tempo = O.sendTo (localUDP tempo) (O.p_bundle (atTime tempo) [m]) (remoteAddr tempo) where m = O.Message "/transmit/cps/cycle" [O.Float $ fromRational $ atCycle tempo, O.Float $ realToFrac $ cps tempo,- O.Int32 $ if (paused tempo) then 1 else 0+ O.Int32 $ if paused tempo then 1 else 0 ] -listenTempo :: O.UDP -> (MVar Tempo) -> IO ()+listenTempo :: O.UDP -> MVar Tempo -> IO () listenTempo udp tempoMV = forever $ do pkt <- O.recvPacket udp act Nothing pkt return ()@@ -160,15 +154,15 @@ putMVar tempoMV $ tempo {atTime = ts, atCycle = realToFrac atCycle', cps = realToFrac cps',- paused = (paused' == 1),+ paused = paused' == 1, synched = True } act _ pkt = putStrLn $ "Unknown packet: " ++ show pkt serverListen :: Config -> IO (Maybe ThreadId)-serverListen config = catchAny (run) (\_ -> do putStrLn $ "Tempo listener failed (is one already running?)"- return Nothing- )+serverListen config = catchAny run (\_ -> do putStrLn "Tempo listener failed (is one already running?)"+ return Nothing+ ) where run = do let port = cTempoPort config -- iNADDR_ANY deprecated - what's the right way to do this? udp <- O.udpServer "0.0.0.0" port@@ -178,11 +172,11 @@ cs' <- act udp c Nothing cs pkt loop udp cs' act :: O.UDP -> N.SockAddr -> Maybe O.Time -> [N.SockAddr] -> O.Packet -> IO [N.SockAddr]- act udp c _ cs (O.Packet_Bundle (O.Bundle ts ms)) = foldM (act udp c (Just ts)) cs $ map (O.Packet_Message) ms+ act udp c _ cs (O.Packet_Bundle (O.Bundle ts ms)) = foldM (act udp c (Just ts)) cs $ map O.Packet_Message ms act _ c _ cs (O.Packet_Message (O.Message "/hello" [])) = return $ nub $ c:cs act udp _ (Just ts) cs (O.Packet_Message (O.Message path params))- | isPrefixOf "/transmit" path =+ | "/transmit" `isPrefixOf` path = do let path' = drop 9 path msg = O.Message path' params mapM_ (O.sendTo udp $ O.p_bundle ts [msg]) cs
src/Sound/Tidal/UI.hs view
@@ -4,7 +4,6 @@ import Prelude hiding ((<*), (*>)) -import Data.Ord (comparing) import Data.Char (digitToInt, isDigit) -- import System.Random (randoms, mkStdGen) import System.Random.MWC@@ -12,38 +11,36 @@ import qualified Data.Vector as V import Data.Word (Word32) import Data.Ratio ((%),numerator,denominator)-import Data.List (sort, sortBy, sortOn, findIndices, elemIndex, groupBy, transpose)-import Data.Maybe (isJust, fromJust, fromMaybe, mapMaybe, catMaybes)+import Data.List (sort, sortOn, findIndices, elemIndex, groupBy, transpose)+import Data.Maybe (isJust, fromJust, fromMaybe, mapMaybe) import qualified Data.Text as T-import Control.Applicative (liftA2) import qualified Data.Map.Strict as Map+import Data.Bool (bool) import Sound.Tidal.Bjorklund (bjorklund) import Sound.Tidal.Core import qualified Sound.Tidal.Params as P import Sound.Tidal.Pattern import Sound.Tidal.Utils- + ------------------------------------------------------------------------ -- * UI -- | Randomisation -timeToRand :: RealFrac a => a -> Double-timeToRand x = runST $ do+timeToSeed x = do let x' = toRational (x*x) / 1000000 let n' = fromIntegral $ numerator x' let d' = fromIntegral $ denominator x'- seed <- initialize (V.fromList [n',d'] :: V.Vector Word32)- uniform seed+ initialize (V.fromList [n',d'] :: V.Vector Word32) +timeToRand :: RealFrac a => a -> Double+timeToRand x = runST $ do seed <- timeToSeed x+ uniform seed+ timeToRands :: RealFrac a => a -> Int -> [Double]-timeToRands x n = V.toList $ runST $ do- let x' = toRational (x*x) / 1000000- let n' = fromIntegral $ numerator x'- let d' = fromIntegral $ denominator x'- seed <- initialize (V.fromList [n',d'] :: V.Vector Word32)- uniformVector seed n+timeToRands x n = V.toList $ runST $ do seed <- timeToSeed x+ uniformVector seed n {-| @@ -91,7 +88,7 @@ @ -} irand :: Num a => Int -> Pattern a-irand i = (fromIntegral . (floor :: Double -> Int) . (* (fromIntegral i))) <$> rand+irand i = fromIntegral . (floor :: Double -> Int) . (* fromIntegral i) <$> rand {- | 1D Perlin (smooth) noise, works like rand but smoothly moves between random values each cycle. `perlinWith` takes a pattern as the RNG's "input" instead@@ -105,8 +102,8 @@ -} perlinWith :: Pattern Double -> Pattern Double perlinWith p = interp <$> (p-pa) <*> (timeToRand <$> pa) <*> (timeToRand <$> pb) where- pa = ((fromIntegral :: Int -> Double) . floor) <$> p- pb = ((fromIntegral :: Int -> Double) . (+1) . floor) <$> p+ pa = (fromIntegral :: Int -> Double) . floor <$> p+ pb = (fromIntegral :: Int -> Double) . (+1) . floor <$> p interp x a b = a + smootherStep x * (b-a) smootherStep x = 6.0 * x**5 - 15.0 * x**4 + 10.0 * x**3 @@ -116,9 +113,9 @@ {- `perlin2With` is Perlin noise with a 2-dimensional input. This can be useful for more control over how the randomness repeats (or doesn't). @-d1 - $ s "[supersaw:-12*32]" - # lpf (rangex 60 5000 $ perlin2With (cosine*2) (sine*2)) +d1+ $ s "[supersaw:-12*32]"+ # lpf (rangex 60 5000 $ perlin2With (cosine*2) (sine*2)) # lpq 0.3 @ will generate a smooth random cutoff pattern that repeats every cycle without@@ -159,7 +156,7 @@ chooseBy :: Pattern Double -> [a] -> Pattern a chooseBy _ [] = silence-chooseBy f xs = ((xs !!) . floor) <$> (range 0 (fromIntegral $ length xs) f)+chooseBy f xs = (xs !!) . floor <$> range 0 (fromIntegral $ length xs) f {- | Like @choose@, but works on an a list of tuples of values and weights @@ -177,7 +174,7 @@ wchooseBy :: Pattern Double -> [(a,Double)] -> Pattern a wchooseBy pat pairs = match <$> pat where- match r = values !! (head (findIndices (> (r*total)) cweights))+ match r = values !! head (findIndices (> (r*total)) cweights) cweights = scanl1 (+) (map snd pairs) values = map fst pairs total = sum $ map snd pairs@@ -207,7 +204,7 @@ _unDegradeBy x p = fmap fst $ filterValues ((<= x) . snd) $ (,) <$> p <*> rand degradeOverBy :: Int -> Pattern Double -> Pattern a -> Pattern a-degradeOverBy i tx p = unwrap $ (\x -> (fmap fst $ filterValues ((> x) . snd) $ (,) <$> p <*> fastRepeatCycles i rand)) <$> (slow (fromIntegral i) tx)+degradeOverBy i tx p = unwrap $ (\x -> fmap fst $ filterValues ((> x) . snd) $ (,) <$> p <*> fastRepeatCycles i rand) <$> slow (fromIntegral i) tx {- | Use @sometimesBy@ to apply a given function "sometimes". For example, the@@ -228,7 +225,7 @@ @ -} sometimesBy :: Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-sometimesBy x f p = overlay (degradeBy x p) (f $ unDegradeBy x p)+sometimesBy x f p = overlay (degradeBy x p) (unDegradeBy x $ f p) -- | @sometimes@ is an alias for sometimesBy 0.5. sometimes :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a@@ -260,7 +257,7 @@ `someCycles = someCyclesBy 0.5` alias -} someCyclesBy :: Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a someCyclesBy x = when test- where test c = (timeToRand (fromIntegral c :: Double)) < x+ where test c = timeToRand (fromIntegral c :: Double) < x somecyclesBy :: Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a somecyclesBy = someCyclesBy@@ -337,7 +334,7 @@ iter = tParam _iter _iter :: Int -> Pattern a -> Pattern a-_iter n p = slowcat $ map (\i -> ((fromIntegral i)%(fromIntegral n)) `rotL` p) [0 .. (n-1)]+_iter n p = slowcat $ map (\i -> (fromIntegral i % fromIntegral n) `rotL` p) [0 .. (n-1)] -- | @iter'@ is the same as @iter@, but decrements the starting -- subdivision instead of incrementing it.@@ -345,7 +342,7 @@ iter' = tParam _iter' _iter' :: Int -> Pattern a -> Pattern a-_iter' n p = slowcat $ map (\i -> ((fromIntegral i)%(fromIntegral n)) `rotR` p) [0 .. (n-1)]+_iter' n p = slowcat $ map (\i -> (fromIntegral i % fromIntegral n) `rotR` p) [0 .. (n-1)] -- | @palindrome p@ applies @rev@ to @p@ every other cycle, so that -- the pattern alternates between forwards and backwards.@@ -369,24 +366,24 @@ @ -} seqP :: [(Time, Time, Pattern a)] -> Pattern a-seqP ps = stack $ map (\(s, e, p) -> playFor s e ((sam s) `rotR` p)) ps+seqP ps = stack $ map (\(s, e, p) -> playFor s e (sam s `rotR` p)) ps -- | Degrades a pattern over the given time. fadeOut :: Time -> Pattern a -> Pattern a-fadeOut dur p = innerJoin $ (\slope -> _degradeBy slope p) <$> (_slow dur envL)+fadeOut dur p = innerJoin $ (`_degradeBy` p) <$> _slow dur envL -- | Alternate version to @fadeOut@ where you can provide the time from which the fade starts fadeOutFrom :: Time -> Time -> Pattern a -> Pattern a-fadeOutFrom from dur p = innerJoin $ (\slope -> _degradeBy slope p) <$> (from `rotR` _slow dur envL)+fadeOutFrom from dur p = innerJoin $ (`_degradeBy` p) <$> (from `rotR` _slow dur envL) -- | 'Undegrades' a pattern over the given time. fadeIn :: Time -> Pattern a -> Pattern a-fadeIn dur p = innerJoin $ (\slope -> _degradeBy slope p) <$> (_slow dur envLR)+fadeIn dur p = innerJoin $ (`_degradeBy` p) <$> _slow dur envLR -- | Alternate version to @fadeIn@ where you can provide the time from -- which the fade in starts fadeInFrom :: Time -> Time -> Pattern a -> Pattern a-fadeInFrom from dur p = innerJoin $ (\slope -> _degradeBy slope p) <$> (from `rotR` _slow dur envLR)+fadeInFrom from dur p = innerJoin $ (`_degradeBy` p) <$> (from `rotR` _slow dur envLR) {- | The 'spread' function allows you to take a pattern transformation which takes a parameter, such as `slow`, and provide several@@ -453,7 +450,7 @@ There is also @slowspread@, which is an alias of @spread@. -} fastspread :: (a -> t -> Pattern b) -> [a] -> t -> Pattern b-fastspread f xs p = fastcat $ map (\x -> f x p) xs+fastspread f xs p = fastcat $ map (`f` p) xs {- | There's a version of this function, `spread'` (pronounced "spread prime"), which takes a *pattern* of parameters, instead of a list: @@ -507,6 +504,8 @@ -- @p@ into the portion of each cycle given by @t@, and @p'@ into the -- remainer of each cycle. wedge :: Time -> Pattern a -> Pattern a -> Pattern a+wedge 0 _ p' = p'+wedge 1 p _ = p wedge t p p' = overlay (_fastGap (1/t) p) (t `rotR` _fastGap (1/(1-t)) p') {- | @whenmod@ has a similar form and behavior to `every`, but requires an@@ -522,7 +521,7 @@ @ -} whenmod :: Int -> Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-whenmod a b = Sound.Tidal.Core.when ((\t -> (t `mod` a) >= b ))+whenmod a b = Sound.Tidal.Core.when (\t -> (t `mod` a) >= b ) {- | @@@ -582,7 +581,7 @@ -} within :: (Time, Time) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a within (s, e) f p = stack [filterWhen (\t -> cyclePos t >= s && cyclePos t < e) $ f p,- filterWhen (\t -> not $ cyclePos t >= s && cyclePos t < e) $ p+ filterWhen (\t -> not $ cyclePos t >= s && cyclePos t < e) p ] withinArc :: Arc -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a@@ -623,8 +622,8 @@ within' :: (Time, Time) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a within' a@(s, e) f p =- stack [ filterWhen (\t -> cyclePos t >= s && cyclePos t < e) $ compress a $ f $ zoom a $ p- , filterWhen (\t -> not $ cyclePos t >= s && cyclePos t < e) $ p+ stack [ filterWhen (\t -> cyclePos t >= s && cyclePos t < e) $ compress a $ f $ zoom a p+ , filterWhen (\t -> not $ cyclePos t >= s && cyclePos t < e) p ] revArc :: (Time, Time) -> Pattern a -> Pattern a@@ -678,8 +677,11 @@ euclid = tParam2 _euclid _euclid :: Int -> Int -> Pattern a -> Pattern a-_euclid n k p = (flip const) <$> (filterValues (== True) $ fastFromList $ bjorklund (n,k)) <*> p+_euclid n k a = fastcat $ fmap (bool silence a) $ bjorklund (n,k) +-- _euclid :: Int -> Int -> Pattern a -> Pattern a+-- _euclid n k p = flip const <$> filterValues (== True) (fastFromList $ bjorklund (n,k)) <*> p+ {- | `euclidfull n k pa pb` stacks @e n k pa@ with @einv n k pb@ -} euclidFull :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a -> Pattern a --euclidFull pn pk pa pb = innerJoin $ (\n k -> _euclidFull n k pa pb) <$> pn <*> pk@@ -688,11 +690,14 @@ _euclidBool :: Int -> Int -> Pattern Bool _euclidBool n k = fastFromList $ bjorklund (n,k) -_euclidFull :: Int -> Int -> Pattern a -> Pattern a -> Pattern a-_euclidFull n k p p' = pickbool <$> (_euclidBool n k) <*> p <*> p'- where pickbool True a _ = a- pickbool False _ b = b+{-_euclidFull :: Int -> Int -> Pattern a -> Pattern a -> Pattern a+ _euclidFull n k p p' = pickbool <$> _euclidBool n k <*> p <*> p'+ where pickbool True a _ = a+ pickbool False _ b = b+-} ++ -- euclid' :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a -- euclid' = tParam2 _euclidq' @@ -707,29 +712,29 @@ _euclidOff :: Int -> Int -> Int -> Pattern a -> Pattern a _euclidOff _ 0 _ _ = silence-_euclidOff n k s p = (((fromIntegral s)%(fromIntegral k)) `rotL`) (_euclid n k p)+_euclidOff n k s p = (rotL $ fromIntegral s%fromIntegral k) (_euclid n k p) euclidOffBool :: Pattern Int -> Pattern Int -> Pattern Int -> Pattern Bool -> Pattern Bool euclidOffBool = tParam3 _euclidOffBool _euclidOffBool :: Int -> Int -> Int -> Pattern Bool -> Pattern Bool _euclidOffBool _ 0 _ _ = silence-_euclidOffBool n k s p = (((fromIntegral s)%(fromIntegral k)) `rotL`) ((\a b -> if b then a else not a) <$> _euclidBool n k <*> p)+_euclidOffBool n k s p = ((fromIntegral s % fromIntegral k) `rotL`) ((\a b -> if b then a else not a) <$> _euclidBool n k <*> p) distrib :: [Pattern Int] -> Pattern a -> Pattern a distrib ps p = do p' <- sequence ps _distrib p' p _distrib :: [Int] -> Pattern a -> Pattern a-_distrib xs p = boolsToPat (foldr (distrib') (replicate (last xs) True) (reverse $ layers xs)) p+_distrib xs p = boolsToPat (foldr distrib' (replicate (last xs) True) (reverse $ layers xs)) p where distrib' :: [Bool] -> [Bool] -> [Bool] distrib' [] _ = []- distrib' (_:a) [] = False:(distrib' a [])- distrib' (True:a) (x:b) = x:(distrib' a b)- distrib' (False:a) (b) = False:(distrib' a b)+ distrib' (_:a) [] = False : distrib' a []+ distrib' (True:a) (x:b) = x : distrib' a b+ distrib' (False:a) b = False : distrib' a b layers = map bjorklund . (zip<*>tail)- boolsToPat a b' = (flip const) <$> (filterValues (== True) $ fastFromList $ a) <*> b'+ boolsToPat a b' = flip const <$> filterValues (== True) (fastFromList a) <*> b' {- | `euclidInv` fills in the blanks left by `e` -@@ -741,7 +746,8 @@ euclidInv = tParam2 _euclidInv _euclidInv :: Int -> Int -> Pattern a -> Pattern a-_euclidInv n k p = (flip const) <$> (filterValues (== False) $ fastFromList $ bjorklund (n,k)) <*> p+--_euclidInv n k p = flip const <$> filterValues (== False) (fastFromList $ bjorklund (n,k)) <*> p+_euclidInv n k a = fastcat $ fmap (bool a silence) $ bjorklund (n,k) index :: Real b => b -> Pattern b -> Pattern c -> Pattern c index sz indexpat pat =@@ -866,10 +872,10 @@ (drop i $ cycle $ map value es) | otherwise = zipWith (\(Event w p _) s -> Event w p s) es- (drop ((length es) - (abs i)) $ cycle $ map value es)+ (drop (length es - abs i) $ cycle $ map value es) wholeCycle (Arc s _) = Arc (sam s) (nextSam s) constrainEvents :: Arc -> [Event a] -> [Event a]- constrainEvents a es = catMaybes $ map (constrainEvent a) es+ constrainEvents a es = mapMaybe (constrainEvent a) es constrainEvent :: Arc -> Event a -> Maybe (Event a) constrainEvent a (Event w p v) = do@@ -883,7 +889,7 @@ segment = tParam _segment _segment :: Time -> Pattern a -> Pattern a-_segment n p = (_fast n $ pure (id)) <* p+_segment n p = _fast n (pure id) <* p -- | @discretise@: the old (deprecated) name for 'segment' discretise :: Pattern Time -> Pattern a -> Pattern a@@ -892,7 +898,7 @@ -- | @randcat ps@: does a @slowcat@ on the list of patterns @ps@ but -- randomises the order in which they are played. randcat :: [Pattern a] -> Pattern a-randcat ps = spread' (rotL) (_segment 1 $ ((%1) . fromIntegral) <$> (irand (length ps) :: Pattern Int)) (slowcat ps)+randcat ps = spread' rotL (_segment 1 $ (%1) . fromIntegral <$> (irand (length ps) :: Pattern Int)) (slowcat ps) -- @fromNote p@: converts a pattern of human-readable pitch names -- into pitch numbers. For example, @"cs2"@ will be parsed as C Sharp@@ -940,14 +946,14 @@ -} fit :: Int -> [a] -> Pattern Int -> Pattern a-fit perCycle xs p = (xs !!!) <$> (p {query = \st -> map ((\e -> (fmap (+ (pos e)) e))) (query p st)})- where pos e = perCycle * (floor $ start $ part e)+fit perCycle xs p = (xs !!!) <$> (p {query = map (\e -> fmap (+ pos e) e) . query p})+ where pos e = perCycle * floor (start $ part e) permstep :: RealFrac b => Int -> [a] -> Pattern b -> Pattern a-permstep nSteps things p = unwrap $ (\n -> fastFromList $ concatMap (\x -> replicate (fst x) (snd x)) $ zip (ps !! (floor (n * (fromIntegral $ (length ps - 1))))) things) <$> (_segment 1 p)+permstep nSteps things p = unwrap $ (\n -> fastFromList $ concatMap (\x -> replicate (fst x) (snd x)) $ zip (ps !! floor (n * fromIntegral (length ps - 1))) things) <$> _segment 1 p where ps = permsort (length things) nSteps deviance avg xs = sum $ map (abs . (avg-) . fromIntegral) xs- permsort n total = map fst $ sortBy (comparing snd) $ map (\x -> (x,deviance (fromIntegral total / (fromIntegral n :: Double)) x)) $ perms n total+ permsort n total = map fst $ sortOn snd $ map (\x -> (x,deviance (fromIntegral total / (fromIntegral n :: Double)) x)) $ perms n total perms 0 _ = [] perms 1 n = [[n]] perms n total = concatMap (\x -> map (x:) $ perms (n-1) (total-x)) [1 .. (total-(n-1))]@@ -962,29 +968,29 @@ substruct :: Pattern String -> Pattern b -> Pattern b substruct s p = p {query = f} where f st =- concatMap (\a' -> queryArc (compressArcTo a' p) a') $ (map whole $ query s st)+ concatMap ((\a' -> queryArc (compressArcTo a' p) a') . whole) (query s st) randArcs :: Int -> Pattern [Arc] randArcs n =- do rs <- mapM (\x -> (pure $ (toRational x)/(toRational n)) <~ choose [1 :: Int,2,3]) [0 .. (n-1)]+ do rs <- mapM (\x -> pure (toRational x / toRational n) <~ choose [1 :: Int,2,3]) [0 .. (n-1)] let rats = map toRational rs total = sum rats- pairs = pairUp $ accumulate $ map ((/total)) rats- return $ pairs+ pairs = pairUp $ accumulate $ map (/total) rats+ return pairs where pairUp [] = []- pairUp xs = (Arc 0 (head xs)):(pairUp' xs)+ pairUp xs = Arc 0 (head xs) : pairUp' xs pairUp' [] = []- pairUp' (_:[]) = []- pairUp' (a:_:[]) = [Arc a 1]- pairUp' (a:b:xs) = (Arc a b):(pairUp' (b:xs))+ pairUp' [_] = []+ pairUp' [a, _] = [Arc a 1]+ pairUp' (a:b:xs) = Arc a b: pairUp' (b:xs) -- TODO - what does this do? Something for @stripe@ .. randStruct :: Int -> Pattern Int randStruct n = splitQueries $ Pattern {nature = Digital, query = f}- where f st = map (\(a,b,c) -> (Event a (fromJust b) c)) $ filter (\(_,x,_) -> isJust x) $ as- where as = map (\(i, (Arc s' e')) ->- (((Arc (s' + sam s) (e' + sam s)),- subArc (Arc s e) (Arc (s' + sam s) (e' + sam s)), i))) $+ where f st = map (\(a,b,c) -> Event a (fromJust b) c) $ filter (\(_,x,_) -> isJust x) as+ where as = map (\(i, Arc s' e') ->+ (Arc (s' + sam s) (e' + sam s),+ subArc (Arc s e) (Arc (s' + sam s) (e' + sam s)), i)) $ enumerate $ value $ head $ queryArc (randArcs n) (Arc (sam s) (nextSam s)) (Arc s e) = arc st@@ -1035,20 +1041,15 @@ -} lindenmayer :: Int -> String -> String -> String lindenmayer _ _ [] = []-lindenmayer 1 r (c:cs) = (fromMaybe [c] $ lookup c $ parseLMRule' r)- ++ (lindenmayer 1 r cs)+lindenmayer 1 r (c:cs) = fromMaybe [c] (lookup c $ parseLMRule' r)+ ++ lindenmayer 1 r cs lindenmayer n r s = iterate (lindenmayer 1 r) s !! n {- | @lindenmayerI@ converts the resulting string into a a list of integers with @fromIntegral@ applied (so they can be used seamlessly where floats or rationals are required) -} lindenmayerI :: Num b => Int -> String -> String -> [b]-lindenmayerI n r s = fmap fromIntegral $ fmap digitToInt $ lindenmayer n r s---- support for fit'-unwrap' :: Pattern (Pattern a) -> Pattern a-unwrap' pp = pp {query = \st -> query (stack $ map scalep (query pp st)) st}- where scalep ev = compressArc (whole ev) $ value ev+lindenmayerI n r s = fmap (fromIntegral . digitToInt) $ lindenmayer n r s {-| Removes events from second pattern that don't start during an event from first.@@ -1094,13 +1095,13 @@ -- | TODO: refactor towards union enclosingArc :: [Arc] -> Arc-enclosingArc [] = (Arc 0 1)+enclosingArc [] = Arc 0 1 enclosingArc as = Arc (minimum (map start as)) (maximum (map stop as)) stretch :: Pattern a -> Pattern a -- TODO - should that be whole or part? stretch p = splitQueries $ p {query = q}- where q st = query (zoomArc (enclosingArc $ map whole $ query p (st {arc = (Arc (sam s) (nextSam s))})) p) st+ where q st = query (zoomArc (enclosingArc $ map whole $ query p (st {arc = Arc (sam s) (nextSam s)})) p) st where s = start $ arc st {- | `fit'` is a generalization of `fit`, where the list is instead constructed by using another integer pattern to slice up a given pattern. The first argument is the number of cycles of that latter pattern to use when slicing. It's easier to understand this with a few examples:@@ -1121,11 +1122,11 @@ -} fit' :: Pattern Time -> Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a-fit' cyc n from to p = unwrap' $ fit n mapMasks to+fit' cyc n from to p = squeezeJoin $ fit n mapMasks to where mapMasks = [stretch $ mask (const True <$> filterValues (== i) from') p' | i <- [0..n-1]]- p' = density cyc $ p- from' = density cyc $ from+ p' = density cyc p+ from' = density cyc from {-| @chunk n f p@ treats the given pattern @p@ as having @n@ chunks, and applies the function @f@ to one of those sections per cycle, running from left to right. @@ -1134,7 +1135,7 @@ @ -} chunk :: Int -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b-chunk n f p = cat [withinArc (Arc (i%(fromIntegral n)) ((i+1)%(fromIntegral n))) f p | i <- [0..(fromIntegral n)-1]]+chunk n f p = cat [withinArc (Arc (i % fromIntegral n) ((i+1) % fromIntegral n)) f p | i <- [0 .. fromIntegral n - 1]] {- chunk n f p = do i <- _slow (toRational n) $ run (fromIntegral n)@@ -1149,7 +1150,7 @@ -} chunk' :: Integral a => a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b chunk' n f p = do i <- _slow (toRational n) $ rev $ run (fromIntegral n)- withinArc (Arc (i%(fromIntegral n)) ((i+)1%(fromIntegral n))) f p+ withinArc (Arc (i % fromIntegral n) ((i+)1 % fromIntegral n)) f p -- deprecated (renamed to chunk') runWith' :: Integral a => a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b@@ -1165,10 +1166,10 @@ loopFirst p = splitQueries $ p {query = f} where f st = map (\(Event w p' v) ->- (Event (plus w) (plus p') v)) $+ Event (plus w) (plus p') v) $ query p (st {arc = minus $ arc st}) where minus = fmap (subtract (sam s))- plus = fmap (+ (sam s))+ plus = fmap (+ sam s) s = start $ arc st timeLoop :: Pattern Time -> Pattern a -> Pattern a@@ -1188,7 +1189,7 @@ toScale' :: Num a => Int -> [a] -> Pattern Int -> Pattern a toScale' o s = fmap noteInScale where octave x = x `div` length s- noteInScale x = (s !!! x) + (fromIntegral $ o * octave x)+ noteInScale x = (s !!! x) + fromIntegral (o * octave x) toScale :: Num a => [a] -> Pattern Int -> Pattern a toScale = toScale' 12@@ -1205,54 +1206,55 @@ {- | `cycleChoose` is like `choose` but only picks a new item from the list once each cycle -}-cycleChoose::[a] -> Pattern a-cycleChoose xs = Pattern {nature = Digital, query = q}- where q (State {arc = Arc s e}) = [Event (Arc s e) (Arc s e) (xs!!(floor $ dlen*(ctrand s)))]- dlen = fromIntegral $ length xs- ctrand s = (timeToRand :: Time -> Double) $ fromIntegral $ (floor :: Time -> Int) $ sam s+cycleChoose :: [a] -> Pattern a+cycleChoose = segment 1 . choose +{- | Internal function used by shuffle and scramble -}+_rearrangeWith :: Pattern Int -> Int -> Pattern a -> Pattern a+_rearrangeWith ipat n pat = innerJoin $ (\i -> _fast nT $ repeatCycles n $ pats !! i) <$> ipat+ where+ pats = map (\i -> zoom (fromIntegral i / nT, fromIntegral (i+1) / nT) pat) [0 .. (n-1)]+ nT :: Time+ nT = fromIntegral n+ {- | `shuffle n p` evenly divides one cycle of the pattern `p` into `n` parts, and returns a random permutation of the parts each cycle. For example, `shuffle 3 "a b c"` could return `"a b c"`, `"a c b"`, `"b a c"`, `"b c a"`, `"c a b"`, or `"c b a"`. But it will **never** return `"a a a"`, because that is not a permutation of the parts. -}-shuffle :: Int -> Pattern a -> Pattern a-shuffle n pat = innerJoin $ (\i -> _fast nT $ repeatCycles n $ pats !! i) <$> randrun n- where- pats = map (\i -> zoom ((fromIntegral i)/nT, (fromIntegral (i+1))/nT) pat) [0 .. (n-1)]- nT :: Time- nT = fromIntegral n+shuffle :: Pattern Int -> Pattern a -> Pattern a+shuffle = tParam _shuffle +_shuffle :: Int -> Pattern a -> Pattern a+_shuffle n = _rearrangeWith (randrun n) n+ {- | `scramble n p` is like `shuffle` but randomly selects from the parts of `p` instead of making permutations. For example, `scramble 3 "a b c"` will randomly select 3 parts from `"a"` `"b"` and `"c"`, possibly repeating a single part. -}-scramble :: Int -> Pattern a -> Pattern a-scramble n pat = innerJoin $ (\i -> _fast nT $ repeatCycles n $ pats !! i) <$> randn- where- randn = _segment nT $ irand n- pats = map (\i -> zoom ((fromIntegral i)/nT, (fromIntegral (i+1))/nT) pat) [0 .. (n-1)]- nT :: Time- nT = fromIntegral n+scramble :: Pattern Int -> Pattern a -> Pattern a+scramble = tParam _scramble +_scramble :: Int -> Pattern a -> Pattern a+_scramble n = _rearrangeWith (_segment (fromIntegral n) $ irand n) n randrun :: Int -> Pattern Int randrun 0 = silence randrun n' = splitQueries $ Pattern Digital (\(State a@(Arc s _) _) -> events a $ sam s)- where events a seed = catMaybes $ map toEvent $ zip arcs shuffled+ where events a seed = mapMaybe toEv $ zip arcs shuffled where shuffled = map snd $ sortOn fst $ zip rs [0 .. (n'-1)] rs = timeToRands seed n'- arcs = map (\(s,e) -> Arc s e) $ zip fractions (tail fractions)- fractions = map (+ (sam $ start a)) $ [0, 1/(fromIntegral n') .. 1]- toEvent (a',v) = do a'' <- subArc a a'- return $ Event a' a'' v+ arcs = zipWith Arc fractions (tail fractions)+ fractions = map (+ (sam $ start a)) [0, 1 / fromIntegral n' .. 1]+ toEv (a',v) = do a'' <- subArc a a'+ return $ Event a' a'' v ur :: Time -> Pattern String -> [(String, Pattern a)] -> [(String, Pattern a -> Pattern a)] -> Pattern a-ur t outer_p ps fs = _slow t $ unwrap $ adjust <$> (timedValues $ (getPat . split) <$> outer_p)- where split s = wordsBy (==':') s+ur t outer_p ps fs = _slow t $ unwrap $ adjust <$> timedValues (getPat . split <$> outer_p)+ where split = wordsBy (==':') getPat (s:xs) = (match s, transform xs) -- TODO - check this really can't happen.. getPat _ = error "can't happen?"@@ -1261,26 +1263,26 @@ adjust (a, (p, f)) = f a p transform (x:_) a = transform' x a transform _ _ = id- transform' str (Arc s e) p = s `rotR` (inside (pure $ 1/(e-s)) (matchF str) p)+ transform' str (Arc s e) p = s `rotR` inside (pure $ 1/(e-s)) (matchF str) p matchF str = fromMaybe id $ lookup str fs timedValues = withEvent (\(Event a a' v) -> Event a a' (a,v)) inhabit :: [(String, Pattern a)] -> Pattern String -> Pattern a-inhabit ps p = unwrap' $ (\s -> fromMaybe silence $ lookup s ps) <$> p+inhabit ps p = squeezeJoin $ (\s -> fromMaybe silence $ lookup s ps) <$> p {- | @spaceOut xs p@ repeats a pattern @p@ at different durations given by the list of time values in @xs@ -} spaceOut :: [Time] -> Pattern a -> Pattern a-spaceOut xs p = _slow (toRational $ sum xs) $ stack $ map (\a -> compressArc a p) $ spaceArcs+spaceOut xs p = _slow (toRational $ sum xs) $ stack $ map (`compressArc` p) spaceArcs where markOut :: Time -> [Time] -> [Arc] markOut _ [] = []- markOut offset (x:xs') = (Arc offset (offset+x)):(markOut (offset+x) xs')- spaceArcs = map (\(Arc a b) -> (Arc (a/s) (b/s))) $ markOut 0 xs+ markOut offset (x:xs') = Arc offset (offset+x):markOut (offset+x) xs'+ spaceArcs = map (\(Arc a b) -> Arc (a/s) (b/s)) $ markOut 0 xs s = sum xs -- | @flatpat@ takes a Pattern of lists and pulls the list elements as -- separate Events flatpat :: Pattern [a] -> Pattern a-flatpat p = p {query = \st -> (concatMap (\(Event b b' xs) -> map (\x -> (Event b b' x)) xs) $ query p st)}+flatpat p = p {query = concatMap (\(Event b b' xs) -> map (Event b b') xs) . query p} -- | @layer@ takes a Pattern of lists and pulls the list elements as -- separate Events@@ -1298,15 +1300,14 @@ do a'' <- subArc (Arc newS newE) a' return (Event (Arc newS newE) a'' v)- where newS = s + (dur*(fromIntegral n))+ where newS = s + (dur * fromIntegral n) newE = newS + dur- dur = (e - s) / (fromIntegral d)+ dur = (e - s) / fromIntegral d -- | Shorthand alias for arpeggiate arpg :: Pattern a -> Pattern a arpg = arpeggiate - arpWith :: ([EventF (ArcF Time) a] -> [EventF (ArcF Time) b]) -> Pattern a -> Pattern b arpWith f p = withEvents munge p where munge es = concatMap (spreadOut . f) (groupBy (\a b -> whole a == whole b) es)@@ -1315,9 +1316,9 @@ do a'' <- subArc (Arc newS newE) a' return (Event (Arc newS newE) a'' v)- where newS = s + (dur*(fromIntegral n))+ where newS = s + (dur * fromIntegral n) newE = newS + dur- dur = (e - s) / (fromIntegral d)+ dur = (e - s) / fromIntegral d arp :: Pattern String -> Pattern a -> Pattern a arp = tParam _arp@@ -1334,16 +1335,16 @@ ("down&up", \x -> reverse x ++ x), ("converge", converge), ("diverge", reverse . converge),- ("disconverge", \x -> converge x ++ (tail $ reverse $ converge x)),+ ("disconverge", \x -> converge x ++ tail (reverse $ converge x)), ("pinkyup", pinkyup), ("pinkyupdown", \x -> init (pinkyup x) ++ init (reverse $ pinkyup x)), ("thumbup", thumbup), ("thumbupdown", \x -> init (thumbup x) ++ init (reverse $ thumbup x)) ] converge [] = []- converge (x:xs) = x:(converge' xs)+ converge (x:xs) = x : converge' xs converge' [] = []- converge' xs = (last xs):(converge $ init xs)+ converge' xs = last xs : converge (init xs) pinkyup xs = concatMap (:[pinky]) $ init xs where pinky = last xs thumbup xs = concatMap (\x -> [thumb,x]) $ tail xs@@ -1383,12 +1384,12 @@ -- patterns. sew :: Pattern Bool -> Pattern a -> Pattern a -> Pattern a sew stitch p1 p2 = overlay (const <$> p1 <* a) (const <$> p2 <* b)- where a = filterValues (id) stitch- b = filterValues (not . id) stitch+ where a = filterValues id stitch+ b = filterValues not stitch stutter :: Integral i => i -> Time -> Pattern a -> Pattern a-stutter n t p = stack $ map (\i -> (t * (fromIntegral i)) `rotR` p) [0 .. (n-1)]+stutter n t p = stack $ map (\i -> (t * fromIntegral i) `rotR` p) [0 .. (n-1)] echo, triple, quad, double :: Time -> Pattern a -> Pattern a echo = stutter (2 :: Int)@@ -1452,7 +1453,7 @@ -} jux' :: [t -> Pattern ControlMap] -> t -> Pattern ControlMap-jux' fs p = stack $ map (\n -> ((fs !! n) p) |+ P.pan (pure $ fromIntegral n / fromIntegral l)) [0 .. l-1]+jux' fs p = stack $ map (\n -> (fs !! n) p |+ P.pan (pure $ fromIntegral n / fromIntegral l)) [0 .. l-1] where l = length fs -- | Multichannel variant of `jux`, _not sure what it does_@@ -1483,7 +1484,7 @@ juxBy n f p = stack [p |+ P.pan 0.5 |- P.pan (n/2), f $ p |+ P.pan 0.5 |+ P.pan (n/2)] pick :: String -> Int -> String-pick name n = name ++ ":" ++ (show n)+pick name n = name ++ ":" ++ show n -- samples "jvbass [~ latibro] [jvbass [latibro jvbass]]" ((1%2) `rotL` slow 6 "[1 6 8 7 3]") @@ -1491,7 +1492,7 @@ samples p p' = pick <$> p <*> p' samples' :: Applicative f => f String -> f Int -> f String-samples' p p' = (flip pick) <$> p' <*> p+samples' p p' = flip pick <$> p' <*> p {- scrumple :: Time -> Pattern a -> Pattern a -> Pattern a@@ -1510,7 +1511,7 @@ stackwith :: Unionable a => Pattern a -> [Pattern a] -> Pattern a stackwith p ps | null ps = silence- | otherwise = stack $ map (\(i, p') -> p' # (((fromIntegral i) % l) `rotL` p)) (zip [0::Int ..] ps)+ | otherwise = stack $ map (\(i, p') -> p' # ((fromIntegral i % l) `rotL` p)) (zip [0::Int ..] ps) where l = fromIntegral $ length ps {-@@ -1535,7 +1536,7 @@ _range from to p _range :: (Functor f, Num b) => b -> b -> f b -> f b-_range from to p = ((+ from) . (* (to-from))) <$> p+_range from to p = (+ from) . (* (to-from)) <$> p {- | `rangex` is an exponential version of `range`, good for using with frequencies. Do *not* use negative numbers or zero as arguments! -}@@ -1559,24 +1560,24 @@ | otherwise = silence steps :: [(String, String)] -> Pattern String-steps = stack . map (\(a,b) -> step a b)+steps = stack . map (uncurry step) -- | like `step`, but allows you to specify an array of strings to use for 0,1,2... step' :: [String] -> String -> Pattern String step' ss cs = fastcat $ map f cs where f c | c == 'x' = pure $ head ss- | isDigit c = pure $ ss!!(digitToInt c)+ | isDigit c = pure $ ss !! digitToInt c | otherwise = silence ghost'' :: Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-ghost'' a f p = superimpose (((a*2.5) `rotR`) . f) $ superimpose (((a*1.5) `rotR`) . f) $ p+ghost'' a f p = superimpose (((a*2.5) `rotR`) . f) $ superimpose (((a*1.5) `rotR`) . f) p ghost' :: Time -> Pattern ControlMap -> Pattern ControlMap ghost' a p = ghost'' a ((|*| P.gain (pure 0.7)) . (|> P.end (pure 0.2)) . (|*| P.speed (pure 1.25))) p ghost :: Pattern ControlMap -> Pattern ControlMap-ghost p = ghost' 0.125 p+ghost = ghost' 0.125 {- | tabby - A more literal weaving than the `weave` function, give number@@ -1589,16 +1590,16 @@ ] where n = fromIntegral nInt- weft = concatMap (\_ -> [[0..n-1],(reverse [0..n-1])]) [0 .. (n `div` 2) - 1]+ weft = concatMap (const [[0..n-1], reverse [0..n-1]]) [0 .. (n `div` 2) - 1] warp = transpose weft thread xs p'' = _slow (n%1) $ fastcat $ map (\i -> zoomArc (Arc (i%n) ((i+1)%n)) p'') (concat xs) weftP = thread weft p' warpP = thread warp p- maskedWeft = mask (every 2 rev $ _fast ((n)%2) $ fastCat [silence, pure True]) weftP- maskedWarp = mask (every 2 rev $ _fast ((n)%2) $ fastCat [pure True, silence]) warpP+ maskedWeft = mask (every 2 rev $ _fast (n % 2) $ fastCat [silence, pure True]) weftP+ maskedWarp = mask (every 2 rev $ _fast (n % 2) $ fastCat [pure True, silence]) warpP _select :: Double -> [Pattern a] -> Pattern a-_select f ps = ps !! (floor $ (max 0 $ min 1 f) * (fromIntegral $ length ps - 1))+_select f ps = ps !! floor (max 0 (min 1 f) * fromIntegral (length ps - 1)) -- | chooses between a list of patterns, using a pattern of floats (from 0-1) select :: Pattern Double -> [Pattern a] -> Pattern a@@ -1610,7 +1611,7 @@ selectF pf ps p = innerJoin $ (\f -> _selectF f ps p) <$> pf _selectF :: Double -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a-_selectF f ps p = (ps !! (floor $ (max 0 $ min 0.999999 f) * (fromIntegral $ length ps))) p+_selectF f ps p = (ps !! floor (max 0 (min 0.999999 f) * fromIntegral (length ps))) p -- | @contrast p f f' p'@ splits controlpattern @p'@ in two, applying -- the function @f@ to one and @f'@ to the other. This depends on@@ -1644,8 +1645,8 @@ -> ControlPattern -> Pattern a contrastRange = contrastBy f- where f (VI s, VI e) (VI v) = v >= s && v <= e - f (VF s, VF e) (VF v) = v >= s && v <= e + where f (VI s, VI e) (VI v) = v >= s && v <= e+ f (VF s, VF e) (VF v) = v >= s && v <= e f (VS s, VS e) (VS v) = v == s && v == e f _ _ = False @@ -1656,7 +1657,7 @@ -- | Like @contrast@, but one function is given, and applied to events -- with controls which don't match. unfix :: (ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern -> ControlPattern-unfix f = contrast id f+unfix = contrast id fixRange :: (ControlPattern -> Pattern ControlMap) -> Pattern (Map.Map String (Value, Value))@@ -1668,7 +1669,7 @@ -> Pattern (Map.Map String (Value, Value)) -> ControlPattern -> Pattern ControlMap-unfixRange f = contrastRange id f+unfixRange = contrastRange id -- | limit values in a Pattern (or other Functor) to n equally spaced -- divisions of 1.@@ -1682,13 +1683,13 @@ -- | Serialises a pattern so there's only one event playing at any one -- time, making it 'monophonic'. Events which start/end earlier are given priority. mono :: Pattern a -> Pattern a-mono p = Pattern Digital $ \(State a cm) -> flatten $ (query p) (State a cm) where+mono p = Pattern Digital $ \(State a cm) -> flatten $ query p (State a cm) where flatten :: [Event a] -> [Event a]- flatten = catMaybes . map constrainPart . truncateOverlaps . sortBy (comparing whole)+ flatten = mapMaybe constrainPart . truncateOverlaps . sortOn whole truncateOverlaps [] = []- truncateOverlaps (e:es) = e:(truncateOverlaps $ catMaybes $ map (snip e) es)- snip a b | (start $ whole b) >= (stop $ whole a) = Just b- | (stop $ whole b) <= (stop $ whole a) = Nothing+ truncateOverlaps (e:es) = e : truncateOverlaps (mapMaybe (snip e) es)+ snip a b | start (whole b) >= stop (whole a) = Just b+ | stop (whole b) <= stop (whole a) = Nothing | otherwise = Just b {whole = Arc (stop $ whole a) (stop $ whole b)} constrainPart :: Event a -> Maybe (Event a) constrainPart e = do a <- subArc (whole e) (part e)@@ -1718,11 +1719,21 @@ , part = queryA' , value = value e + ((v - value e) * pc)} ]- pc | (delta' $ whole e) == 0 = 0- | otherwise = fromRational $ (eventPartStart e - wholeStart e) / (delta' $ whole e)+ pc | delta' (whole e) == 0 = 0+ | otherwise = fromRational $ (eventPartStart e - wholeStart e) / delta' (whole e) delta' a = stop a - start a monoP = mono p -- | Looks up values from a list of tuples, in order to swap values in the given pattern swap :: Eq a => [(a, b)] -> Pattern a -> Pattern b-swap things p = filterJust $ (\x -> lookup x things) <$> p+swap things p = filterJust $ (`lookup` things) <$> p++{- @coat@ | + applies a function to a pattern and cats the resulting pattern,+ then continues applying the function until the depth is reached+ this can be used to create a pattern that wanders away from + the original pattern by continually adding random numbers+ d1 $ note (scale "hexDorian" mutateBy (+ (range -1 1 $ irand 2)) 8 $ "0 1 . 2 3 4") # s "gtr"+-}+soak :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a+soak depth f pattern = cat $ take depth $ iterate f pattern
src/Sound/Tidal/Utils.hs view
@@ -6,7 +6,7 @@ mapBoth f (a,b) = (f a, f b) mapPartTimes :: (a -> a) -> ((a,a),(a,a)) -> ((a,a),(a,a))-mapPartTimes f part = mapBoth (mapBoth f) part+mapPartTimes f = mapBoth (mapBoth f) mapFst :: (a -> b) -> (a, c) -> (b, c) mapFst f (x,y) = (f x,y)@@ -24,7 +24,7 @@ removeCommon :: Eq a => [a] -> [a] -> ([a],[a]) removeCommon [] bs = ([],bs) removeCommon as [] = (as,[])-removeCommon (a:as) bs | elem a bs = removeCommon as (delete a bs)+removeCommon (a:as) bs | a `elem` bs = removeCommon as (delete a bs) | otherwise = (a:as',bs') where (as',bs') = removeCommon as bs @@ -51,7 +51,7 @@ accumulate :: Num t => [t] -> [t] accumulate = accumulate' 0 where accumulate' _ [] = []- accumulate' n (a:xs) = (n+a):(accumulate' (n+a) xs)+ accumulate' n (a:xs) = (n+a) : accumulate' (n+a) xs {- | enumerate a list of things
src/Sound/Tidal/Version.hs view
@@ -1,4 +1,4 @@- module Sound.Tidal.Version where +tidal_version :: String tidal_version = "1.0.7"
test/Sound/Tidal/PatternTest.hs view
@@ -194,12 +194,12 @@ (Event (Arc (2 % 3) (1 % 1)) (Arc (2 % 3) (1 % 1)) "e") ] - describe "unwrapSqueeze" $ do+ describe "squeezeJoin" $ do it "compresses cycles to fit outer 'whole' timearc of event" $ do let a = fastCat [pure "a", pure "b"] b = fastCat [pure "c", pure "d", pure "e"] pp = fastCat [pure a, pure b]- queryArc (unwrapSqueeze pp) (Arc 0 1)+ queryArc (squeezeJoin pp) (Arc 0 1) `shouldBe` [(Event (Arc (0 % 1) (1 % 4)) (Arc (0 % 1) (1 % 4)) ("a" :: String)), (Event (Arc (1 % 4) (1 % 2)) (Arc (1 % 4) (1 % 2)) "b"), (Event (Arc (1 % 2) (2 % 3)) (Arc (1 % 2) (2 % 3)) "c"),
+ test/Sound/Tidal/ScalesTest.hs view
@@ -0,0 +1,318 @@+{-# LANGUAGE OverloadedStrings #-}++module Sound.Tidal.ScalesTest where++import TestUtils+import Test.Microspec++import Prelude hiding ((<*), (*>))++import Sound.Tidal.Scales+import Sound.Tidal.Pattern++run :: Microspec ()+run =+ describe "Sound.Tidal.Scales" $ do+ describe "scale" $ do+ describe "5 note scales" $ do+ let twoOctavesOf5NoteScale = "0 1 2 3 4 5 6 7 8 9"+ it "can transform notes correctly over 2 octaves - minPent" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "minPent" twoOctavesOf5NoteScale)+ ("0 3 5 7 10 12 15 17 19 22"::Pattern Int)+ it "can transform notes correctly over 2 octaves - majPent" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "majPent" twoOctavesOf5NoteScale)+ ("0 2 4 7 9 12 14 16 19 21"::Pattern Int)+ it "can transform notes correctly over 2 octaves - ritusen" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "ritusen" twoOctavesOf5NoteScale)+ ("0 2 5 7 9 12 14 17 19 21"::Pattern Int)+ it "can transform notes correctly over 2 octaves - egyptian" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "egyptian" twoOctavesOf5NoteScale)+ ("0 2 5 7 10 12 14 17 19 22"::Pattern Int)+ it "can transform notes correctly over 2 octaves - kumai" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "kumai" twoOctavesOf5NoteScale)+ ("0 2 3 7 9 12 14 15 19 21"::Pattern Int)+ it "can transform notes correctly over 2 octaves - hirajoshi" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "hirajoshi" twoOctavesOf5NoteScale)+ ("0 2 3 7 8 12 14 15 19 20"::Pattern Int)+ it "can transform notes correctly over 2 octaves - iwato" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "iwato" twoOctavesOf5NoteScale)+ ("0 1 5 6 10 12 13 17 18 22"::Pattern Int)+ it "can transform notes correctly over 2 octaves - chinese" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "chinese" twoOctavesOf5NoteScale)+ ("0 4 6 7 11 12 16 18 19 23"::Pattern Int)+ it "can transform notes correctly over 2 octaves - indian" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "indian" twoOctavesOf5NoteScale)+ ("0 4 5 7 10 12 16 17 19 22"::Pattern Int)+ it "can transform notes correctly over 2 octaves - pelog" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "pelog" twoOctavesOf5NoteScale)+ ("0 1 3 7 8 12 13 15 19 20"::Pattern Int)+ it "can transform notes correctly over 2 octaves - prometheus" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "prometheus" twoOctavesOf5NoteScale)+ ("0 2 4 6 11 12 14 16 18 23"::Pattern Int)+ it "can transform notes correctly over 2 octaves - scriabin" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "scriabin" twoOctavesOf5NoteScale)+ ("0 1 4 7 9 12 13 16 19 21"::Pattern Int)+ it "can transform notes correctly over 2 octaves - gong" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "gong" twoOctavesOf5NoteScale)+ ("0 2 4 7 9 12 14 16 19 21"::Pattern Int)+ it "can transform notes correctly over 2 octaves - shang" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "shang" twoOctavesOf5NoteScale)+ ("0 2 5 7 10 12 14 17 19 22"::Pattern Int)+ it "can transform notes correctly over 2 octaves - jiao" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "jiao" twoOctavesOf5NoteScale)+ ("0 3 5 8 10 12 15 17 20 22"::Pattern Int)+ it "can transform notes correctly over 2 octaves - zhi" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "zhi" twoOctavesOf5NoteScale)+ ("0 2 5 7 9 12 14 17 19 21"::Pattern Int)+ it "can transform notes correctly over 2 octaves - yu" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "yu" twoOctavesOf5NoteScale)+ ("0 3 5 7 10 12 15 17 19 22"::Pattern Int)+ describe "6 note scales" $ do+ let twoOctavesOf6NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11"+ it "can transform notes correctly over 2 octaves - whole" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "whole" twoOctavesOf6NoteScale)+ ("0 2 4 6 8 10 12 14 16 18 20 22"::Pattern Int)+ it "can transform notes correctly over 2 octaves - wholetone" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "wholetone" twoOctavesOf6NoteScale)+ (Sound.Tidal.Scales.scale "whole" twoOctavesOf6NoteScale :: Pattern Int)+ it "can transform notes correctly over 2 octaves - augmented" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "augmented" twoOctavesOf6NoteScale)+ ("0 3 4 7 8 11 12 15 16 19 20 23"::Pattern Int)+ it "can transform notes correctly over 2 octaves - augmented2" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "augmented2" twoOctavesOf6NoteScale)+ ("0 1 4 5 8 9 12 13 16 17 20 21"::Pattern Int)+ it "can transform notes correctly over 2 octaves - hexMajor7" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "hexMajor7" twoOctavesOf6NoteScale)+ ("0 2 4 7 9 11 12 14 16 19 21 23"::Pattern Int)+ it "can transform notes correctly over 2 octaves - hexPhrygian" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "hexPhrygian" twoOctavesOf6NoteScale)+ ("0 1 3 5 8 10 12 13 15 17 20 22"::Pattern Int)+ it "can transform notes correctly over 2 octaves - hexDorian" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "hexDorian" twoOctavesOf6NoteScale)+ ("0 2 3 5 7 10 12 14 15 17 19 22"::Pattern Int)+ it "can transform notes correctly over 2 octaves - hexSus" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "hexSus" twoOctavesOf6NoteScale)+ ("0 2 5 7 9 10 12 14 17 19 21 22"::Pattern Int)+ it "can transform notes correctly over 2 octaves - hexMajor6" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "hexMajor6" twoOctavesOf6NoteScale)+ ("0 2 4 5 7 9 12 14 16 17 19 21"::Pattern Int)+ it "can transform notes correctly over 2 octaves - hexAeolian" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "hexAeolian" twoOctavesOf6NoteScale)+ ("0 3 5 7 8 10 12 15 17 19 20 22"::Pattern Int)+ describe "7 note scales" $ do+ let twoOctavesOf7NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13"+ it "can transform notes correctly over 2 octaves - major" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "major" twoOctavesOf7NoteScale)+ ("0 2 4 5 7 9 11 12 14 16 17 19 21 23"::Pattern Int)+ it "can transform notes correctly over 2 octaves - ionian" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "ionian" twoOctavesOf7NoteScale)+ (Sound.Tidal.Scales.scale "major" twoOctavesOf7NoteScale :: Pattern Int)+ it "can transform notes correctly over 2 octaves - dorian" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "dorian" twoOctavesOf7NoteScale)+ ("0 2 3 5 7 9 10 12 14 15 17 19 21 22"::Pattern Int)+ it "can transform notes correctly over 2 octaves - aeolian" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "aeolian" twoOctavesOf7NoteScale)+ ("0 2 3 5 7 8 10 12 14 15 17 19 20 22"::Pattern Int)+ it "can transform notes correctly over 2 octaves - aeolian" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "minor" twoOctavesOf7NoteScale)+ (Sound.Tidal.Scales.scale "aeolian" twoOctavesOf7NoteScale::Pattern Int)+ it "can transform notes correctly over 2 octaves - minor" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "minor" twoOctavesOf7NoteScale)+ (Sound.Tidal.Scales.scale "aeolian" twoOctavesOf7NoteScale::Pattern Int)+ it "can transform notes correctly over 2 octaves - locrian" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "locrian" twoOctavesOf7NoteScale)+ ("0 1 3 5 6 8 10 12 13 15 17 18 20 22"::Pattern Int)+ it "can transform notes correctly over 2 octaves - harmonicMinor" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "harmonicMinor" twoOctavesOf7NoteScale)+ ("0 2 3 5 7 8 11 12 14 15 17 19 20 23"::Pattern Int)+ it "can transform notes correctly over 2 octaves - harmonicMajor" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "harmonicMajor" twoOctavesOf7NoteScale)+ ("0 2 4 5 7 8 11 12 14 16 17 19 20 23"::Pattern Int)+ it "can transform notes correctly over 2 octaves - melodicMinor" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "melodicMinor" twoOctavesOf7NoteScale)+ ("0 2 3 5 7 9 11 12 14 15 17 19 21 23"::Pattern Int)+ it "can transform notes correctly over 2 octaves - melodicMinorDesc" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "melodicMinorDesc" twoOctavesOf7NoteScale)+ (Sound.Tidal.Scales.scale "minor" twoOctavesOf7NoteScale::Pattern Int)+ it "can transform notes correctly over 2 octaves - melodicMajor" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "melodicMajor" twoOctavesOf7NoteScale)+ ("0 2 4 5 7 8 10 12 14 16 17 19 20 22"::Pattern Int)+ it "can transform notes correctly over 2 octaves - bartok" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "bartok" twoOctavesOf7NoteScale)+ (Sound.Tidal.Scales.scale "melodicMajor" twoOctavesOf7NoteScale::Pattern Int)+ it "can transform notes correctly over 2 octaves - hindu" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "hindu" twoOctavesOf7NoteScale)+ (Sound.Tidal.Scales.scale "melodicMajor" twoOctavesOf7NoteScale::Pattern Int)+ it "can transform notes correctly over 2 octaves - todi" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "todi" twoOctavesOf7NoteScale)+ ("0 1 3 6 7 8 11 12 13 15 18 19 20 23"::Pattern Int)+ it "can transform notes correctly over 2 octaves - purvi" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "purvi" twoOctavesOf7NoteScale)+ ("0 1 4 6 7 8 11 12 13 16 18 19 20 23"::Pattern Int)+ it "can transform notes correctly over 2 octaves - marva" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "marva" twoOctavesOf7NoteScale)+ ("0 1 4 6 7 9 11 12 13 16 18 19 21 23"::Pattern Int)+ it "can transform notes correctly over 2 octaves - bhairav" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "bhairav" twoOctavesOf7NoteScale)+ ("0 1 4 5 7 8 11 12 13 16 17 19 20 23"::Pattern Int)+ it "can transform notes correctly over 2 octaves - ahirbhairav" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "ahirbhairav" twoOctavesOf7NoteScale)+ ("0 1 4 5 7 9 10 12 13 16 17 19 21 22"::Pattern Int)+ it "can transform notes correctly over 2 octaves - superLocrian" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "superLocrian" twoOctavesOf7NoteScale)+ ("0 1 3 4 6 8 10 12 13 15 16 18 20 22"::Pattern Int)+ it "can transform notes correctly over 2 octaves - romanianMinor" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "romanianMinor" twoOctavesOf7NoteScale)+ ("0 2 3 6 7 9 10 12 14 15 18 19 21 22"::Pattern Int)+ it "can transform notes correctly over 2 octaves - hungarianMinor" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "hungarianMinor" twoOctavesOf7NoteScale)+ ("0 2 3 6 7 8 11 12 14 15 18 19 20 23"::Pattern Int)+ it "can transform notes correctly over 2 octaves - neapolitanMinor" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "neapolitanMinor" twoOctavesOf7NoteScale)+ ("0 1 3 5 7 8 11 12 13 15 17 19 20 23"::Pattern Int)+ it "can transform notes correctly over 2 octaves - enigmatic" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "enigmatic" twoOctavesOf7NoteScale)+ ("0 1 4 6 8 10 11 12 13 16 18 20 22 23"::Pattern Int)+ it "can transform notes correctly over 2 octaves - spanish" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "spanish" twoOctavesOf7NoteScale)+ ("0 1 4 5 7 8 10 12 13 16 17 19 20 22"::Pattern Int)+ it "can transform notes correctly over 2 octaves - leadingWhole" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "leadingWhole" twoOctavesOf7NoteScale)+ ("0 2 4 6 8 10 11 12 14 16 18 20 22 23"::Pattern Int)+ it "can transform notes correctly over 2 octaves - lydianMinor" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "lydianMinor" twoOctavesOf7NoteScale)+ ("0 2 4 6 7 8 10 12 14 16 18 19 20 22"::Pattern Int)+ it "can transform notes correctly over 2 octaves - neapolitanMajor" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "neapolitanMajor" twoOctavesOf7NoteScale)+ ("0 1 3 5 7 9 11 12 13 15 17 19 21 23"::Pattern Int)+ it "can transform notes correctly over 2 octaves - locrianMajor" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "locrianMajor" twoOctavesOf7NoteScale)+ ("0 2 4 5 6 8 10 12 14 16 17 18 20 22"::Pattern Int)+ describe "8 note scales" $ do+ let twoOctavesOf8NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15"+ it "can transform notes correctly over 2 octaves - diminished" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "diminished" twoOctavesOf8NoteScale)+ ("0 1 3 4 6 7 9 10 12 13 15 16 18 19 21 22"::Pattern Int)+ it "can transform notes correctly over 2 octaves - octatonic" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "octatonic" twoOctavesOf8NoteScale)+ (Sound.Tidal.Scales.scale "diminished" twoOctavesOf8NoteScale::Pattern Int)+ it "can transform notes correctly over 2 octaves - diminished2" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "diminished2" twoOctavesOf8NoteScale)+ ("0 2 3 5 6 8 9 11 12 14 15 17 18 20 21 23"::Pattern Int)+ it "can transform notes correctly over 2 octaves - octatonic2" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "octatonic2" twoOctavesOf8NoteScale)+ (Sound.Tidal.Scales.scale "diminished2" twoOctavesOf8NoteScale::Pattern Int)+ describe "modes of limited transposition" $ do+ let twoOctavesOf6NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11"+ let twoOctavesOf8NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15"+ let twoOctavesOf9NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17"+ let twoOctavesOf10NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19"+ it "can transform notes correctly over 2 octaves - messiaen1" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "messiaen1" twoOctavesOf6NoteScale)+ (Sound.Tidal.Scales.scale "wholetone" twoOctavesOf6NoteScale::Pattern Int)+ it "can transform notes correctly over 2 octaves - messiaen2" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "messiaen2" twoOctavesOf8NoteScale)+ (Sound.Tidal.Scales.scale "diminished" twoOctavesOf8NoteScale::Pattern Int)+ it "can transform notes correctly over 2 octaves - messiaen3" $ do+ -- tone, semitone, semitone, tone, semitone, semitone, tone, semitone, semitone+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "messiaen3" twoOctavesOf9NoteScale)+ ("0 2 3 4 6 7 8 10 11 12 14 15 16 18 19 20 22 23"::Pattern Int)+ it "can transform notes correctly over 2 octaves - messiaen4" $ do+ -- semitone, semitone, minor third, semitone, semitone, semitone, minor third, semitone+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "messiaen4" twoOctavesOf8NoteScale)+ ("0 1 2 5 6 7 8 11 12 13 14 17 18 19 20 23"::Pattern Int)+ it "can transform notes correctly over 2 octaves - messiaen5" $ do+ -- semitone, major third, semitone, semitone, major third, semitone+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "messiaen5" twoOctavesOf6NoteScale)+ ("0 1 5 6 7 11 12 13 17 18 19 23"::Pattern Int)+ it "can transform notes correctly over 2 octaves - messiaen6" $ do+ -- tone, tone, semitone, semitone, tone, tone, semitone, semitone+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "messiaen6" twoOctavesOf8NoteScale)+ ("0 2 4 5 6 8 10 11 12 14 16 17 18 20 22 23"::Pattern Int)+ it "can transform notes correctly over 2 octaves - messiaen7" $ do+ -- semitone, semitone, semitone, tone, semitone, semitone, semitone, semitone, tone, semitone+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "messiaen7" twoOctavesOf10NoteScale)+ ("0 1 2 3 5 6 7 8 9 11 12 13 14 15 17 18 19 20 21 23"::Pattern Int)+ describe "12 note scales" $ do+ let twoOctavesOf12NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23"+ it "can transform notes correctly over 2 octaves - chromatic" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "chromatic" twoOctavesOf12NoteScale)+ (twoOctavesOf12NoteScale::Pattern Int)+ describe "edge cases" $ do+ it "responds to unknown scales by mapping to octaves" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "ergaerv" "0 1 2 3 4")+ ("0 12 24 36 48"::Pattern Int)+ it "correctly maps negative numbers" $ do+ compareP (Arc 0 1)+ (Sound.Tidal.Scales.scale "major" "0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13")+ ("0 -1 -3 -5 -7 -8 -10 -12 -13 -15 -17 -19 -20 -22 "::Pattern Int)+
test/Sound/Tidal/UITest.hs view
@@ -13,6 +13,7 @@ import Sound.Tidal.Control import Sound.Tidal.Core import Sound.Tidal.Params+import Sound.Tidal.ParseBP import Sound.Tidal.Pattern import Sound.Tidal.UI @@ -58,6 +59,14 @@ in compareP overTimeSpan testMe expectedResult + it "does nothing when set at 0% probability -- const" $ do+ let+ overTimeSpan = (Arc 0 2)+ testMe = sometimesBy 0 (const $ s "cp") (s "bd*8")+ expectedResult = s "bd*8"+ in+ compareP overTimeSpan testMe expectedResult+ it "applies the 'rev' function when set at 100% probability" $ do let overTimeSpan = (Arc 0 1)@@ -169,3 +178,62 @@ compareP (Arc 0 1) (euclidFull 3 8 "bd" silence) ("bd(3,8)" :: Pattern String)+ + describe "soak" $ do+ it "applies a transform and then appends the result -- addition" $ do+ compareP (Arc 0 3)+ (soak 3 (+ 1) "4 ~ 0 1")+ (cat ["4 ~ 0 1"::Pattern Int,"5 ~ 1 2"::Pattern Int,"6 ~ 2 3"::Pattern Int])+ it "applies a transform and then appends the result -- slow" $ do+ compareP (Arc 0 7)+ (soak 3 (slow 2) "4 ~ 0 1")+ (cat ["4 ~ 0 1"::Pattern Int, slow 2 "4 ~ 0 1"::Pattern Int, slow 4 "4 ~ 0 1"::Pattern Int])+ it "applies a transform and then appends the result -- addition patterns" $ do+ compareP (Arc 0 3)+ (soak 3 (+ "1 2 3") "1 1")+ (cat ["1 1"::Pattern Int,"2 [3 3] 4"::Pattern Int,"3 [5 5] 7"::Pattern Int])++ describe "euclid" $ do+ it "matches examples in Toussaint's paper" $ do+ sequence_ $ map (\(a,b) -> it b $ compareP (Arc 0 1) a (parseBP_E b))+ ([(euclid 1 2 "x", "x ~"),+ (euclid 1 3 "x", "x ~ ~"),+ (euclid 1 4 "x", "x ~ ~ ~"),+ (euclid 4 12 "x", "x ~ ~ x ~ ~ x ~ ~ x ~ ~"),+ (euclid 2 5 "x", "x ~ x ~ ~"),+ -- (euclid 3 4 "x", "x ~ x x"), -- Toussaint is wrong..+ (euclid 3 4 "x", "x x x ~"), -- correction+ (euclid 3 5 "x", "x ~ x ~ x"),+ (euclid 3 7 "x", "x ~ x ~ x ~ ~"),+ (euclid 3 8 "x", "x ~ ~ x ~ ~ x ~"),+ (euclid 4 7 "x", "x ~ x ~ x ~ x"),+ (euclid 4 9 "x", "x ~ x ~ x ~ x ~ ~"),+ (euclid 4 11 "x", "x ~ ~ x ~ ~ x ~ ~ x ~"),+ -- (euclid 5 6 "x", "x ~ x x x x"), -- Toussaint is wrong..+ (euclid 5 6 "x", "x x x x x ~"), -- correction+ (euclid 5 7 "x", "x ~ x x ~ x x"),+ (euclid 5 8 "x", "x ~ x x ~ x x ~"),+ (euclid 5 9 "x", "x ~ x ~ x ~ x ~ x"),+ (euclid 5 11 "x", "x ~ x ~ x ~ x ~ x ~ ~"),+ (euclid 5 12 "x", "x ~ ~ x ~ x ~ ~ x ~ x ~"),+ -- (euclid 5 16 "x", "x ~ ~ x ~ ~ x ~ ~ x ~ ~ x ~ ~ ~ ~"), -- Toussaint is wrong..+ (euclid 5 16 "x", "x ~ ~ x ~ ~ x ~ ~ x ~ ~ x ~ ~ ~"), -- correction+ -- (euclid 7 8 "x", "x ~ x x x x x x"), -- Toussaint is wrong..+ (euclid 7 8 "x", "x x x x x x x ~"), -- Correction+ (euclid 7 12 "x", "x ~ x x ~ x ~ x x ~ x ~"),+ (euclid 7 16 "x", "x ~ ~ x ~ x ~ x ~ ~ x ~ x ~ x ~"),+ (euclid 9 16 "x", "x ~ x x ~ x ~ x ~ x x ~ x ~ x ~"),+ (euclid 11 24 "x", "x ~ ~ x ~ x ~ x ~ x ~ x ~ ~ x ~ x ~ x ~ x ~ x ~"),+ (euclid 13 24 "x", "x ~ x x ~ x ~ x ~ x ~ x ~ x x ~ x ~ x ~ x ~ x ~")+ ] :: [(Pattern String, String)])++ describe "wedge" $ do+ it "should not freeze tidal amount is 1" $ do+ compareP (Arc 0 1)+ (wedge (1) (s "ho ho:2 ho:3 hc") (rev $ s "ho ho:2 ho:3 hc"))+ (s "ho ho:2 ho:3 hc")+ it "should not freeze tidal amount is 0" $ do+ compareP (Arc 0 1)+ (wedge (0) (s "ho ho:2 ho:3 hc") (rev $ s "ho ho:2 ho:3 hc"))+ (rev $ s "ho ho:2 ho:3 hc")+
test/Test.hs view
@@ -7,6 +7,7 @@ import Sound.Tidal.ParseTest import Sound.Tidal.PatternTest import Sound.Tidal.ControlTest+import Sound.Tidal.ScalesTest import Sound.Tidal.UITest import Sound.Tidal.UtilsTest @@ -17,5 +18,6 @@ Sound.Tidal.ParseTest.run Sound.Tidal.PatternTest.run Sound.Tidal.ControlTest.run+ Sound.Tidal.ScalesTest.run Sound.Tidal.UITest.run Sound.Tidal.UtilsTest.run
tidal.cabal view
@@ -1,5 +1,5 @@ name: tidal-version: 1.0.7+version: 1.0.8 synopsis: Pattern language for improvised music -- description: homepage: http://tidalcycles.org/@@ -19,9 +19,6 @@ Description: Tidal is a domain specific language for live coding pattern. library- if impl(ghc == 8.4.4)- cpp-options: -DTIDAL_SEMIGROUP- ghc-options: -Wall hs-source-dirs: src@@ -47,9 +44,10 @@ Sound.Tidal.Utils Sound.Tidal.Version Sound.Tidal.EspGrid-+ other-modules: Sound.Tidal.MiniTidal.TH+ Sound.Tidal.MiniTidal.Token Build-depends:- base < 5+ base >=4.8 && <5 , containers < 0.7 , colour < 2.4 , hosc < 0.18@@ -59,8 +57,9 @@ , mwc-random < 0.15 , vector < 0.13 , bifunctors < 5.6- , transformers < 0.5.6- + , transformers < 0.5.7+ , template-haskell >= 2.10.0.0 && < 3+ if !impl(ghc >= 8.4.1) build-depends: semigroups == 0.18.* @@ -75,6 +74,7 @@ Sound.Tidal.MiniTidalTest Sound.Tidal.ParseTest Sound.Tidal.PatternTest+ Sound.Tidal.ScalesTest Sound.Tidal.UITest Sound.Tidal.UtilsTest TestUtils
tidal.el view
@@ -95,50 +95,50 @@ import Sound.Tidal.Context tidal <- startMulti [superdirtTarget {oLatency = 0.1, oAddress = \"127.0.0.1\", oPort = 57120}] (defaultConfig {cFrameTimespan = 1/20, cCtrlListen = True}) let p = streamReplace tidal- hush = streamHush tidal- list = streamList tidal- mute = streamMute tidal- unmute = streamUnmute tidal- solo = streamSolo tidal- unsolo = streamUnsolo tidal- once = streamOnce tidal False- asap = streamOnce tidal True- nudgeAll = streamNudgeAll tidal- all = streamAll tidal- resetCycles = streamResetCycles tidal- setcps = asap . cps- xfade i = transition tidal (Sound.Tidal.Transition.xfadeIn 4) i- xfadeIn i t = transition tidal (Sound.Tidal.Transition.xfadeIn t) i- histpan i t = transition tidal (Sound.Tidal.Transition.histpan t) i- wait i t = transition tidal (Sound.Tidal.Transition.wait t) i- waitT i f t = transition tidal (Sound.Tidal.Transition.waitT f t) i- jump i = transition tidal (Sound.Tidal.Transition.jump) i- jumpIn i t = transition tidal (Sound.Tidal.Transition.jumpIn t) i- jumpIn' i t = transition tidal (Sound.Tidal.Transition.jumpIn' t) i- jumpMod i t = transition tidal (Sound.Tidal.Transition.jumpMod t) i- mortal i lifespan release = transition tidal (Sound.Tidal.Transition.mortal lifespan release) i- interpolate i = transition tidal (Sound.Tidal.Transition.interpolate) i- interpolateIn i t = transition tidal (Sound.Tidal.Transition.interpolateIn t) i- clutch i = transition tidal (Sound.Tidal.Transition.clutch) i- clutchIn i t = transition tidal (Sound.Tidal.Transition.clutchIn t) i- anticipate i = transition tidal (Sound.Tidal.Transition.anticipate) i- anticipateIn i t = transition tidal (Sound.Tidal.Transition.anticipateIn t) i- d1 = p 1- d2 = p 2 -- . (|< orbit 1)- d3 = p 3 -- . (|< orbit 2)- d4 = p 4 -- . (|< orbit 3)- d5 = p 5 -- . (|< orbit 4)- d6 = p 6 -- . (|< orbit 5)- d7 = p 7 -- . (|< orbit 6)- d8 = p 8 -- . (|< orbit 7)- d9 = p 9 -- . (|< orbit 8)- d10 = p 10- d11 = p 11- d12 = p 12- d13 = p 13- d14 = p 14- d15 = p 15- d16 = p 16+let hush = streamHush tidal+let list = streamList tidal+let mute = streamMute tidal+let unmute = streamUnmute tidal+let solo = streamSolo tidal+let unsolo = streamUnsolo tidal+let once = streamOnce tidal False+let asap = streamOnce tidal True+let nudgeAll = streamNudgeAll tidal+let all = streamAll tidal+let resetCycles = streamResetCycles tidal+let setcps = asap . cps+let xfade i = transition tidal (Sound.Tidal.Transition.xfadeIn 4) i+let xfadeIn i t = transition tidal (Sound.Tidal.Transition.xfadeIn t) i+let histpan i t = transition tidal (Sound.Tidal.Transition.histpan t) i+let wait i t = transition tidal (Sound.Tidal.Transition.wait t) i+let waitT i f t = transition tidal (Sound.Tidal.Transition.waitT f t) i+let jump i = transition tidal (Sound.Tidal.Transition.jump) i+let jumpIn i t = transition tidal (Sound.Tidal.Transition.jumpIn t) i+let jumpIn' i t = transition tidal (Sound.Tidal.Transition.jumpIn' t) i+let jumpMod i t = transition tidal (Sound.Tidal.Transition.jumpMod t) i+let mortal i lifespan release = transition tidal (Sound.Tidal.Transition.mortal lifespan release) i+let interpolate i = transition tidal (Sound.Tidal.Transition.interpolate) i+let interpolateIn i t = transition tidal (Sound.Tidal.Transition.interpolateIn t) i+let clutch i = transition tidal (Sound.Tidal.Transition.clutch) i+let clutchIn i t = transition tidal (Sound.Tidal.Transition.clutchIn t) i+let anticipate i = transition tidal (Sound.Tidal.Transition.anticipate) i+let anticipateIn i t = transition tidal (Sound.Tidal.Transition.anticipateIn t) i+let d1 = p 1+let d2 = p 2 . (|< orbit 1)+let d3 = p 3 . (|< orbit 2)+let d4 = p 4 . (|< orbit 3)+let d5 = p 5 . (|< orbit 4)+let d6 = p 6 . (|< orbit 5)+let d7 = p 7 . (|< orbit 6)+let d8 = p 8 . (|< orbit 7)+let d9 = p 9 . (|< orbit 8)+let d10 = p 10+let d11 = p 11+let d12 = p 12+let d13 = p 13+let d14 = p 14+let d15 = p 15+let d16 = p 16 ") (tidal-send-string ":set prompt \"tidal> \"") )