From d5f50ace26880ff5962efb2b76ab50c7a146ecd9 Mon Sep 17 00:00:00 2001 From: onthepeakofnormal Date: Sun, 10 Jul 2022 18:46:15 +0200 Subject: [PATCH 01/11] introduce datatype for chords, make TPat applicative and monad, changes to the parser --- src/Sound/Tidal/ParseBP.hs | 127 ++++++++++++++++++++++++++++++++----- 1 file changed, 111 insertions(+), 16 deletions(-) diff --git a/src/Sound/Tidal/ParseBP.hs b/src/Sound/Tidal/ParseBP.hs index 937f2dee5..2f32ab4a5 100644 --- a/src/Sound/Tidal/ParseBP.hs +++ b/src/Sound/Tidal/ParseBP.hs @@ -23,7 +23,7 @@ module Sound.Tidal.ParseBP where along with this library. If not, see . -} -import Control.Applicative () +import Control.Applicative (liftA2) import qualified Control.Exception as E import Data.Bifunctor (first) import Data.Colour @@ -79,6 +79,42 @@ data TPat a = TPat_Atom (Maybe ((Int, Int), (Int, Int))) a | TPat_Var String deriving (Show, Functor) +instance Applicative TPat where + (<*>) f (TPat_Atom _ x) = fmap (\g -> g x) f + (<*>) f (TPat_Fast t x) = TPat_Fast t (f <*> x) + (<*>) f (TPat_Slow t x) = TPat_Slow t (f <*> x) + (<*>) f (TPat_DegradeBy i d x) = TPat_DegradeBy i d (f <*> x) + (<*>) f (TPat_CycleChoose i xs) = TPat_CycleChoose i (map (\x -> f <*> x) xs) + (<*>) f (TPat_Euclid i d o x) = TPat_Euclid i d o (f <*> x) + (<*>) f (TPat_Stack xs) = TPat_Stack (map (\x -> f <*> x) xs) + (<*>) f (TPat_Polyrhythm r xs) = TPat_Polyrhythm r (map (\x -> f <*> x) xs) + (<*>) f (TPat_Seq xs) = TPat_Seq (map (\x -> f <*> x) xs) + (<*>) _ TPat_Silence = TPat_Silence + (<*>) _ TPat_Foot = TPat_Foot + (<*>) f (TPat_Elongate r x) = TPat_Elongate r (f <*> x) + (<*>) f (TPat_Repeat i x) = TPat_Repeat i (f <*> x) + (<*>) f (TPat_EnumFromTo x y) = TPat_EnumFromTo (f <*> x) (f <*> y) + (<*>) _ (TPat_Var s) = TPat_Var s + pure x = TPat_Atom Nothing x + +instance Monad TPat where + (TPat_Atom _ x) >>= f = f x + (TPat_Fast t x) >>= f = TPat_Fast t (x >>= f) + (TPat_Slow t x) >>= f = TPat_Slow t (x >>= f) + (TPat_DegradeBy i d x) >>= f = TPat_DegradeBy i d (x >>= f) + (TPat_CycleChoose i xs) >>= f = TPat_CycleChoose i (map (\x -> x >>= f) xs) + (TPat_Euclid i d o x) >>= f = TPat_Euclid i d o (x >>= f) + (TPat_Stack xs) >>= f = TPat_Stack (map (\x -> x >>= f) xs) + (TPat_Polyrhythm r xs) >>= f = TPat_Polyrhythm r (map (\x -> x >>= f) xs) + (TPat_Seq xs) >>= f = TPat_Seq (map (\x -> x >>= f) xs) + TPat_Silence >>= _ = TPat_Silence + TPat_Foot >>= _ = TPat_Foot + (TPat_Elongate r x) >>= f = TPat_Elongate r (x >>= f) + (TPat_Repeat i x) >>= f = TPat_Repeat i (x >>= f) + (TPat_EnumFromTo x y) >>= f = TPat_EnumFromTo (x >>= f) (y >>= f) + TPat_Var s >>= _ = TPat_Var s + return = pure + tShowList :: (Show a) => [TPat a] -> String tShowList vs = "[" ++ intercalate "," (map tShow vs) ++ "]" @@ -357,14 +393,14 @@ pSequence f = do pRepeat :: TPat a -> MyParser (TPat a) pRepeat a = do es <- many1 $ do char '!' n <- (subtract 1 . read <$> many1 digit) <|> return 1 - spaces + -- spaces return n return $ TPat_Repeat (1 + sum es) a pElongate :: TPat a -> MyParser (TPat a) pElongate a = do rs <- many1 $ do oneOf "@_" r <- (subtract 1 <$> pRatio) <|> return 1 - spaces + -- spaces return r return $ TPat_Elongate (1 + sum rs) a @@ -434,18 +470,16 @@ 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 + pChord (pure v) <|> return (TPat_Atom Nothing v) + <|> pChord (pure 0) + 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 + pChord (pure v) <|> return (TPat_Atom Nothing v) + <|> pChord (pure 0) <|> do TPat_Atom Nothing . fromRational <$> pRatio pBool :: MyParser (TPat Bool) @@ -464,10 +498,9 @@ parseIntNote = do s <- sign 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) + pChord (pure i) <|> return (TPat_Atom Nothing i) <|> - do TPat_Stack . map (TPat_Atom Nothing) <$> parseChord + pChord (pure 0) parseChord :: (Enum a, Num a) => MyParser [a] parseChord = do char '\'' @@ -519,12 +552,12 @@ pColour = wrapPos $ do name <- many1 letter "colour name" pMult :: TPat a -> MyParser (TPat a) pMult thing = do char '*' - spaces + -- spaces r <- pRational <|> pPolyIn pRational <|> pPolyOut pRational return $ TPat_Fast r thing <|> do char '/' - spaces + -- spaces r <- pRational <|> pPolyIn pRational <|> pPolyOut pRational return $ TPat_Slow r thing <|> @@ -533,7 +566,7 @@ pMult thing = do char '*' pRand :: TPat a -> MyParser (TPat a) pRand thing = do char '?' r <- float <|> return 0.5 - spaces + -- spaces seed <- newSeed return $ TPat_DegradeBy seed r thing <|> return thing @@ -607,3 +640,65 @@ pRatioSingleChar c v = try $ do isInt :: RealFrac a => a -> Bool isInt x = x == fromInteger (round x) + +data Modifier = Range Int | Invert | Open deriving Eq + +data Chord a = Chord {cRoot :: TPat a + ,cName :: TPat String + ,cMods :: TPat [Modifier] + } + +instance Show Modifier where + show (Range i) = show i + show Invert = "i" + show Open = "o" + +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 + +chordToPat :: (Enum a, Num a) => Chord a -> TPat a +chordToPat (Chord rP nP msP) = do + ms <- msP + name <- nP + r <- rP + let chord = map (+ r) (fromMaybe [0] $ lookup name chordTable) + TPat_Stack $ fmap return $ foldl (flip applyModifier) chord ms + + +parseModInv :: MyParser Modifier +parseModInv = char 'i' >> return Invert + +parseModOpen :: MyParser Modifier +parseModOpen = char 'o' >> return Open + +parseModRange :: MyParser Modifier +parseModRange = parseIntNote >>= \i -> return $ Range $ fromIntegral i + +parseModifiers :: MyParser [Modifier] +parseModifiers = try (many1 parseModInv) <|> try (many1 parseModOpen) <|> (many1 parseModRange) "modifier" + + +pModifiers :: MyParser (TPat [Modifier]) +pModifiers = wrapPos $ TPat_Atom Nothing <$> parseModifiers + + +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] + +pChord :: (Enum a, Num a) => TPat a -> MyParser (TPat a) +pChord i = do + char '\'' + n <- pSequence pVocable + ms <- option [] (char '\'' >> pPart pModifiers `sepBy` char '\'') + let mods = fmap concat $ sequence ms + return $ chordToPat (Chord i n mods) From 9f3c56405451a88915f947db5d7eb00dda375bb9 Mon Sep 17 00:00:00 2001 From: onthepeakofnormal Date: Sun, 10 Jul 2022 21:03:33 +0200 Subject: [PATCH 02/11] some fixes -- test suite runs without errors now --- src/Sound/Tidal/ParseBP.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Sound/Tidal/ParseBP.hs b/src/Sound/Tidal/ParseBP.hs index 2f32ab4a5..2d2982074 100644 --- a/src/Sound/Tidal/ParseBP.hs +++ b/src/Sound/Tidal/ParseBP.hs @@ -23,7 +23,7 @@ module Sound.Tidal.ParseBP where along with this library. If not, see . -} -import Control.Applicative (liftA2) +import Control.Applicative () import qualified Control.Exception as E import Data.Bifunctor (first) import Data.Colour @@ -393,14 +393,14 @@ pSequence f = do pRepeat :: TPat a -> MyParser (TPat a) pRepeat a = do es <- many1 $ do char '!' n <- (subtract 1 . read <$> many1 digit) <|> return 1 - -- spaces + spaces return n return $ TPat_Repeat (1 + sum es) a pElongate :: TPat a -> MyParser (TPat a) pElongate a = do rs <- many1 $ do oneOf "@_" r <- (subtract 1 <$> pRatio) <|> return 1 - -- spaces + spaces return r return $ TPat_Elongate (1 + sum rs) a @@ -552,12 +552,12 @@ pColour = wrapPos $ do name <- many1 letter "colour name" pMult :: TPat a -> MyParser (TPat a) pMult thing = do char '*' - -- spaces + spaces r <- pRational <|> pPolyIn pRational <|> pPolyOut pRational return $ TPat_Fast r thing <|> do char '/' - -- spaces + spaces r <- pRational <|> pPolyIn pRational <|> pPolyOut pRational return $ TPat_Slow r thing <|> @@ -566,7 +566,7 @@ pMult thing = do char '*' pRand :: TPat a -> MyParser (TPat a) pRand thing = do char '?' r <- float <|> return 0.5 - -- spaces + spaces seed <- newSeed return $ TPat_DegradeBy seed r thing <|> return thing @@ -680,7 +680,7 @@ parseModRange :: MyParser Modifier parseModRange = parseIntNote >>= \i -> return $ Range $ fromIntegral i parseModifiers :: MyParser [Modifier] -parseModifiers = try (many1 parseModInv) <|> try (many1 parseModOpen) <|> (many1 parseModRange) "modifier" +parseModifiers = try (many1 parseModInv) <|> try (many1 parseModOpen) <|> (try $ fmap pure parseModRange) "modifier" pModifiers :: MyParser (TPat [Modifier]) @@ -698,7 +698,7 @@ instance Enumerable [Modifier] where pChord :: (Enum a, Num a) => TPat a -> MyParser (TPat a) pChord i = do char '\'' - n <- pSequence pVocable - ms <- option [] (char '\'' >> pPart pModifiers `sepBy` char '\'') + n <- pPart pVocable + ms <- option [] $ many1 $ try (char '\'' >> pPart pModifiers) let mods = fmap concat $ sequence ms return $ chordToPat (Chord i n mods) From 44d95f748b96c938ac9296b93a559b9b485eb9a2 Mon Sep 17 00:00:00 2001 From: onthepeakofnormal Date: Sat, 16 Jul 2022 23:19:08 +0200 Subject: [PATCH 03/11] Chord type doesn't work out, instances of Monad and Applicative were wrong --- src/Sound/Tidal/ParseBP.hs | 223 +++++++++++++++++++++++-------------- 1 file changed, 141 insertions(+), 82 deletions(-) diff --git a/src/Sound/Tidal/ParseBP.hs b/src/Sound/Tidal/ParseBP.hs index 2d2982074..04c52016b 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 #-} @@ -29,7 +29,7 @@ import Data.Bifunctor (first) import Data.Colour import Data.Colour.Names import Data.Functor.Identity (Identity) -import Data.List (intercalate) +import Data.List (intercalate, (\\)) import Data.Maybe import Data.Ratio import Data.Typeable (Typeable) @@ -62,58 +62,44 @@ 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) - -instance Applicative TPat where - (<*>) f (TPat_Atom _ x) = fmap (\g -> g x) f - (<*>) f (TPat_Fast t x) = TPat_Fast t (f <*> x) - (<*>) f (TPat_Slow t x) = TPat_Slow t (f <*> x) - (<*>) f (TPat_DegradeBy i d x) = TPat_DegradeBy i d (f <*> x) - (<*>) f (TPat_CycleChoose i xs) = TPat_CycleChoose i (map (\x -> f <*> x) xs) - (<*>) f (TPat_Euclid i d o x) = TPat_Euclid i d o (f <*> x) - (<*>) f (TPat_Stack xs) = TPat_Stack (map (\x -> f <*> x) xs) - (<*>) f (TPat_Polyrhythm r xs) = TPat_Polyrhythm r (map (\x -> f <*> x) xs) - (<*>) f (TPat_Seq xs) = TPat_Seq (map (\x -> f <*> x) xs) - (<*>) _ TPat_Silence = TPat_Silence - (<*>) _ TPat_Foot = TPat_Foot - (<*>) f (TPat_Elongate r x) = TPat_Elongate r (f <*> x) - (<*>) f (TPat_Repeat i x) = TPat_Repeat i (f <*> x) - (<*>) f (TPat_EnumFromTo x y) = TPat_EnumFromTo (f <*> x) (f <*> y) - (<*>) _ (TPat_Var s) = TPat_Var s - pure x = TPat_Atom Nothing x - -instance Monad TPat where - (TPat_Atom _ x) >>= f = f x - (TPat_Fast t x) >>= f = TPat_Fast t (x >>= f) - (TPat_Slow t x) >>= f = TPat_Slow t (x >>= f) - (TPat_DegradeBy i d x) >>= f = TPat_DegradeBy i d (x >>= f) - (TPat_CycleChoose i xs) >>= f = TPat_CycleChoose i (map (\x -> x >>= f) xs) - (TPat_Euclid i d o x) >>= f = TPat_Euclid i d o (x >>= f) - (TPat_Stack xs) >>= f = TPat_Stack (map (\x -> x >>= f) xs) - (TPat_Polyrhythm r xs) >>= f = TPat_Polyrhythm r (map (\x -> x >>= f) xs) - (TPat_Seq xs) >>= f = TPat_Seq (map (\x -> x >>= f) xs) - TPat_Silence >>= _ = TPat_Silence - TPat_Foot >>= _ = TPat_Foot - (TPat_Elongate r x) >>= f = TPat_Elongate r (x >>= f) - (TPat_Repeat i x) >>= f = TPat_Repeat i (x >>= f) - (TPat_EnumFromTo x y) >>= f = TPat_EnumFromTo (x >>= f) (y >>= f) - TPat_Var s >>= _ = TPat_Var s - return = pure +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 a, Enum a, Parseable a, Enumerable a) => (a -> b) -> (TPat a) -> (TPat String) -> (TPat [Modifier]) -> (TPat b) + +instance Show a => Show (TPat a) where + show = tShow + +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) ++ "]" @@ -168,6 +154,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 -> chordToPat f (toPat iP) (toPat nP) (toPat mP) _ -> silence resolve_tpat :: (Enumerable a, Parseable a) => TPat a -> (Rational, Pattern a) @@ -470,16 +457,16 @@ pDouble :: MyParser (TPat Double) pDouble = wrapPos $ do s <- sign f <- choice [fromRational <$> pRatio, parseNote] "float" let v = applySign s f - pChord (pure v) <|> return (TPat_Atom Nothing v) - <|> pChord (pure 0) + pChord (TPat_Atom Nothing v) <|> return (TPat_Atom Nothing v) + <|> pChord (TPat_Atom Nothing 0) pNote :: MyParser (TPat Note) pNote = wrapPos $ fmap (fmap Note) $ do s <- sign f <- choice [intOrFloat, parseNote] "float" let v = applySign s f - pChord (pure v) <|> return (TPat_Atom Nothing v) - <|> pChord (pure 0) + pChord (TPat_Atom Nothing v) <|> return (TPat_Atom Nothing v) + <|> pChord (TPat_Atom Nothing 0) <|> do TPat_Atom Nothing . fromRational <$> pRatio pBool :: MyParser (TPat Bool) @@ -496,11 +483,11 @@ parseIntNote = do s <- sign then return $ applySign s $ round d else fail "not an integer" -pIntegral :: Integral a => MyParser (TPat a) +pIntegral :: (Integral a, Parseable a, Enumerable a) => MyParser (TPat a) pIntegral = wrapPos $ do i <- parseIntNote - pChord (pure i) <|> return (TPat_Atom Nothing i) + pChord (TPat_Atom Nothing i) <|> return (TPat_Atom Nothing i) <|> - pChord (pure 0) + pChord (TPat_Atom Nothing 0) parseChord :: (Enum a, Num a) => MyParser [a] parseChord = do char '\'' @@ -641,17 +628,13 @@ pRatioSingleChar c v = try $ do isInt :: RealFrac a => a -> Bool isInt x = x == fromInteger (round x) -data Modifier = Range Int | Invert | Open deriving Eq - -data Chord a = Chord {cRoot :: TPat a - ,cName :: TPat String - ,cMods :: TPat [Modifier] - } +data Modifier = Range Int | Drop Int | Invert | Open deriving Eq instance Show Modifier where - show (Range i) = show i - show Invert = "i" - show Open = "o" + 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..] @@ -660,33 +643,65 @@ 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 -chordToPat :: (Enum a, Num a) => Chord a -> TPat a -chordToPat (Chord rP nP msP) = do - ms <- msP - name <- nP - r <- rP - let chord = map (+ r) (fromMaybe [0] $ lookup name chordTable) - TPat_Stack $ fmap return $ foldl (flip applyModifier) chord ms parseModInv :: MyParser Modifier parseModInv = char 'i' >> return Invert +-- parseManyInv :: MyParser (TPat [Modifier]) +-- parseManyInv = try $ pure <$> many1 (do parseModInv +-- notFollowedBy (pPart $ fmap pure pInteger) +-- return Invert) +-- <|> do char 'i' +-- nP <- pPart $ fmap pure pInteger +-- let msP = do +-- n <- nP +-- return $ replicate (round n) Invert +-- return $ msP +-- +-- +-- parseManyDrop :: MyParser (TPat [Modifier]) +-- parseManyDrop = do +-- char 'd' +-- nP <- pPart pIntegral +-- let msP = do +-- n <- nP +-- return $ [Drop n] +-- return $ msP + parseModOpen :: MyParser Modifier parseModOpen = char 'o' >> return Open parseModRange :: MyParser Modifier parseModRange = parseIntNote >>= \i -> return $ Range $ fromIntegral i +-- pModifiers :: MyParser (TPat [Modifier]) +-- pModifiers = wrapPos $ (try parseManyInv +-- -- <|> try parseManyDrop +-- <|> TPat_Atom Nothing <$> try (many1 parseModOpen) +-- <|> TPat_Atom Nothing <$> (try $ fmap pure parseModRange) +-- "modifier") + +chordToPat :: (Num a, Enum a) => (a -> b) -> Pattern a -> Pattern String -> Pattern [Modifier] -> Pattern b +chordToPat f noteP nameP modsP = uncollect $ do + n <- noteP + name <- nameP + ms <- modsP + let chord = map (+ n) (fromMaybe [0] $ lookup name chordTable) + return $ fmap f $ foldl (flip applyModifier) chord ms + parseModifiers :: MyParser [Modifier] parseModifiers = try (many1 parseModInv) <|> try (many1 parseModOpen) <|> (try $ fmap pure parseModRange) "modifier" - pModifiers :: MyParser (TPat [Modifier]) pModifiers = wrapPos $ TPat_Atom Nothing <$> parseModifiers - instance Parseable [Modifier] where tPatParser = pModifiers doEuclid = euclidOff @@ -695,10 +710,54 @@ instance Enumerable [Modifier] where fromTo a b = fastFromList [a,b] fromThenTo a b c = fastFromList [a,b,c] -pChord :: (Enum a, Num a) => TPat a -> MyParser (TPat a) +pChord :: (Enum a, Num a, Parseable a, Enumerable a) => TPat a -> MyParser (TPat a) pChord i = do char '\'' n <- pPart pVocable ms <- option [] $ many1 $ try (char '\'' >> pPart pModifiers) - let mods = fmap concat $ sequence ms - return $ chordToPat (Chord i n mods) + return $ TPat_Chord id i n (TPat_Stack ms) + +--- + +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) +-- +collectBy :: Eq a => (Event a -> Event a -> Bool) -> Pattern a -> Pattern [a] +collectBy f = withEvents (collectEventsBy f) +-- +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 +-- +uncollect :: Pattern [a] -> Pattern a +uncollect = withEvents uncollectEvents From 707728cd83ef919aefc1e41d5becf9e7cb64ede7 Mon Sep 17 00:00:00 2001 From: onthepeakofnormal Date: Sun, 17 Jul 2022 12:08:11 +0200 Subject: [PATCH 04/11] clean up, fix some errors --- src/Sound/Tidal/ParseBP.hs | 165 +++++++++++++++++++------------------ 1 file changed, 86 insertions(+), 79 deletions(-) diff --git a/src/Sound/Tidal/ParseBP.hs b/src/Sound/Tidal/ParseBP.hs index 04c52016b..7d16c17d7 100644 --- a/src/Sound/Tidal/ParseBP.hs +++ b/src/Sound/Tidal/ParseBP.hs @@ -78,7 +78,7 @@ data TPat a where TPat_Repeat :: Int -> (TPat a) -> (TPat a) TPat_EnumFromTo :: (TPat a) -> (TPat a) -> (TPat a) TPat_Var :: String -> (TPat a) - TPat_Chord :: (Num a, Enum a, Parseable a, Enumerable a) => (a -> b) -> (TPat a) -> (TPat String) -> (TPat [Modifier]) -> (TPat b) + TPat_Chord :: (Num a, Enum a, Parseable a, Enumerable a) => (a -> b) -> (TPat a) -> (TPat String) -> [TPat [Modifier]] -> (TPat b) instance Show a => Show (TPat a) where show = tShow @@ -154,7 +154,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 -> chordToPat f (toPat iP) (toPat nP) (toPat mP) + 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) @@ -454,20 +454,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 - pChord (TPat_Atom Nothing v) <|> return (TPat_Atom Nothing v) - <|> pChord (TPat_Atom Nothing 0) +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 - pChord (TPat_Atom Nothing v) <|> return (TPat_Atom Nothing v) - <|> pChord (TPat_Atom Nothing 0) - <|> 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" @@ -484,10 +492,13 @@ parseIntNote = do s <- sign else fail "not an integer" pIntegral :: (Integral a, Parseable a, Enumerable a) => MyParser (TPat a) -pIntegral = wrapPos $ do i <- parseIntNote - pChord (TPat_Atom Nothing i) <|> return (TPat_Atom Nothing i) - <|> - pChord (TPat_Atom Nothing 0) +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 '\'' @@ -628,6 +639,53 @@ 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 + + +----- + data Modifier = Range Int | Drop Int | Invert | Open deriving Eq instance Show Modifier where @@ -649,73 +707,22 @@ applyModifier (Drop i) ds = case length ds < i of 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 + chord <- pat + ms <- modsP + return $ foldl (flip applyModifier) chord 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 -parseModInv :: MyParser Modifier -parseModInv = char 'i' >> return Invert - --- parseManyInv :: MyParser (TPat [Modifier]) --- parseManyInv = try $ pure <$> many1 (do parseModInv --- notFollowedBy (pPart $ fmap pure pInteger) --- return Invert) --- <|> do char 'i' --- nP <- pPart $ fmap pure pInteger --- let msP = do --- n <- nP --- return $ replicate (round n) Invert --- return $ msP --- --- --- parseManyDrop :: MyParser (TPat [Modifier]) --- parseManyDrop = do --- char 'd' --- nP <- pPart pIntegral --- let msP = do --- n <- nP --- return $ [Drop n] --- return $ msP - -parseModOpen :: MyParser Modifier -parseModOpen = char 'o' >> return Open - -parseModRange :: MyParser Modifier -parseModRange = parseIntNote >>= \i -> return $ Range $ fromIntegral i - --- pModifiers :: MyParser (TPat [Modifier]) --- pModifiers = wrapPos $ (try parseManyInv --- -- <|> try parseManyDrop --- <|> TPat_Atom Nothing <$> try (many1 parseModOpen) --- <|> TPat_Atom Nothing <$> (try $ fmap pure parseModRange) --- "modifier") - -chordToPat :: (Num a, Enum a) => (a -> b) -> Pattern a -> Pattern String -> Pattern [Modifier] -> Pattern b -chordToPat f noteP nameP modsP = uncollect $ do +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 - ms <- modsP let chord = map (+ n) (fromMaybe [0] $ lookup name chordTable) - return $ fmap f $ foldl (flip applyModifier) chord ms - -parseModifiers :: MyParser [Modifier] -parseModifiers = try (many1 parseModInv) <|> try (many1 parseModOpen) <|> (try $ fmap pure parseModRange) "modifier" - -pModifiers :: MyParser (TPat [Modifier]) -pModifiers = wrapPos $ TPat_Atom Nothing <$> parseModifiers - -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] - -pChord :: (Enum a, Num a, Parseable a, Enumerable a) => TPat a -> MyParser (TPat a) -pChord i = do - char '\'' - n <- pPart pVocable - ms <- option [] $ many1 $ try (char '\'' >> pPart pModifiers) - return $ TPat_Chord id i n (TPat_Stack ms) + applyModifierPatSeq f (return chord) modsP --- From 0421a0f88eadad841e355de5b9dcf3dec06dfe9a Mon Sep 17 00:00:00 2001 From: onthepeakofnormal Date: Sun, 17 Jul 2022 12:19:19 +0200 Subject: [PATCH 05/11] move some of the code into other modules --- src/Sound/Tidal/ParseBP.hs | 90 +------------------------------------- 1 file changed, 2 insertions(+), 88 deletions(-) diff --git a/src/Sound/Tidal/ParseBP.hs b/src/Sound/Tidal/ParseBP.hs index 7d16c17d7..d323c6dba 100644 --- a/src/Sound/Tidal/ParseBP.hs +++ b/src/Sound/Tidal/ParseBP.hs @@ -29,7 +29,7 @@ import Data.Bifunctor (first) import Data.Colour import Data.Colour.Names import Data.Functor.Identity (Identity) -import Data.List (intercalate, (\\)) +import Data.List (intercalate) import Data.Maybe import Data.Ratio import Data.Typeable (Typeable) @@ -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, @@ -682,89 +682,3 @@ pChord i = do n <- pPart pVocable "chordname" ms <- option [] $ many1 $ (char '\'' >> pPart pModifiers) return $ TPat_Chord id i n ms - - ------ - -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 - chord <- pat - ms <- modsP - return $ foldl (flip applyModifier) chord 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 chord = map (+ n) (fromMaybe [0] $ lookup name chordTable) - applyModifierPatSeq f (return chord) modsP - ---- - -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) --- -collectBy :: Eq a => (Event a -> Event a -> Bool) -> Pattern a -> Pattern [a] -collectBy f = withEvents (collectEventsBy f) --- -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 --- -uncollect :: Pattern [a] -> Pattern a -uncollect = withEvents uncollectEvents From ffe675191b6cb70f551bf7aaede74ba45b6f4525 Mon Sep 17 00:00:00 2001 From: onthepeakofnormal Date: Sun, 17 Jul 2022 12:23:02 +0200 Subject: [PATCH 06/11] data structure for chord modifiers and a function that creates chords for the given patterns --- src/Sound/Tidal/Chords.hs | 41 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 41 insertions(+) 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 From 56f419c1b12551c8270acdfb290f793e0f937429 Mon Sep 17 00:00:00 2001 From: onthepeakofnormal Date: Sun, 17 Jul 2022 12:25:07 +0200 Subject: [PATCH 07/11] add a bunch of functions to convert patterns to patterns of lists and vice versa --- src/Sound/Tidal/Pattern.hs | 55 +++++++++++++++++++++++++++++++++++--- 1 file changed, 52 insertions(+), 3 deletions(-) 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 From c18ceee03adc111c8d17c7012e0144fb8b4419ea Mon Sep 17 00:00:00 2001 From: onthepeakofnormal Date: Wed, 20 Jul 2022 21:45:17 +0200 Subject: [PATCH 08/11] add some tests --- test/Sound/Tidal/ParseTest.hs | 36 +++++++++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) 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) From 73d5b08456804d48a2dc5ce36199a264a2edfb7f Mon Sep 17 00:00:00 2001 From: onthepeakofnormal Date: Wed, 20 Jul 2022 21:47:33 +0200 Subject: [PATCH 09/11] change a to b in TPat_Chord type to make it less confusing --- src/Sound/Tidal/ParseBP.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Sound/Tidal/ParseBP.hs b/src/Sound/Tidal/ParseBP.hs index d323c6dba..26a507681 100644 --- a/src/Sound/Tidal/ParseBP.hs +++ b/src/Sound/Tidal/ParseBP.hs @@ -78,7 +78,7 @@ data TPat a where TPat_Repeat :: Int -> (TPat a) -> (TPat a) TPat_EnumFromTo :: (TPat a) -> (TPat a) -> (TPat a) TPat_Var :: String -> (TPat a) - TPat_Chord :: (Num a, Enum a, Parseable a, Enumerable a) => (a -> b) -> (TPat a) -> (TPat String) -> [TPat [Modifier]] -> (TPat b) + 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 = tShow From 9ee62a158321b85310a2949468618746800dfbde Mon Sep 17 00:00:00 2001 From: onthepeakofnormal Date: Wed, 20 Jul 2022 22:17:07 +0200 Subject: [PATCH 10/11] make old show instance --- src/Sound/Tidal/ParseBP.hs | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/src/Sound/Tidal/ParseBP.hs b/src/Sound/Tidal/ParseBP.hs index 26a507681..18f8dc2fe 100644 --- a/src/Sound/Tidal/ParseBP.hs +++ b/src/Sound/Tidal/ParseBP.hs @@ -81,7 +81,22 @@ data TPat a where 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 = tShow + 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) @@ -129,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 ++ ") [" ++ (intercalate ", " $ map tShow mods) ++ "]" tShow a = "can't happen? " ++ show a From 428f428f28ae13e3fe4c2e790f9db3f1fb7fba53 Mon Sep 17 00:00:00 2001 From: onthepeakofnormal Date: Wed, 20 Jul 2022 22:18:45 +0200 Subject: [PATCH 11/11] better tShow --- src/Sound/Tidal/ParseBP.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Sound/Tidal/ParseBP.hs b/src/Sound/Tidal/ParseBP.hs index 18f8dc2fe..479cb3214 100644 --- a/src/Sound/Tidal/ParseBP.hs +++ b/src/Sound/Tidal/ParseBP.hs @@ -144,7 +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 ++ ") [" ++ (intercalate ", " $ map tShow mods) ++ "]" +tShow (TPat_Chord f n name mods) = "chord (" ++ (tShow $ fmap f n) ++ ") (" ++ tShow name ++ ")" ++ tShowList mods tShow a = "can't happen? " ++ show a