diff --git a/src/Sound/Tidal/Chords.hs b/src/Sound/Tidal/Chords.hs index 3650c7989..5c94d3dd8 100644 --- a/src/Sound/Tidal/Chords.hs +++ b/src/Sound/Tidal/Chords.hs @@ -274,3 +274,44 @@ chordL p = (\name -> fromMaybe [] $ lookup name chordTable) <$> p chordList :: String chordList = unwords $ map fst (chordTable :: [(String, [Int])]) +data Modifier = Range Int | Drop Int | Invert | Open deriving Eq + +instance Show Modifier where + show (Range i) = "Range " ++ show i + show (Drop i) = "Drop " ++ show i + show Invert = "Invert" + show Open = "Open" + +applyModifier :: (Enum a, Num a) => Modifier -> [a] -> [a] +applyModifier (Range i) ds = take i $ concatMap (\x -> map (+ x) ds) [0,12..] +applyModifier Invert [] = [] +applyModifier Invert (d:ds) = ds ++ [d+12] +applyModifier Open ds = case length ds > 2 of + True -> [ (ds !! 0 - 12), (ds !! 2 - 12), (ds !! 1) ] ++ reverse (take (length ds - 3) (reverse ds)) + False -> ds +applyModifier (Drop i) ds = case length ds < i of + True -> ds + False -> (ds!!s - 12):(xs ++ drop 1 ys) + where (xs,ys) = splitAt s ds + s = length ds - i + +applyModifierPat :: (Num a, Enum a) => Pattern [a] -> Pattern [Modifier] -> Pattern [a] +applyModifierPat pat modsP = do + ch <- pat + ms <- modsP + return $ foldl (flip applyModifier) ch ms + +applyModifierPatSeq :: (Num a, Enum a) => (a -> b) -> Pattern [a] -> [Pattern [Modifier]] -> Pattern [b] +applyModifierPatSeq f pat [] = fmap (map f) pat +applyModifierPatSeq f pat (mP:msP) = applyModifierPatSeq f (applyModifierPat pat mP) msP + +chordToPatSeq :: (Num a, Enum a) => (a -> b) -> Pattern a -> Pattern String -> [Pattern [Modifier]] -> Pattern b +chordToPatSeq f noteP nameP modsP = uncollect $ do + n <- noteP + name <- nameP + let ch = map (+ n) (fromMaybe [0] $ lookup name chordTable) + applyModifierPatSeq f (return ch) modsP + +-- | turns a given pattern of some Num type, a pattern of chord names and a list of patterns of modifiers into a chord pattern +chord :: (Num a, Enum a) => Pattern a -> Pattern String -> [Pattern [Modifier]] -> Pattern a +chord = chordToPatSeq id diff --git a/src/Sound/Tidal/ParseBP.hs b/src/Sound/Tidal/ParseBP.hs index 937f2dee5..479cb3214 100644 --- a/src/Sound/Tidal/ParseBP.hs +++ b/src/Sound/Tidal/ParseBP.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, FlexibleInstances, CPP, DeriveFunctor #-} +{-# LANGUAGE OverloadedStrings, FlexibleInstances, CPP, DeriveFunctor, GADTs, StandaloneDeriving #-} {-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans -fno-warn-unused-do-bind #-} @@ -42,7 +42,7 @@ import qualified Text.Parsec.Prim import Sound.Tidal.Pattern import Sound.Tidal.UI import Sound.Tidal.Core -import Sound.Tidal.Chords (chordTable) +import Sound.Tidal.Chords import Sound.Tidal.Utils (fromRight) data TidalParseError = TidalParseError {parsecError :: ParseError, @@ -62,22 +62,59 @@ type MyParser = Text.Parsec.Prim.Parsec String Int -- | AST representation of patterns -data TPat a = TPat_Atom (Maybe ((Int, Int), (Int, Int))) a - | TPat_Fast (TPat Time) (TPat a) - | TPat_Slow (TPat Time) (TPat a) - | TPat_DegradeBy Int Double (TPat a) - | TPat_CycleChoose Int [TPat a] - | TPat_Euclid (TPat Int) (TPat Int) (TPat Int) (TPat a) - | TPat_Stack [TPat a] - | TPat_Polyrhythm (Maybe (TPat Rational)) [TPat a] - | TPat_Seq [TPat a] - | TPat_Silence - | TPat_Foot - | TPat_Elongate Rational (TPat a) - | TPat_Repeat Int (TPat a) - | TPat_EnumFromTo (TPat a) (TPat a) - | TPat_Var String - deriving (Show, Functor) +data TPat a where + TPat_Atom :: (Maybe ((Int, Int), (Int, Int))) -> a -> (TPat a) + TPat_Fast :: (TPat Time) -> (TPat a) -> (TPat a) + TPat_Slow :: (TPat Time) -> (TPat a) -> (TPat a) + TPat_DegradeBy :: Int -> Double -> (TPat a) -> (TPat a) + TPat_CycleChoose :: Int -> [TPat a] -> (TPat a) + TPat_Euclid :: (TPat Int) -> (TPat Int) -> (TPat Int) -> (TPat a) -> (TPat a) + TPat_Stack :: [TPat a] -> (TPat a) + TPat_Polyrhythm :: (Maybe (TPat Rational)) -> [TPat a] -> (TPat a) + TPat_Seq :: [TPat a] -> (TPat a) + TPat_Silence :: (TPat a) + TPat_Foot :: (TPat a) + TPat_Elongate :: Rational -> (TPat a) -> (TPat a) + TPat_Repeat :: Int -> (TPat a) -> (TPat a) + TPat_EnumFromTo :: (TPat a) -> (TPat a) -> (TPat a) + TPat_Var :: String -> (TPat a) + TPat_Chord :: (Num b, Enum b, Parseable b, Enumerable b) => (b -> a) -> (TPat b) -> (TPat String) -> [TPat [Modifier]] -> (TPat a) + +instance Show a => Show (TPat a) where + show (TPat_Atom c v) = "TPat_Atom (" ++ show c ++ ") (" ++ show v ++ ")" + show (TPat_Fast t v) = "TPat_Fast (" ++ show t ++ ") (" ++ show v ++ ")" + show (TPat_Slow t v) = "TPat_Slow (" ++ show t ++ ") (" ++ show v ++ ")" + show (TPat_DegradeBy x r v) = "TPat_DegradeBy (" ++ show x ++ ") (" ++ show r ++ ") (" ++ show v ++ ")" + show (TPat_CycleChoose x vs) = "TPat_CycleChoose (" ++ show x ++ ") (" ++ show vs ++ ")" + show (TPat_Euclid a b c v) = "TPat_Euclid (" ++ show a ++ ") (" ++ show b ++ ") (" ++ show c ++ ") " ++ show v ++ ")" + show (TPat_Stack vs) = "TPat_Stack " ++ show vs + show (TPat_Polyrhythm mSteprate vs) = "TPat_Polyrhythm (" ++ show mSteprate ++ ") " ++ show vs + show (TPat_Seq vs) = "TPat_Seq " ++ show vs + show TPat_Silence = "TPat_Silence" + show TPat_Foot = "TPat_Foot" + show (TPat_Elongate r v) = "TPat_Elongate (" ++ show r ++ ") (" ++ show v ++ ")" + show (TPat_Repeat r v) = "TPat_Repeat (" ++ show r ++ ") (" ++ show v ++ ")" + show (TPat_EnumFromTo a b) = "TPat_EnumFromTo (" ++ show a ++ ") (" ++ show b ++ ")" + show (TPat_Var s) = "TPat_Var " ++ show s + show (TPat_Chord g iP nP msP) = "TPat_Chord (" ++ (show $ fmap g iP) ++ ") (" ++ show nP ++ ") (" ++ show msP ++ ")" + +instance Functor TPat where + fmap f (TPat_Atom c v) = TPat_Atom c (f v) + fmap f (TPat_Fast t v) = TPat_Fast t (fmap f v) + fmap f (TPat_Slow t v) = TPat_Slow t (fmap f v) + fmap f (TPat_DegradeBy x r v) = TPat_DegradeBy x r (fmap f v) + fmap f (TPat_CycleChoose x vs) = TPat_CycleChoose x (map (fmap f) vs) + fmap f (TPat_Euclid a b c v) = TPat_Euclid a b c (fmap f v) + fmap f (TPat_Stack vs) = TPat_Stack (map (fmap f) vs) + fmap f (TPat_Polyrhythm mSteprate vs) = TPat_Polyrhythm mSteprate (map (fmap f) vs) + fmap f (TPat_Seq vs) = TPat_Seq (map (fmap f) vs) + fmap _ TPat_Silence = TPat_Silence + fmap _ TPat_Foot = TPat_Foot + fmap f (TPat_Elongate r v) = TPat_Elongate r (fmap f v) + fmap f (TPat_Repeat r v) = TPat_Repeat r (fmap f v) + fmap f (TPat_EnumFromTo a b) = TPat_EnumFromTo (fmap f a) (fmap f b) + fmap _ (TPat_Var s) = TPat_Var s + fmap f (TPat_Chord g iP nP msP) = TPat_Chord (f . g) iP nP msP tShowList :: (Show a) => [TPat a] -> String tShowList vs = "[" ++ intercalate "," (map tShow vs) ++ "]" @@ -107,6 +144,7 @@ tShow (TPat_Seq vs) = snd $ steps_seq vs tShow TPat_Silence = "silence" tShow (TPat_EnumFromTo a b) = "unwrap $ fromTo <$> (" ++ tShow a ++ ") <*> (" ++ tShow b ++ ")" tShow (TPat_Var s) = "getControl " ++ s +tShow (TPat_Chord f n name mods) = "chord (" ++ (tShow $ fmap f n) ++ ") (" ++ tShow name ++ ")" ++ tShowList mods tShow a = "can't happen? " ++ show a @@ -132,6 +170,7 @@ toPat = \case | otherwise = pure $ fst $ head pats TPat_Seq xs -> snd $ resolve_seq xs TPat_Var s -> getControl s + TPat_Chord f iP nP mP -> chordToPatSeq f (toPat iP) (toPat nP) (map toPat mP) _ -> silence resolve_tpat :: (Enumerable a, Parseable a) => TPat a -> (Rational, Pattern a) @@ -431,22 +470,28 @@ pChar :: MyParser (TPat Char) pChar = wrapPos $ TPat_Atom Nothing <$> pCharNum pDouble :: MyParser (TPat Double) -pDouble = wrapPos $ do s <- sign - f <- choice [fromRational <$> pRatio, parseNote] "float" - let v = applySign s f - do TPat_Stack . map (TPat_Atom Nothing . (+ v)) <$> parseChord - <|> return (TPat_Atom Nothing v) - <|> - do TPat_Stack . map (TPat_Atom Nothing) <$> parseChord +pDouble = try $ do d <- pDoubleWithoutChord + pChord d <|> return d + <|> pChord (TPat_Atom Nothing 0) + <|> pDoubleWithoutChord + +pDoubleWithoutChord :: MyParser (TPat Double) +pDoubleWithoutChord = pPart $ wrapPos $ do s <- sign + f <- choice [fromRational <$> pRatio, parseNote] "float" + return $ TPat_Atom Nothing (applySign s f) pNote :: MyParser (TPat Note) -pNote = wrapPos $ fmap (fmap Note) $ do s <- sign - f <- choice [intOrFloat, parseNote] "float" - let v = applySign s f - do TPat_Stack . map (TPat_Atom Nothing . (+ v)) <$> parseChord - <|> return (TPat_Atom Nothing v) - <|> do TPat_Stack . map (TPat_Atom Nothing) <$> parseChord - <|> do TPat_Atom Nothing . fromRational <$> pRatio +pNote = try $ do n <- pNoteWithoutChord + pChord n <|> return n + <|> pChord (TPat_Atom Nothing 0) + <|> pNoteWithoutChord + <|> do TPat_Atom Nothing . fromRational <$> pRatio + +pNoteWithoutChord :: MyParser (TPat Note) +pNoteWithoutChord = pPart $ wrapPos $ do s <- sign + f <- choice [intOrFloat, parseNote] "float" + return $ TPat_Atom Nothing (Note $ applySign s f) + pBool :: MyParser (TPat Bool) pBool = wrapPos $ do oneOf "t1" @@ -462,12 +507,14 @@ parseIntNote = do s <- sign then return $ applySign s $ round d else fail "not an integer" -pIntegral :: Integral a => MyParser (TPat a) -pIntegral = wrapPos $ do i <- parseIntNote - do TPat_Stack . map (TPat_Atom Nothing . (+i)) <$> parseChord - <|> return (TPat_Atom Nothing i) - <|> - do TPat_Stack . map (TPat_Atom Nothing) <$> parseChord +pIntegral :: (Integral a, Parseable a, Enumerable a) => MyParser (TPat a) +pIntegral = try $ do i <- pIntegralWithoutChord + pChord i <|> return i + <|> pChord (TPat_Atom Nothing 0) + <|> pIntegralWithoutChord + +pIntegralWithoutChord :: (Integral a, Parseable a, Enumerable a) => MyParser (TPat a) +pIntegralWithoutChord = pPart $ wrapPos $ fmap (TPat_Atom Nothing) parseIntNote parseChord :: (Enum a, Num a) => MyParser [a] parseChord = do char '\'' @@ -607,3 +654,47 @@ pRatioSingleChar c v = try $ do isInt :: RealFrac a => a -> Bool isInt x = x == fromInteger (round x) + +--- + +instance Parseable [Modifier] where + tPatParser = pModifiers + doEuclid = euclidOff + +instance Enumerable [Modifier] where + fromTo a b = fastFromList [a,b] + fromThenTo a b c = fastFromList [a,b,c] + +parseModInv :: MyParser Modifier +parseModInv = char 'i' >> return Invert + +parseModInvNum :: MyParser [Modifier] +parseModInvNum = do + char 'i' + n <- pInteger + return $ replicate (round n) Invert + +parseModDrop :: MyParser [Modifier] +parseModDrop = do + char 'd' + n <- pInteger + return $ [Drop $ round n] + +parseModOpen :: MyParser Modifier +parseModOpen = char 'o' >> return Open + +parseModRange :: MyParser Modifier +parseModRange = parseIntNote >>= \i -> return $ Range $ fromIntegral i + +parseModifiers :: MyParser [Modifier] +parseModifiers = (many1 parseModOpen) <|> parseModDrop <|> (fmap pure parseModRange) <|> try parseModInvNum <|> (many1 parseModInv) "modifier" + +pModifiers :: MyParser (TPat [Modifier]) +pModifiers = wrapPos $ TPat_Atom Nothing <$> parseModifiers + +pChord :: (Enum a, Num a, Parseable a, Enumerable a) => TPat a -> MyParser (TPat a) +pChord i = do + char '\'' + n <- pPart pVocable "chordname" + ms <- option [] $ many1 $ (char '\'' >> pPart pModifiers) + return $ TPat_Chord id i n ms diff --git a/src/Sound/Tidal/Pattern.hs b/src/Sound/Tidal/Pattern.hs index 96a6c8689..57a50c907 100644 --- a/src/Sound/Tidal/Pattern.hs +++ b/src/Sound/Tidal/Pattern.hs @@ -37,7 +37,7 @@ import Control.DeepSeq (NFData) import Control.Monad ((>=>)) import qualified Data.Map.Strict as Map import Data.Maybe (isJust, fromJust, catMaybes, mapMaybe) -import Data.List (delete, findIndex) +import Data.List (delete, findIndex, (\\)) import Data.Word (Word8) import Data.Data (Data) -- toConstr import Data.Typeable (Typeable) @@ -348,7 +348,7 @@ empty :: Pattern a empty = Pattern {query = const []} queryArc :: Pattern a -> Arc -> [Event a] -queryArc p a = query p $ State a Map.empty +queryArc p a = query p $ State a Map.empty -- | Splits queries that span cycles. For example `query p (0.5, 1.5)` would be -- turned into two queries, `(0.5,1)` and `(1,1.5)`, and the results @@ -429,7 +429,7 @@ compressArcTo (Arc s e) = compressArc (Arc (cyclePos s) (e - sam s)) _fastGap :: Time -> Pattern a -> Pattern a _fastGap 0 _ = empty -_fastGap r p = splitQueries $ +_fastGap r p = splitQueries $ withResultArc (\(Arc s e) -> Arc (sam s + ((s - sam s)/r')) (sam s + ((e - sam s)/r')) ) $ p {query = f} @@ -835,3 +835,52 @@ getList _ = Nothing valueToPattern :: Value -> Pattern Value valueToPattern (VPattern pat) = pat valueToPattern v = pure v + +--- functions relating to chords/patterns of lists + + +sameDur :: Event a -> Event a -> Bool +sameDur e1 e2 = (whole e1 == whole e2) && (part e1 == part e2) + +groupEventsBy :: Eq a => (Event a -> Event a -> Bool) -> [Event a] -> [[Event a]] +groupEventsBy _ [] = [] +groupEventsBy f (e:es) = eqs:(groupEventsBy f (es \\ eqs)) + where eqs = e:[x | x <- es, f e x] + +-- assumes that all events in the list have same whole/part +collectEvent :: [Event a] -> Maybe (Event [a]) +collectEvent [] = Nothing +collectEvent l@(e:_) = Just $ e {context = con, value = vs} + where con = unionC $ map context l + vs = map value l + unionC [] = Context [] + unionC ((Context is):cs) = Context (is ++ iss) + where Context iss = unionC cs + +collectEventsBy :: Eq a => (Event a -> Event a -> Bool) -> [Event a] -> [Event [a]] +collectEventsBy f es = remNo $ map collectEvent (groupEventsBy f es) + where + remNo [] = [] + remNo (Nothing:cs) = remNo cs + remNo ((Just c):cs) = c : (remNo cs) + +-- | collects all events satisfying the same constraint into a list +collectBy :: Eq a => (Event a -> Event a -> Bool) -> Pattern a -> Pattern [a] +collectBy f = withEvents (collectEventsBy f) + +-- | collects all events occuring at the exact same time into a list +collect :: Eq a => Pattern a -> Pattern [a] +collect = collectBy sameDur + +uncollectEvent :: Event [a] -> [Event a] +uncollectEvent e = [e {value = (value e)!!i, context = resolveContext i (context e)} | i <-[0..length (value e) - 1]] + where resolveContext i (Context xs) = case length xs <= i of + True -> Context [] + False -> Context [xs!!i] + +uncollectEvents :: [Event [a]] -> [Event a] +uncollectEvents = concatMap uncollectEvent + +-- | merges all values in a list into one pattern by stacking the values +uncollect :: Pattern [a] -> Pattern a +uncollect = withEvents uncollectEvents diff --git a/test/Sound/Tidal/ParseTest.hs b/test/Sound/Tidal/ParseTest.hs index 55a26c5a7..5448f37c9 100644 --- a/test/Sound/Tidal/ParseTest.hs +++ b/test/Sound/Tidal/ParseTest.hs @@ -160,6 +160,42 @@ run = compareP (Arc 0 2) ("c'major c'minor" :: Pattern Note) ("'major 'minor") + it "can invert chords" $ do + compareP (Arc 0 2) + ("c'major'i" :: Pattern Note) + ("[4,7,12]") + it "can invert chords using a number" $ do + compareP (Arc 0 2) + ("c'major'i2" :: Pattern Note) + ("[7,12,16]") + it "spread chords over a range" $ do + compareP (Arc 0 2) + ("c'major'5 e'min7'5" :: Pattern Note) + ("[0,4,7,12,16] [4,7,11,14,16]") + it "can open chords" $ do + compareP (Arc 0 2) + ("c'major'o" :: Pattern Note) + ("[-12,-5,4]") + it "can drop notes in a chord" $ do + compareP (Arc 0 2) + ("c'major'd1" :: Pattern Note) + ("[-5,0,4]") + it "can apply multiple modifiers" $ do + compareP (Arc 0 2) + ("c'major'i'5" :: Pattern Note) + ("[4,7,12,16,19]") + it "can pattern modifiers" $ do + compareP (Arc 0 2) + ("c'major'" :: Pattern Note) + ("<[4,7,12] [0,4,7,12,16]>") + it "can pattern chord names" $ do + compareP (Arc 0 2) + ("c''i" :: Pattern Note) + ("<[4,7,12] [3,7,12]>") + it "can pattern chord notes" $ do + compareP (Arc 0 2) + ("''i" :: Pattern Note) + ("<[4,7,12] [7,11,16]>") it "handle trailing and leading whitespaces" $ do compareP (Arc 0 1) (" bd " :: Pattern String)