diff --git a/Sound/Tidal/Context.hs b/Sound/Tidal/Context.hs --- a/Sound/Tidal/Context.hs +++ b/Sound/Tidal/Context.hs @@ -7,6 +7,7 @@ import Data.Monoid as C import Sound.Tidal.Parse as C import Sound.Tidal.Pattern as C +import Sound.Tidal.PatternList as C import Sound.Tidal.Stream as C import Sound.Tidal.Dirt as C import Sound.Tidal.Strategies as C diff --git a/Sound/Tidal/Dirt.hs b/Sound/Tidal/Dirt.hs --- a/Sound/Tidal/Dirt.hs +++ b/Sound/Tidal/Dirt.hs @@ -13,6 +13,7 @@ import Data.Maybe import Data.Fixed import Data.Ratio +import Data.List (elemIndex) import Sound.Tidal.Stream import Sound.Tidal.OscStream @@ -337,3 +338,7 @@ {- | Copies the @n@ parameter to the @orbit@ parameter, so different sound variants or notes go to different orbits in SuperDirt. -} nToOrbit = copyParam n_p orbit_p + +{- | Maps the sample or synth names to different @orbit@s, using indexes from the given list. E.g. @soundToOrbit ["bd", "sn", "cp"] $ sound "bd [cp sn]"@ would cause the bd, sn and cp smamples to be sent to orbit 0, 1, 2 respectively.-} +soundToOrbit :: [String] -> ParamPattern -> ParamPattern +soundToOrbit sounds p = follow s_p orbit_p ((\s -> fromMaybe 0 $ elemIndex s sounds) <$>) p diff --git a/Sound/Tidal/Params.hs b/Sound/Tidal/Params.hs --- a/Sound/Tidal/Params.hs +++ b/Sound/Tidal/Params.hs @@ -321,6 +321,7 @@ pit2 = pitch2 pit3 = pitch3 por = portamento +rel = release sag = sagogo scl = sclaves scp = sclap diff --git a/Sound/Tidal/Parse.hs b/Sound/Tidal/Parse.hs --- a/Sound/Tidal/Parse.hs +++ b/Sound/Tidal/Parse.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase, GADTs #-} module Sound.Tidal.Parse where @@ -21,27 +21,30 @@ import Sound.Tidal.Time (Arc, Time) -- | AST representation of patterns -data TPat a - = TPat_Atom a - | TPat_Density Time (TPat a) - -- We keep this distinct from '_density because of divide-by-zero: - | TPat_Slow Time (TPat a) - | TPat_Zoom Arc (TPat a) - | TPat_DegradeBy Double (TPat a) - | TPat_Silence - | TPat_Foot - | TPat_Cat [TPat a] - | TPat_Overlay (TPat a) (TPat a) - | TPat_ShiftL Time (TPat a) - -- | TPat_E Int Int (TPat a) - | TPat_pE (TPat Int) (TPat Int) (TPat Integer) (TPat a) - deriving (Show) +data TPat a where + TPat_Atom :: Parseable a => a -> TPat a + TPat_Density :: Parseable a => Time -> (TPat a) -> (TPat a) + -- We keep this distinct from '_density because of divide-by-zero: + TPat_Slow :: Parseable a => Time -> TPat a -> TPat a + TPat_Zoom :: Parseable a => Arc -> TPat a -> TPat a + TPat_DegradeBy :: Parseable a => Double -> TPat a -> TPat a + TPat_Silence :: Parseable a => TPat a + TPat_Foot :: Parseable a => TPat a + TPat_Enum :: Parseable a => TPat a + TPat_EnumFromTo :: Parseable a => TPat a -> TPat a -> TPat a + TPat_Cat :: Parseable a => [TPat a] -> TPat a + TPat_Overlay :: Parseable a => TPat a -> TPat a -> TPat a + TPat_ShiftL :: Parseable a => Time -> TPat a -> TPat a + -- TPat_E Int Int (TPat a) + TPat_pE :: Parseable a => TPat Int -> TPat Int -> TPat Integer -> TPat a -> TPat a -instance Monoid (TPat a) where +-- deriving (Show) + +instance Parseable a => Monoid (TPat a) where mempty = TPat_Silence mappend = TPat_Overlay -toPat :: TPat a -> Pattern a +toPat :: Parseable a => TPat a -> Pattern a toPat = \case TPat_Atom x -> atom x TPat_Density t x -> _density t $ toPat x @@ -55,35 +58,60 @@ TPat_pE n k s thing -> unwrap $ eoff <$> toPat n <*> toPat k <*> toPat s <*> pure (toPat thing) TPat_Foot -> error "Can't happen, feet (.'s) only used internally.." + TPat_Enum -> error "Can't happen, enums (..'s) only used internally.." + TPat_EnumFromTo a b -> unwrap $ fromTo <$> (toPat a) <*> (toPat b) + -- TPat_EnumFromThenTo a b c -> unwrap $ fromThenTo <$> (toPat a) <*> (toPat b) <*> (toPat c) p :: Parseable a => String -> Pattern a p = toPat . parseTPat class Parseable a where parseTPat :: String -> TPat a + fromTo :: a -> a -> Pattern a + fromThenTo :: a -> a -> a -> Pattern a instance Parseable Double where parseTPat = parseRhythm pDouble + fromTo a b = enumFromTo' a b + fromThenTo a b c = enumFromThenTo' a b c instance Parseable String where parseTPat = parseRhythm pVocable + fromTo a b = listToPat [a,b] + fromThenTo a b c = listToPat [a,b,c] instance Parseable Bool where parseTPat = parseRhythm pBool + fromTo a b = listToPat [a,b] + fromThenTo a b c = listToPat [a,b,c] instance Parseable Int where parseTPat = parseRhythm pIntegral + fromTo a b = enumFromTo' a b + fromThenTo a b c = enumFromThenTo' a b c instance Parseable Integer where parseTPat s = parseRhythm pIntegral s + fromTo a b = enumFromTo' a b + fromThenTo a b c = enumFromThenTo' a b c instance Parseable Rational where parseTPat = parseRhythm pRational + fromTo a b = enumFromTo' a b + fromThenTo a b c = enumFromThenTo' a b c -type ColourD = Colour Double +enumFromTo' a b | a > b = listToPat $ reverse $ enumFromTo b a + | otherwise = listToPat $ enumFromTo a b +enumFromThenTo' a b c | a > c = listToPat $ reverse $ enumFromThenTo c (c + (a-b)) a + | otherwise = listToPat $ enumFromThenTo a b c + +type ColourD = Colour Double + instance Parseable ColourD where parseTPat = parseRhythm pColour + fromTo a b = listToPat [a,b] + fromThenTo a b c = listToPat [a,b,c] instance (Parseable a) => IsString (Pattern a) where fromString = toPat . parseTPat @@ -140,21 +168,35 @@ ) (return $ p s) -parseRhythm :: Parser (TPat a) -> String -> TPat a +parseRhythm :: Parseable a => Parser (TPat a) -> String -> TPat a parseRhythm f input = either (const TPat_Silence) id $ parse (pSequence f') "" input where f' = f <|> do symbol "~" "rest" return TPat_Silence -pSequenceN :: Parser (TPat a) -> GenParser Char () (Int, TPat a) +pSequenceN :: Parseable a => Parser (TPat a) -> GenParser Char () (Int, TPat a) pSequenceN f = do spaces -- d <- pDensity - ps <- many $ pPart f + ps <- many $ do a <- pPart f + do Text.ParserCombinators.Parsec.try $ symbol "-" + b <- pPart f + return [TPat_EnumFromTo (TPat_Cat a) (TPat_Cat b)] + <|> return a <|> do symbol "." return [TPat_Foot] let ps' = TPat_Cat $ map TPat_Cat $ splitFeet $ concat ps return (length ps, ps') +{- +expandEnum :: Parseable t => Maybe (TPat t) -> [TPat t] -> [TPat t] +expandEnum a [] = [a] +expandEnum (Just a) (TPat_Enum:b:ps) = (TPat_EnumFromTo a b) : (expandEnum Nothing ps) +-- ignore ..s in other places +expandEnum a (TPat_Enum:ps) = expandEnum a ps +expandEnum (Just a) (b:ps) = a:(expandEnum b (Just c) ps) +expandEnum Nothing (c:ps) = expandEnum (Just c) ps +-} + -- could use splitOn here but `TPat a` isn't a member of `EQ`.. splitFeet :: [TPat t] -> [[TPat t]] splitFeet [] = [] @@ -164,14 +206,14 @@ takeFoot (TPat_Foot:ps) = ([], ps) takeFoot (p:ps) = (\(a,b) -> (p:a,b)) $ takeFoot ps -pSequence :: Parser (TPat a) -> GenParser Char () (TPat a) +pSequence :: Parseable a => Parser (TPat a) -> GenParser Char () (TPat a) pSequence f = do (_, p) <- pSequenceN f return p -pSingle :: Parser (TPat a) -> Parser (TPat a) +pSingle :: Parseable a => Parser (TPat a) -> Parser (TPat a) pSingle f = f >>= pRand >>= pMult -pPart :: Parser (TPat a) -> Parser [TPat a] +pPart :: Parseable a => Parser (TPat a) -> Parser [TPat a] pPart f = do part <- pSingle f <|> pPolyIn f <|> pPolyOut f part <- pE part part <- pRand part @@ -181,12 +223,12 @@ spaces return $ parts -pPolyIn :: Parser (TPat a) -> Parser (TPat a) +pPolyIn :: Parseable a => Parser (TPat a) -> Parser (TPat a) pPolyIn f = do ps <- brackets (pSequence f `sepBy` symbol ",") spaces pMult $ mconcat ps -pPolyOut :: Parser (TPat a) -> Parser (TPat a) +pPolyOut :: Parseable a => Parser (TPat a) -> Parser (TPat a) pPolyOut f = do ps <- braces (pSequenceN f `sepBy` symbol ",") spaces base <- do char '%' @@ -233,7 +275,7 @@ i <- integer return $ applySign s $ fromIntegral i -pIntegral :: Integral i => Parser (TPat i) +pIntegral :: Parseable a => Integral a => Parser (TPat a) pIntegral = TPat_Atom <$> parseIntNote parseNote :: Integral a => Parser a @@ -266,7 +308,7 @@ colour <- readColourName name "known colour" return $ TPat_Atom colour -pMult :: TPat a -> Parser (TPat a) +pMult :: Parseable a => TPat a -> Parser (TPat a) pMult thing = do char '*' spaces r <- pRatio @@ -281,13 +323,13 @@ -pRand :: TPat a -> Parser (TPat a) +pRand :: Parseable a => TPat a -> Parser (TPat a) pRand thing = do char '?' spaces return $ TPat_DegradeBy 0.5 thing <|> return thing -pE :: TPat a -> Parser (TPat a) +pE :: Parseable a => TPat a -> Parser (TPat a) pE thing = do (n,k,s) <- parens (pair) pure $ TPat_pE n k s thing <|> return thing @@ -307,7 +349,7 @@ eoff n k s p = ((s%(fromIntegral k)) `rotL`) (e n k p) -- TPat_ShiftL (s%(fromIntegral k)) (TPat_E n k p) -pReplicate :: TPat a -> Parser [TPat a] +pReplicate :: Parseable a => TPat a -> Parser [TPat a] pReplicate thing = do extras <- many $ do char '!' -- if a number is given (without a space)slow 2 $ fast @@ -320,7 +362,7 @@ return (thing:concat extras) -pStretch :: TPat a -> Parser [TPat a] +pStretch :: Parseable a => TPat a -> Parser [TPat a] pStretch thing = do char '@' n <- ((read <$> many1 digit) <|> return 1) diff --git a/Sound/Tidal/Pattern.hs b/Sound/Tidal/Pattern.hs --- a/Sound/Tidal/Pattern.hs +++ b/Sound/Tidal/Pattern.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans -fno-warn-name-shadowing #-} module Sound.Tidal.Pattern where import Control.Applicative --- import Data.Monoid +import Data.Monoid import Data.Fixed import Data.List import Data.Maybe @@ -30,13 +30,89 @@ data Pattern a = Pattern {arc :: Arc -> [Event a]} deriving Typeable -#define INSTANCE_Eq -#define INSTANCE_Ord -#define INSTANCE_Enum +noOv :: String -> a +noOv meth = error $ meth ++ ": No overloading" -#define APPLICATIVE Pattern -#include "ApplicativeNumeric-inc.hs" +instance Eq (Pattern a) where + (==) = noOv "(==)" +instance Ord a => Ord (Pattern a) where + min = liftA2 min + max = liftA2 max + +instance Num a => Num (Pattern a) where + negate = fmap negate + (+) = liftA2 (+) + (*) = liftA2 (*) + fromInteger = pure . fromInteger + abs = fmap abs + signum = fmap signum + +instance Enum a => Enum (Pattern a) where + succ = fmap succ + pred = fmap pred + toEnum = pure . toEnum + fromEnum = noOv "fromEnum" + enumFrom = noOv "enumFrom" + enumFromThen = noOv "enumFromThen" + enumFromTo = noOv "enumFromTo" + enumFromThenTo = noOv "enumFromThenTo" + +instance (Num a, Ord a) => Real (Pattern a) where + toRational = noOv "toRational" + +instance (Integral a) => Integral (Pattern a) where + quot = liftA2 quot + rem = liftA2 rem + div = liftA2 div + mod = liftA2 mod + toInteger = noOv "toInteger" + x `quotRem` y = (x `quot` y, x `rem` y) + x `divMod` y = (x `div` y, x `mod` y) + +instance (Fractional a) => Fractional (Pattern a) where + recip = fmap recip + fromRational = pure . fromRational + +instance (Floating a) => Floating (Pattern a) where + pi = pure pi + sqrt = fmap sqrt + exp = fmap exp + log = fmap log + sin = fmap sin + cos = fmap cos + asin = fmap asin + atan = fmap atan + acos = fmap acos + sinh = fmap sinh + cosh = fmap cosh + asinh = fmap asinh + atanh = fmap atanh + acosh = fmap acosh + +instance (RealFrac a) => RealFrac (Pattern a) where + properFraction = noOv "properFraction" + truncate = noOv "truncate" + round = noOv "round" + ceiling = noOv "ceiling" + floor = noOv "floor" + +instance (RealFloat a) => RealFloat (Pattern a) where + floatRadix = noOv "floatRadix" + floatDigits = noOv "floatDigits" + floatRange = noOv "floatRange" + decodeFloat = noOv "decodeFloat" + encodeFloat = ((.).(.)) pure encodeFloat + exponent = noOv "exponent" + significand = noOv "significand" + scaleFloat n = fmap (scaleFloat n) + isNaN = noOv "isNaN" + isInfinite = noOv "isInfinite" + isDenormalized = noOv "isDenormalized" + isNegativeZero = noOv "isNegativeZero" + isIEEE = noOv "isIEEE" + atan2 = liftA2 atan2 + -- | @show (p :: Pattern)@ returns a text string representing the -- event values active during the first cycle of the given pattern. instance (Show a) => Show (Pattern a) where @@ -201,6 +277,9 @@ listToPat :: [a] -> Pattern a listToPat = fastcat . map atom +patToList :: Pattern a -> [a] +patToList p = map (thd') $ sortBy (\a b -> compare (snd' a) (snd' b)) $ filter ((\x -> x >= 0 && x < 1) . fst . snd' ) (arc p (0,1)) + -- | @maybeListToPat@ is similar to @listToPat@, but allows values to -- be optional using the @Maybe@ type, so that @Nothing@ results in -- gaps in the pattern. @@ -235,6 +314,8 @@ fast :: Pattern Time -> Pattern a -> Pattern a fast = temporalParam _density +_fast = _density + fast' :: Pattern Time -> Pattern a -> Pattern a fast' = temporalParam' _density @@ -342,7 +423,9 @@ -- | @rev p@ returns @p@ with the event positions in each cycle -- reversed (or mirrored). rev :: Pattern a -> Pattern a -rev p = splitQueries $ Pattern $ \a -> mapArcs mirrorArc (arc p (mirrorArc a)) +rev p = splitQueries $ Pattern $ \a -> map makeWholeAbsolute $ mapSnds' mirrorArc $ map makeWholeRelative (arc p (mirrorArc a)) + where makeWholeRelative ((s,e), part@(s',e'), v) = ((s'-s, e-e'), part, v) + makeWholeAbsolute ((s,e), part@(s',e'), v) = ((s'-e,e'+s), part, v) -- | @palindrome p@ applies @rev@ to @p@ every other cycle, so that -- the pattern alternates between forwards and backwards. @@ -911,11 +994,11 @@ splitQueries :: Pattern a -> Pattern a splitQueries p = Pattern $ \a -> concatMap (arc p) $ arcCycles a -{- | Truncates a pattern so that only a fraction of the pattern is played. -The following example plays only the first three quarters of the pattern: +{- | @trunc@ truncates a pattern so that only a fraction of the pattern is played. +The following example plays only the first quarter of the pattern: @ -d1 $ trunc 0.75 $ sound "bd sn*2 cp hh*4 arpy bd*2 cp bd*2" +d1 $ trunc 0.25 $ sound "bd sn*2 cp hh*4 arpy bd*2 cp bd*2" @ -} trunc :: Pattern Time -> Pattern a -> Pattern a @@ -924,6 +1007,18 @@ _trunc :: Time -> Pattern a -> Pattern a _trunc t = compress (0,t) . zoom (0,t) +{- | @linger@ is similar to `trunc` but the truncated part of the pattern loops until the end of the cycle + +@ +d1 $ linger 0.25 $ sound "bd sn*2 cp hh*4 arpy bd*2 cp bd*2" +@ +-} +linger :: Pattern Time -> Pattern a -> Pattern a +linger = temporalParam _linger + +_linger :: Time -> Pattern a -> Pattern a +_linger n p = _density (1/n) $ zoom (0,n) p + {- | Plays a portion of a pattern, specified by a beginning and end arc of time. The new resulting pattern is played over the time period of the original pattern: @@ -1129,12 +1224,13 @@ -- | @discretise n p@: 'samples' the pattern @p@ at a rate of @n@ -- events per cycle. Useful for turning a continuous pattern into a -- discrete one. -discretise :: Pattern Time -> Pattern a -> Pattern a -discretise n p = (density n $ atom (id)) <*> p -discretise' :: Time -> Pattern a -> Pattern a -discretise' n p = (_density n $ atom (id)) <*> p +discretise :: Time -> Pattern a -> Pattern a +discretise n p = (_density n $ atom (id)) <*> p +discretise' = discretise +_discretise = discretise + -- | @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 @@ -1205,7 +1301,7 @@ -- | @substruct a b@: similar to @struct@, but each event in pattern @a@ gets replaced with pattern @b@, compressed to fit the timespan of the event. substruct :: Pattern String -> Pattern b -> Pattern b -substruct s p = filterStartInRange $ Pattern $ f +substruct s p = Pattern $ f where f a = concatMap (\a' -> arc (compressTo a' p) a') $ (map fst' $ arc s a) compressTo (s,e) p = compress (cyclePos s, e-(sam s)) p diff --git a/Sound/Tidal/PatternList.hs b/Sound/Tidal/PatternList.hs new file mode 100644 --- /dev/null +++ b/Sound/Tidal/PatternList.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE OverloadedLists, TypeFamilies #-} + +module Sound.Tidal.PatternList where + +import Sound.Tidal.Pattern +import GHC.Exts( IsList(..) ) + +instance (Ord a) => IsList (Pattern a) where + type Item (Pattern a) = a + fromList = listToPat + toList = patToList + diff --git a/Sound/Tidal/Stream.hs b/Sound/Tidal/Stream.hs --- a/Sound/Tidal/Stream.hs +++ b/Sound/Tidal/Stream.hs @@ -295,7 +295,7 @@ withS :: Param -> (Pattern String -> Pattern String) -> ParamPattern -> ParamPattern withS = with -follow :: ParamType a => Param -> Param -> (Pattern a -> Pattern a) -> ParamPattern -> ParamPattern +follow :: (ParamType a, ParamType b) => Param -> Param -> (Pattern a -> Pattern b) -> ParamPattern -> ParamPattern follow source dest f p = p # (makeP dest $ f (get source p)) -- follow :: ParamType a => Param -> (Pattern a -> ParamPattern) -> ParamPattern -> ParamPattern diff --git a/Sound/Tidal/Version.hs b/Sound/Tidal/Version.hs --- a/Sound/Tidal/Version.hs +++ b/Sound/Tidal/Version.hs @@ -1,4 +1,4 @@ module Sound.Tidal.Version where -tidal_version = "0.9.1" +tidal_version = "0.9.3" diff --git a/tests/test.hs b/tests/test.hs new file mode 100644 --- /dev/null +++ b/tests/test.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Test.Tasty +-- import Test.Tasty.SmallCheck as SC +-- import Test.Tasty.QuickCheck as QC +import Test.Tasty.HUnit + +import Data.List +import Data.Ord + +import Sound.Tidal.Context + +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" [basic1, + patternsOfPatterns + ] + +basic1 = testGroup "fast / slow" + [ + testCase "silence" $ same16 (fast 1.1 silence) (silence :: Pattern Double), + testCase "fast" $ same16 silence (silence :: Pattern Double), + testCase "fast" $ same16 "bd*128" (rep 128 "bd") + ] + +patternsOfPatterns = + testGroup "patterns of patterns" + [ + testCase "decimal density" $ same16 (_discretise 0.25 saw) (discretise 0.25 saw) + ] + +rep :: Int -> String -> Pattern String +rep n v = p $ intercalate " " $ take n $ repeat v + +sameN :: (Eq a, Show a) => String -> Time -> Pattern a -> Pattern a -> Assertion +sameN s n a b = assertEqual s (arc a (0,n)) (arc b (0,n)) + +same16 :: (Eq a, Show a) => Pattern a -> Pattern a -> Assertion +same16 = sameN "for 16 cycles," 16 + diff --git a/tidal.cabal b/tidal.cabal --- a/tidal.cabal +++ b/tidal.cabal @@ -1,5 +1,5 @@ name: tidal -version: 0.9.2 +version: 0.9.3 synopsis: Pattern language for improvised music -- description: homepage: http://tidalcycles.org/ @@ -11,7 +11,7 @@ Copyright: (c) Tidal contributors, 2017 category: Sound build-type: Simple -cabal-version: >=1.6 +cabal-version: >=1.10 tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 Extra-source-files: README.md tidal.el doc/tidal.md @@ -19,6 +19,8 @@ Description: Tidal is a domain specific language for live coding pattern. library + default-language: Haskell2010 + Exposed-modules: Sound.Tidal.Bjorklund Sound.Tidal.Strategies Sound.Tidal.Dirt @@ -36,6 +38,7 @@ Sound.Tidal.Scales Sound.Tidal.Chords Sound.Tidal.Version + Sound.Tidal.PatternList Build-depends: base < 5 @@ -50,8 +53,22 @@ , safe , websockets > 0.8 , mtl >= 2.1 - , applicative-numbers source-repository head type: git location: https://github.com/tidalcycles/Tidal + +test-suite test + default-language: + Haskell2010 + type: + exitcode-stdio-1.0 + hs-source-dirs: + tests + main-is: + test.hs + build-depends: + base >= 4 && < 5 + , tasty >= 0.11 + , tasty-hunit + , tidal