diff --git a/src/Sound/Tidal/ParseBP.hs b/src/Sound/Tidal/ParseBP.hs index 5881e13f..9dd8785c 100644 --- a/src/Sound/Tidal/ParseBP.hs +++ b/src/Sound/Tidal/ParseBP.hs @@ -1,5 +1,10 @@ -{-# LANGUAGE OverloadedStrings, FlexibleInstances, CPP, DeriveFunctor, GADTs, StandaloneDeriving #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans -fno-warn-unused-do-bind #-} module Sound.Tidal.ParseBP where @@ -23,30 +28,30 @@ module Sound.Tidal.ParseBP where along with this library. If not, see <http://www.gnu.org/licenses/>. -} -import Control.Applicative () -import qualified Control.Exception as E -import Data.Bifunctor (first) +import Control.Applicative () +import qualified Control.Exception as E +import Data.Bifunctor (first) import Data.Colour import Data.Colour.Names -import Data.Functor.Identity (Identity) -import Data.List (intercalate) +import Data.Functor.Identity (Identity) +import Data.List (intercalate) import Data.Maybe import Data.Ratio -import Data.Typeable (Typeable) -import GHC.Exts ( IsString(..) ) -import Text.Parsec.Error -import Text.ParserCombinators.Parsec -import Text.ParserCombinators.Parsec.Language ( haskellDef ) -import qualified Text.ParserCombinators.Parsec.Token as P -import qualified Text.Parsec.Prim +import Data.Typeable (Typeable) +import GHC.Exts (IsString (..)) +import Sound.Tidal.Chords +import Sound.Tidal.Core import Sound.Tidal.Pattern import Sound.Tidal.UI -import Sound.Tidal.Core -import Sound.Tidal.Chords -import Sound.Tidal.Utils (fromRight) +import Sound.Tidal.Utils (fromRight) +import Text.Parsec.Error +import qualified Text.Parsec.Prim +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Language (haskellDef) +import qualified Text.ParserCombinators.Parsec.Token as P data TidalParseError = TidalParseError {parsecError :: ParseError, - code :: String + code :: String } deriving (Eq, Typeable) @@ -175,7 +180,7 @@ toPat = \case resolve_tpat :: (Enumerable a, Parseable a) => TPat a -> (Rational, Pattern a) resolve_tpat (TPat_Seq xs) = resolve_seq xs -resolve_tpat a = (1, toPat a) +resolve_tpat a = (1, toPat a) resolve_seq :: (Enumerable a, Parseable a) => [TPat a] -> (Rational, Pattern a) resolve_seq xs = (total_size, timeCat sized_pats) @@ -183,15 +188,15 @@ resolve_seq xs = (total_size, timeCat sized_pats) total_size = sum $ map fst sized_pats resolve_size :: [TPat a] -> [(Rational, TPat a)] -resolve_size [] = [] +resolve_size [] = [] resolve_size ((TPat_Elongate r p):ps) = (r, p):resolve_size ps -resolve_size ((TPat_Repeat n p):ps) = replicate n (1,p) ++ resolve_size ps -resolve_size (p:ps) = (1,p):resolve_size ps +resolve_size ((TPat_Repeat n p):ps) = replicate n (1,p) ++ resolve_size ps +resolve_size (p:ps) = (1,p):resolve_size ps steps_tpat :: (Show a) => TPat a -> (Rational, String) steps_tpat (TPat_Seq xs) = steps_seq xs -steps_tpat a = (1, tShow a) +steps_tpat a = (1, tShow a) steps_seq :: (Show a) => [TPat a] -> (Rational, String) steps_seq xs = (total_size, "timeCat [" ++ intercalate "," (map (\(r,s) -> "(" ++ show r ++ ", " ++ s ++ ")") sized_pats) ++ "]") @@ -199,10 +204,10 @@ steps_seq xs = (total_size, "timeCat [" ++ intercalate "," (map (\(r,s) -> "(" + total_size = sum $ map fst sized_pats steps_size :: Show a => [TPat a] -> [(Rational, String)] -steps_size [] = [] +steps_size [] = [] steps_size ((TPat_Elongate r p):ps) = (r, tShow p):steps_size ps -steps_size ((TPat_Repeat n p):ps) = replicate n (1, tShow p) ++ steps_size ps -steps_size (p:ps) = (1,tShow p):steps_size ps +steps_size ((TPat_Repeat n p):ps) = replicate n (1, tShow p) ++ steps_size ps +steps_size (p:ps) = (1,tShow p):steps_size ps parseBP :: (Enumerable a, Parseable a) => String -> Either ParseError (Pattern a) parseBP s = toPat <$> parseTPat s @@ -212,7 +217,7 @@ parseBP_E s = toE parsed where parsed = parseTPat s -- TODO - custom error - toE (Left e) = E.throw $ TidalParseError {parsecError = e, code = s} + toE (Left e) = E.throw $ TidalParseError {parsecError = e, code = s} toE (Right tp) = toPat tp parseTPat :: Parseable a => String -> Either ParseError (TPat a) @@ -389,9 +394,9 @@ pSequence f = do splitFeet [] = [] splitFeet pats = foot : splitFeet pats' where (foot, pats') = takeFoot pats - takeFoot [] = ([], []) + takeFoot [] = ([], []) takeFoot (TPat_Foot:pats'') = ([], pats'') - takeFoot (pat:pats'') = first (pat:) $ takeFoot pats'' + takeFoot (pat:pats'') = first (pat:) $ takeFoot pats'' pRepeat :: TPat a -> MyParser (TPat a) pRepeat a = do es <- many1 $ do char '!' diff --git a/src/Sound/Tidal/Pattern.hs b/src/Sound/Tidal/Pattern.hs index 6809e525..6f7da9e7 100644 --- a/src/Sound/Tidal/Pattern.hs +++ b/src/Sound/Tidal/Pattern.hs @@ -54,13 +54,16 @@ data State = State {arc :: Arc, } -- | A datatype representing events taking place over time -data Pattern a = Pattern {query :: State -> [Event a], tactus :: Maybe Rational} +data Pattern a = Pattern {query :: State -> [Event a], tactus :: Maybe Rational, pureValue :: Maybe a} deriving (Generic, Functor) instance NFData a => NFData (Pattern a) pattern :: (State -> [Event a]) -> Pattern a -pattern f = Pattern f Nothing +pattern f = Pattern f Nothing Nothing + +setTactus :: Rational -> Pattern a -> Pattern a +setTactus r p = p {tactus = Just r} -- type StateMap = Map.Map String (Pattern Value) type ControlPattern = Pattern ValueMap @@ -69,13 +72,14 @@ type ControlPattern = Pattern ValueMap instance Applicative Pattern where -- | Repeat the given value once per cycle, forever - pure v = pattern $ \(State a _) -> - map (\a' -> Event - (Context []) - (Just a') - (sect a a') - v) - $ cycleArcsInArc a + pure v = Pattern q (Just 1) (Just v) + where q (State a _) = + map (\a' -> Event + (Context []) + (Just a') + (sect a a') + v) + $ cycleArcsInArc a -- | In each of @a <*> b@, @a <* b@ and @a *> b@ -- (using the definitions from this module, not the Prelude), @@ -186,7 +190,7 @@ instance Monad Pattern where -- -- TODO - what if a continuous pattern contains a discrete one, or vice-versa? unwrap :: Pattern (Pattern a) -> Pattern a -unwrap pp = pp {query = q} +unwrap pp = pp {query = q, pureValue = Nothing} where q st = concatMap (\(Event c w p v) -> mapMaybe (munge c w p) $ query v st {arc = p}) @@ -200,7 +204,7 @@ unwrap pp = pp {query = q} -- | Turns a pattern of patterns into a single pattern. Like @unwrap@, -- but structure only comes from the inner pattern. innerJoin :: Pattern (Pattern a) -> Pattern a -innerJoin pp = pp {query = q} +innerJoin pp = pp {query = q, pureValue = Nothing} where q st = concatMap (\(Event oc _ op v) -> mapMaybe (munge oc) $ query v st {arc = op} ) @@ -214,7 +218,7 @@ innerJoin pp = pp {query = q} -- | Turns a pattern of patterns into a single pattern. Like @unwrap@, -- but structure only comes from the outer pattern. outerJoin :: Pattern (Pattern a) -> Pattern a -outerJoin pp = pp {query = q} +outerJoin pp = pp {query = q, pureValue = Nothing} where q st = concatMap (\e -> mapMaybe (munge (context e) (whole e) (part e)) $ query (value e) st {arc = pure (start $ wholeOrPart e)} @@ -229,7 +233,7 @@ outerJoin pp = pp {query = q} -- 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? squeezeJoin :: Pattern (Pattern a) -> Pattern a -squeezeJoin pp = pp {query = q} +squeezeJoin pp = pp {query = q, pureValue = Nothing} where q st = concatMap (\e@(Event c w p v) -> mapMaybe (munge c w p) $ query (focusArc (wholeOrPart e) v) st {arc = p} @@ -246,8 +250,8 @@ _trigJoin cycleZero pat_of_pats = pattern q where q st = catMaybes $ concatMap - (\oe@(Event oc (Just jow) op ov) -> - map (\oe@(Event ic (iw) ip iv) -> + (\(Event oc (Just jow) op ov) -> + map (\(Event ic (iw) ip iv) -> do w <- subMaybeArc (Just jow) iw p <- subArc op ip return $ Event (combineContexts [ic, oc]) w p iv @@ -412,7 +416,7 @@ instance Floating ValueMap -- * Internal/fundamental functions empty :: Pattern a -empty = Pattern {query = const []} +empty = Pattern {query = const [], tactus = Just 1, pureValue = Nothing} silence :: Pattern a silence = empty @@ -452,7 +456,7 @@ withQueryControls f pat = pat { query = query pat . (\(State a m) -> State a (f -- | @withEvent f p@ returns a new @Pattern@ with each event mapped over -- function @f@. withEvent :: (Event a -> Event b) -> Pattern a -> Pattern b -withEvent f p = p {query = map f . query p} +withEvent f p = p {query = map f . query p, pureValue = Nothing} -- | @withEvent f p@ returns a new @Pattern@ with each value mapped over -- function @f@. @@ -462,7 +466,7 @@ withValue f pat = withEvent (fmap f) pat -- | @withEvent f p@ returns a new @Pattern@ with f applied to the resulting list of events for each query -- function @f@. withEvents :: ([Event a] -> [Event b]) -> Pattern a -> Pattern b -withEvents f p = p {query = f . query p} +withEvents f p = p {query = f . query p, pureValue = Nothing} -- | @withPart f p@ returns a new @Pattern@ with function @f@ applied -- to the part. @@ -669,7 +673,7 @@ rev p = -- | Mark values in the first pattern which match with at least one -- value in the second pattern. matchManyToOne :: (b -> a -> Bool) -> Pattern a -> Pattern b -> Pattern (Bool, b) -matchManyToOne f pa pb = pa {query = q} +matchManyToOne f pa pb = pa {query = q, pureValue = Nothing} where q st = map match $ query pb st where match ex@(Event xContext xWhole xPart x) = diff --git a/src/Sound/Tidal/Show.hs b/src/Sound/Tidal/Show.hs index a69e70a0..0ad3024e 100644 --- a/src/Sound/Tidal/Show.hs +++ b/src/Sound/Tidal/Show.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE FlexibleInstances, RecordWildCards #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Sound.Tidal.Show (show, showAll, draw, drawLine, drawLineSz, stepcount, showStateful) where @@ -22,13 +23,13 @@ module Sound.Tidal.Show (show, showAll, draw, drawLine, drawLineSz, stepcount, s along with this library. If not, see <http://www.gnu.org/licenses/>. -} -import Sound.Tidal.Pattern +import Sound.Tidal.Pattern -import Data.List (intercalate, sortOn) -import Data.Ratio (numerator, denominator) -import Data.Maybe (fromMaybe, isJust) +import Data.List (intercalate, sortOn) +import Data.Maybe (fromMaybe, isJust) +import Data.Ratio (denominator, numerator) -import qualified Data.Map.Strict as Map +import qualified Data.Map.Strict as Map instance (Show a) => Show (Pattern a) where show = showPattern (Arc 0 1) @@ -47,6 +48,7 @@ showStateful p = intercalate "\n" evStrings evStrings = map evString evs' showPattern :: Show a => Arc -> Pattern a -> String +showPattern _ (Pattern _ _ (Just v)) = "(pure " ++ show v ++ ")" showPattern a p = intercalate "\n" evStrings where evs = map showEvent $ sortOn part $ queryArc p a maxPartLength :: Int @@ -79,16 +81,16 @@ instance Show Context where show (Context cs) = show cs instance Show Value where - show (VS s) = ('"':s) ++ "\"" - show (VI i) = show i - show (VF f) = show f ++ "f" - show (VN n) = show n - show (VR r) = prettyRat r ++ "r" - show (VB b) = show b - show (VX xs) = show xs + show (VS s) = ('"':s) ++ "\"" + show (VI i) = show i + show (VF f) = show f ++ "f" + show (VN n) = show n + show (VR r) = prettyRat r ++ "r" + show (VB b) = show b + show (VX xs) = show xs show (VPattern pat) = "(" ++ show pat ++ ")" - show (VState f) = show $ f Map.empty - show (VList vs) = show $ map show vs + show (VState f) = show $ f Map.empty + show (VList vs) = show $ map show vs instance {-# OVERLAPPING #-} Show ValueMap where show m = intercalate ", " $ map (\(name, v) -> name ++ ": " ++ show v) $ Map.toList m @@ -195,7 +197,7 @@ draw pat = Render 1 s (intercalate "\n" $ map (('|' :) .drawLevel) ls) drawLevel [] = replicate s '.' drawLevel (e:es) = map f $ take s $ zip (drawLevel es ++ repeat '.') (drawEvent e ++ repeat '.') f ('.', x) = x - f (x, _) = x + f (x, _) = x drawEvent :: Event Char -> String drawEvent ev = replicate (floor $ rs * evStart) '.' ++ (value ev:replicate (floor (rs * (evStop - evStart)) - 1) '-') diff --git a/src/Sound/Tidal/Stream.hs b/src/Sound/Tidal/Stream.hs index 725a51b6..bba195c5 100644 --- a/src/Sound/Tidal/Stream.hs +++ b/src/Sound/Tidal/Stream.hs @@ -29,7 +29,7 @@ module Sound.Tidal.Stream (module Sound.Tidal.Stream) where import Control.Applicative ((<|>)) import Control.Concurrent -import Control.Concurrent.MVar +import Control.Concurrent.MVar () import qualified Control.Exception as E import Control.Monad (forM_, when) import Data.Coerce (coerce) diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs index f7b3890c..4ea4e08f 100644 --- a/src/Sound/Tidal/UI.hs +++ b/src/Sound/Tidal/UI.hs @@ -680,7 +680,7 @@ signifies: @(Int -> Bool)@, a function that takes a whole number and returns either @True@ or @False@. -} ifp :: (Int -> Bool) -> (Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -ifp test f1 f2 p = splitQueries $ p {query = q} +ifp test f1 f2 p = splitQueries $ p {query = q, pureValue = Nothing} where q a | test (floor $ start $ arc a) = query (f1 p) a | otherwise = query (f2 p) a @@ -1492,7 +1492,7 @@ 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} +stretch p = splitQueries $ p {query = q, pureValue = Nothing} where q st = query (zoomArc (cycleArc $ enclosingArc $ map wholeOrPart $ query p (st {arc = Arc (sam s) (nextSam s)})) p) st where s = start $ arc st @@ -1906,7 +1906,7 @@ spaceOut xs p = _slow (toRational $ sum xs) $ stack $ map (`compressArc` p) spac > d1 $ n ("[0,4,7] [-12,-8,-5]") # s "superpiano" # sustain 2 -} flatpat :: Pattern [a] -> Pattern a -flatpat p = p {query = concatMap (\(Event c b b' xs) -> map (Event c b b') xs) . query p} +flatpat p = p {query = concatMap (\(Event c b b' xs) -> map (Event c b b') xs) . query p, pureValue = Nothing} {- | @layer@ takes a list of 'Pattern'-returning functions and a seed element, stacking the result of applying the seed element to each function in the list. @@ -2037,7 +2037,7 @@ rolledWith t = withEvents aux -- | @fill@ 'fills in' gaps in one pattern with events from another. For example @fill "bd" "cp ~ cp"@ would result in the equivalent of `"~ bd ~"`. This only finds gaps in a resulting pattern, in other words @"[bd ~, sn]"@ doesn't contain any gaps (because @sn@ covers it all), and @"bd ~ ~ sn"@ only contains a single gap that bridges two steps. fill :: Pattern a -> Pattern a -> Pattern a -fill p' p = struct (splitQueries $ p {query = q}) p' +fill p' p = struct (splitQueries $ p {query = q, pureValue = Nothing}) p' where q st = removeTolerance (s,e) $ invert (s-tolerance, e+tolerance) $ query p (st {arc = (s-tolerance, e+tolerance)}) where (s,e) = arc st @@ -2764,7 +2764,7 @@ swap things p = filterJust $ (`lookup` things) <$> p > # s "gtr" -} snowball :: Int -> (Pattern a -> Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -snowball depth combinationFunction f pattern = cat $ take depth $ scanl combinationFunction pattern $ drop 1 $ iterate f pattern +snowball depth combinationFunction f pat = cat $ take depth $ scanl combinationFunction pat $ drop 1 $ iterate f pat {- | Applies a function to a pattern and cats the resulting pattern, then continues @@ -2778,7 +2778,7 @@ snowball depth combinationFunction f pattern = cat $ take depth $ scanl combinat > # s "gtr" -} soak :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -soak depth f pattern = cat $ take depth $ iterate f pattern +soak depth f pat = cat $ take depth $ iterate f pat -- | @construct n p@ breaks @p@ into pieces and then reassembles them -- so that it fits into @n@ steps. @@ -2828,7 +2828,7 @@ squeeze _ [] = silence squeeze ipat pats = squeezeJoin $ (pats !!!) <$> ipat squeezeJoinUp :: Pattern (ControlPattern) -> ControlPattern -squeezeJoinUp pp = pp {query = q} +squeezeJoinUp pp = pp {query = q, pureValue = Nothing} where q st = concatMap (f st) (query (filterDigital pp) st) f st (Event c (Just w) p v) = mapMaybe (munge c w p) $ query (compressArc (cycleArc w) (v |* P.speed (pure $ fromRational $ 1/(stop w - start w)))) st {arc = p} diff --git a/test/Sound/Tidal/ExceptionsTest.hs b/test/Sound/Tidal/ExceptionsTest.hs index 3a61ba17..0934111b 100644 --- a/test/Sound/Tidal/ExceptionsTest.hs +++ b/test/Sound/Tidal/ExceptionsTest.hs @@ -16,7 +16,7 @@ run = describe "NFData, forcing and catching exceptions" $ do describe "instance NFData (Pattern a)" $ do it "rnf forces argument" $ do - evaluate (rnf (Pattern undefined Nothing :: Pattern ())) + evaluate (rnf (Pattern undefined Nothing Nothing :: Pattern ())) `shouldThrow` anyException