diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,13 @@ # TidalCycles log of changes +## 1.4.9 - Housebound spirit + * Simplify 'show'ing of patterns @yaxu + * New `draw` function for drawing a pattern of single characters as a text-based diagram, + with friends `drawLine` and `drawLineSz` for drawing multiple cycles @yaxu + * Fixes and expansions of ratio aliases - s should be a sixteenth @mxmxyz, w is now 1, f is now 0.2 + * Simplify definition of `accumulate` using scanl @benjwadams + * The first parameter of `someCyclesBy` is now patternable @bgold-cosmos + ## 1.4.8 - Limerick * Add ratio shorthand to floating point patterns @yaxu * Support fractional scales, add Arabic scales @quakehead diff --git a/src/Sound/Tidal/Context.hs b/src/Sound/Tidal/Context.hs --- a/src/Sound/Tidal/Context.hs +++ b/src/Sound/Tidal/Context.hs @@ -12,6 +12,7 @@ import Sound.Tidal.ParseBP as C import Sound.Tidal.Pattern as C import Sound.Tidal.Scales as C +import Sound.Tidal.Show as C import Sound.Tidal.Simple as C import Sound.Tidal.Stream as C import Sound.Tidal.Transition as C diff --git a/src/Sound/Tidal/ParseBP.hs b/src/Sound/Tidal/ParseBP.hs --- a/src/Sound/Tidal/ParseBP.hs +++ b/src/Sound/Tidal/ParseBP.hs @@ -126,6 +126,14 @@ fromTo :: a -> a -> Pattern a fromThenTo :: a -> a -> a -> Pattern a +instance Parseable Char where + tPatParser = pChar + doEuclid = euclidOff + +instance Enumerable Char where + fromTo = enumFromTo' + fromThenTo a b c = fastFromList [a,b,c] + instance Parseable Double where tPatParser = pDouble doEuclid = euclidOff @@ -244,7 +252,7 @@ ) parseRhythm :: Parseable a => MyParser (TPat a) -> String -> Either ParseError (TPat a) -parseRhythm f = runParser (pSequence f') (0 :: Int) "" +parseRhythm f = runParser (pSequence f' Prelude.<* eof) (0 :: Int) "" where f' = do f <|> do symbol "~" "rest" return TPat_Silence @@ -323,8 +331,12 @@ spaces -- TODO needed/wanted? pMult $ TPat_Polyrhythm (Just $ TPat_Atom Nothing 1) ss + +pCharNum :: MyParser Char +pCharNum = (letter <|> oneOf "0123456789") "letter or number" + pString :: MyParser String -pString = do c <- (letter <|> oneOf "0123456789") "charnum" +pString = do c <- pCharNum "charnum" cs <- many (letter <|> oneOf "0123456789:.-_") "string" return (c:cs) @@ -340,6 +352,9 @@ pVocable :: MyParser (TPat String) pVocable = wrapPos $ (TPat_Atom Nothing) <$> pString +pChar :: MyParser (TPat Char) +pChar = wrapPos $ (TPat_Atom Nothing) <$> pCharNum + pDouble :: MyParser (TPat Double) pDouble = wrapPos $ do f <- choice [intOrFloat, parseNote] "float" do c <- parseChord @@ -477,18 +492,20 @@ <|> pRatioChar pRatioChar :: Fractional a => MyParser a -pRatioChar = do char 'h' - return $ 0.5 +pRatioChar = do char 'w' + return $ 1 + <|> do char 'h' + return $ 0.5 <|> do char 'q' return $ 0.25 <|> do char 'e' return $ 0.125 <|> do char 's' - return $ 0.625 + return $ 0.0625 <|> do char 't' return $ 1/3 <|> do char 'f' - return $ 0.25 + return $ 0.2 pRational :: MyParser (TPat Rational) pRational = wrapPos $ (TPat_Atom Nothing) <$> pRatio diff --git a/src/Sound/Tidal/Pattern.hs b/src/Sound/Tidal/Pattern.hs --- a/src/Sound/Tidal/Pattern.hs +++ b/src/Sound/Tidal/Pattern.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TypeSynonymInstances #-} {-# LANGUAGE DeriveFunctor #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -9,10 +9,9 @@ import Control.Applicative (liftA2) --import Data.Bifunctor (Bifunctor(..)) import Data.Data (Data) -- toConstr -import Data.List (delete, findIndex, sort, intercalate) +import Data.List (delete, findIndex, sort) import qualified Data.Map.Strict as Map -import Data.Maybe (isJust, fromJust, catMaybes, fromMaybe, mapMaybe) -import Data.Ratio (numerator, denominator) +import Data.Maybe (isJust, fromJust, catMaybes, mapMaybe) import Data.Typeable (Typeable) import Control.DeepSeq (NFData(rnf)) import Data.Word (Word8) @@ -51,9 +50,6 @@ NFData (ArcF a) where rnf (Arc s e) = rnf s `seq` rnf e -instance {-# OVERLAPPING #-} Show Arc where - show (Arc s e) = prettyRat s ++ ">" ++ prettyRat e - instance Num a => Num (ArcF a) where negate = fmap negate (+) = liftA2 (+) @@ -142,9 +138,6 @@ instance NFData Context where rnf (Context c) = rnf c -instance Show Context where - show (Context cs) = show cs - combineContexts :: [Context] -> Context combineContexts = Context . concatMap contextPosition @@ -178,15 +171,6 @@ bimap f g (Event w p e) = Event (f w) (f p) (g e) -} -instance {-# OVERLAPPING #-} Show a => Show (Event a) where - show (Event c (Just (Arc ws we)) a@(Arc ps pe) e) = - show c ++ h ++ "(" ++ show a ++ ")" ++ t ++ "|" ++ show e - where h | ws == ps = "" - | otherwise = prettyRat ws ++ "-" - t | we == pe = "" - | otherwise = "-" ++ prettyRat we - show (Event c Nothing a e) = - show c ++ "~" ++ show a ++ "~|" ++ show e isAnalog :: Event a -> Bool isAnalog (Event {whole = Nothing}) = True @@ -607,77 +591,6 @@ instance Fractional ControlMap where recip = fmap (applyFIS recip id id) fromRational = Map.singleton "speed" . VF . fromRational - -showPattern :: Show a => Arc -> Pattern a -> String -showPattern a p = intercalate "\n" $ map show $ queryArc p a - -instance (Show a) => Show (Pattern a) where - show = showPattern (Arc 0 1) - -instance Show Value where - show (VS s) = ('"':s) ++ "\"" - show (VI i) = show i - show (VF f) = show f ++ "f" - show (VR r) = show r ++ "r" - show (VB b) = show b - show (VX xs) = show xs - -instance {-# OVERLAPPING #-} Show ControlMap where - show m = intercalate ", " $ map (\(name, v) -> name ++ ": " ++ show v) $ Map.toList m - -prettyRat :: Rational -> String -prettyRat r | unit == 0 && frac > 0 = showFrac (numerator frac) (denominator frac) - | otherwise = show unit ++ showFrac (numerator frac) (denominator frac) - where unit = floor r :: Int - frac = r - toRational unit - -showFrac :: Integer -> Integer -> String -showFrac 0 _ = "" -showFrac 1 2 = "½" -showFrac 1 3 = "⅓" -showFrac 2 3 = "⅔" -showFrac 1 4 = "¼" -showFrac 3 4 = "¾" -showFrac 1 5 = "⅕" -showFrac 2 5 = "⅖" -showFrac 3 5 = "⅗" -showFrac 4 5 = "⅘" -showFrac 1 6 = "⅙" -showFrac 5 6 = "⅚" -showFrac 1 7 = "⅐" -showFrac 1 8 = "⅛" -showFrac 3 8 = "⅜" -showFrac 5 8 = "⅝" -showFrac 7 8 = "⅞" -showFrac 1 9 = "⅑" -showFrac 1 10 = "⅒" - -showFrac n d = fromMaybe plain $ do n' <- up n - d' <- down d - return $ n' ++ d' - where plain = " " ++ show n ++ "/" ++ show d - up 1 = Just "¹" - up 2 = Just "²" - up 3 = Just "³" - up 4 = Just "⁴" - up 5 = Just "⁵" - up 6 = Just "⁶" - up 7 = Just "⁷" - up 8 = Just "⁸" - up 9 = Just "⁹" - up 0 = Just "⁰" - up _ = Nothing - down 1 = Just "₁" - down 2 = Just "₂" - down 3 = Just "₃" - down 4 = Just "₄" - down 5 = Just "₅" - down 6 = Just "₆" - down 7 = Just "₇" - down 8 = Just "₈" - down 9 = Just "₉" - down 0 = Just "₀" - down _ = Nothing ------------------------------------------------------------------------ -- * Internal functions diff --git a/src/Sound/Tidal/Show.hs b/src/Sound/Tidal/Show.hs new file mode 100644 --- /dev/null +++ b/src/Sound/Tidal/Show.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Sound.Tidal.Show (show, showAll, draw, drawLine) where + +import Sound.Tidal.Pattern + +import Data.List (intercalate, sortOn) +import Data.Ratio (numerator, denominator) +import Data.Maybe (fromMaybe, isJust) + +import qualified Data.Map.Strict as Map + +instance (Show a) => Show (Pattern a) where + show = showPattern (Arc 0 1) + +showPattern :: Show a => Arc -> Pattern a -> String +showPattern a p = intercalate "\n" evStrings + where evs = map showEvent $ sortOn part $ queryArc p a + maxPartLength :: Int + maxPartLength = maximum $ map (length . fst) evs + evString :: (String, String) -> String + evString ev = ((replicate (maxPartLength - (length (fst ev))) ' ') + ++ fst ev + ++ snd ev + ) + evStrings = map evString evs + +showEvent :: Show a => Event a -> (String, String) +showEvent (Event _ (Just (Arc ws we)) a@(Arc ps pe) e) = + (h ++ "(" ++ show a ++ ")" ++ t ++ "|", show e) + where h | ws == ps = "" + | otherwise = prettyRat ws ++ "-" + t | we == pe = "" + | otherwise = "-" ++ prettyRat we + +showEvent (Event _ Nothing a e) = + ("~" ++ show a ++ "~|", show e) + +-- Show everything, including event context +showAll :: Show a => Arc -> Pattern a -> String +showAll a p = intercalate "\n" $ map show $ sortOn part $ queryArc p a + +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 (VR r) = show r ++ "r" + show (VB b) = show b + show (VX xs) = show xs + +instance {-# OVERLAPPING #-} Show ControlMap where + show m = intercalate ", " $ map (\(name, v) -> name ++ ": " ++ show v) $ Map.toList m + +instance {-# OVERLAPPING #-} Show Arc where + show (Arc s e) = prettyRat s ++ ">" ++ prettyRat e + +instance {-# OVERLAPPING #-} Show a => Show (Event a) where + show e = show (context e) ++ ((\(a,b) -> a ++ b) $ showEvent e) + +prettyRat :: Rational -> String +prettyRat r | unit == 0 && frac > 0 = showFrac (numerator frac) (denominator frac) + | otherwise = show unit ++ showFrac (numerator frac) (denominator frac) + where unit = floor r :: Int + frac = r - toRational unit + +showFrac :: Integer -> Integer -> String +showFrac 0 _ = "" +showFrac 1 2 = "½" +showFrac 1 3 = "⅓" +showFrac 2 3 = "⅔" +showFrac 1 4 = "¼" +showFrac 3 4 = "¾" +showFrac 1 5 = "⅕" +showFrac 2 5 = "⅖" +showFrac 3 5 = "⅗" +showFrac 4 5 = "⅘" +showFrac 1 6 = "⅙" +showFrac 5 6 = "⅚" +showFrac 1 7 = "⅐" +showFrac 1 8 = "⅛" +showFrac 3 8 = "⅜" +showFrac 5 8 = "⅝" +showFrac 7 8 = "⅞" +showFrac 1 9 = "⅑" +showFrac 1 10 = "⅒" + +showFrac n d = fromMaybe plain $ do n' <- up n + d' <- down d + return $ n' ++ d' + where plain = show n ++ "/" ++ show d + up 1 = Just "¹" + up 2 = Just "²" + up 3 = Just "³" + up 4 = Just "⁴" + up 5 = Just "⁵" + up 6 = Just "⁶" + up 7 = Just "⁷" + up 8 = Just "⁸" + up 9 = Just "⁹" + up 0 = Just "⁰" + up _ = Nothing + down 1 = Just "₁" + down 2 = Just "₂" + down 3 = Just "₃" + down 4 = Just "₄" + down 5 = Just "₅" + down 6 = Just "₆" + down 7 = Just "₇" + down 8 = Just "₈" + down 9 = Just "₉" + down 0 = Just "₀" + down _ = Nothing + +stepcount :: Pattern a -> Int +stepcount pat = fromIntegral $ eventSteps $ concatMap (\ev -> [start ev, stop ev]) $ map part $ filter eventHasOnset $ queryArc pat (Arc 0 1) + where eventSteps xs = foldr lcm 1 $ map denominator xs + +data Render = Render Int Int String + +instance Show Render where + show (Render cyc i render) | i <= 1024 = "\n[" ++ show cyc ++ (if cyc == 1 then " cycle" else " cycles") ++ "]\n" ++ render + | otherwise = "That pattern is too complex to draw." + + +drawLine :: Pattern Char -> Render +drawLine = drawLineSz 78 + +drawLineSz :: Int -> Pattern Char -> Render +drawLineSz sz pat = joinCycles sz $ drawCycles pat + where + drawCycles :: Pattern Char -> [Render] + drawCycles pat' = (draw pat'):(drawCycles $ rotL 1 pat') + joinCycles :: Int -> [Render] -> Render + joinCycles _ [] = Render 0 0 "" + joinCycles n ((Render cyc l s):cs) | l > n = Render 0 0 "" + | otherwise = Render (cyc+cyc') (l + l' + 1) $ intercalate "\n" $ map (\(a,b) -> a ++ b) lineZip + where + (Render cyc' l' s') = joinCycles (n-l-1) cs + linesN = max (length $ lines s) (length $ lines s') + lineZip = take linesN $ + zip (lines s ++ (repeat $ replicate l ' ')) + (lines s' ++ (repeat $ replicate l' ' ')) + + -- where maximum (map (length . head . (++ [""]) . lines) cs) + + +draw :: Pattern Char -> Render +draw pat = Render 1 s $ (intercalate "\n" $ map ((\x -> ('|':x)) .drawLevel) ls) + where ls = levels pat + s = stepcount pat + rs = toRational s + drawLevel :: [Event Char] -> String + drawLevel [] = replicate s ' ' + drawLevel (e:es) = map f $ take s $ zip (drawLevel es ++ repeat ' ') (drawEvent e ++ repeat ' ') + f (' ', x) = x + f (x, _) = x + drawEvent :: Event Char -> String + drawEvent ev = (replicate (floor $ rs * evStart) ' ') + ++ (value ev:(replicate ((floor $ rs * (evStop - evStart)) - 1) '-')) + where evStart = start $ wholeOrPart ev + evStop = stop $ wholeOrPart ev + +{- +fitsWhole :: Event b -> [Event b] -> Bool +fitsWhole event events = + not $ any (\event' -> isJust $ subArc (wholeOrPart event) (wholeOrPart event')) events + +addEventWhole :: Event b -> [[Event b]] -> [[Event b]] +addEventWhole e [] = [[e]] +addEventWhole e (level:ls) + | isAnalog e = level:ls + | fitsWhole e level = (e:level) : ls + | otherwise = level : addEventWhole e ls + +arrangeEventsWhole :: [Event b] -> [[Event b]] +arrangeEventsWhole = foldr addEventWhole [] + +levelsWhole :: Eq a => Pattern a -> [[Event a]] +levelsWhole pat = arrangeEventsWhole $ sortOn' ((\Arc{..} -> 0 - (stop - start)) . wholeOrPart) (defragParts $ queryArc pat (Arc 0 1)) + +sortOn' :: Ord a => (b -> a) -> [b] -> [b] +sortOn' f = map snd . sortOn fst . map (\x -> let y = f x in y `seq` (y, x)) +-} + +fits :: Event b -> [Event b] -> Bool +fits (Event _ _ part' _) events = not $ any (\Event{..} -> isJust $ subArc part' part) events + +addEvent :: Event b -> [[Event b]] -> [[Event b]] +addEvent e [] = [[e]] +addEvent e (level:ls) + | fits e level = (e:level) : ls + | otherwise = level : addEvent e ls + +arrangeEvents :: [Event b] -> [[Event b]] +arrangeEvents = foldr addEvent [] + +levels :: Eq a => Pattern a -> [[Event a]] +-- levels pat = arrangeEvents $ sortOn' ((\Arc{..} -> stop - start) . part) (defragParts $ queryArc pat (Arc 0 1)) +levels pat = arrangeEvents $ reverse $ defragParts $ queryArc pat (Arc 0 1) diff --git a/src/Sound/Tidal/Stream.hs b/src/Sound/Tidal/Stream.hs --- a/src/Sound/Tidal/Stream.hs +++ b/src/Sound/Tidal/Stream.hs @@ -25,6 +25,7 @@ -- import qualified Sound.OSC.Datum as O import Data.List (sortOn) import System.Random (getStdRandom, randomR) +import Sound.Tidal.Show () data TimeStamp = BundleStamp | MessageStamp | NoStamp deriving (Eq, Show) diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs --- a/src/Sound/Tidal/UI.hs +++ b/src/Sound/Tidal/UI.hs @@ -261,11 +261,14 @@ {- | @someCyclesBy@ is a cycle-by-cycle version of @sometimesBy@. It has a `someCycles = someCyclesBy 0.5` alias -} -someCyclesBy :: Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -someCyclesBy x = when test +someCyclesBy :: Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +someCyclesBy pd f p = do {d <- pd; _someCyclesBy d f p} + +_someCyclesBy :: Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +_someCyclesBy x = when test where test c = timeToRand (fromIntegral c :: Double) < x -somecyclesBy :: Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +somecyclesBy :: Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a somecyclesBy = someCyclesBy someCycles :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a diff --git a/src/Sound/Tidal/Utils.hs b/src/Sound/Tidal/Utils.hs --- a/src/Sound/Tidal/Utils.hs +++ b/src/Sound/Tidal/Utils.hs @@ -53,9 +53,8 @@ nth n (_ : xs) = nth (n - 1) xs accumulate :: Num t => [t] -> [t] -accumulate = accumulate' 0 - where accumulate' _ [] = [] - accumulate' n (a:xs) = (n+a) : accumulate' (n+a) xs +accumulate [] = [] +accumulate (x:xs) = scanl (+) x xs {- | enumerate a list of things diff --git a/src/Sound/Tidal/Version.hs b/src/Sound/Tidal/Version.hs --- a/src/Sound/Tidal/Version.hs +++ b/src/Sound/Tidal/Version.hs @@ -1,4 +1,4 @@ module Sound.Tidal.Version where tidal_version :: String -tidal_version = "1.4.8" +tidal_version = "1.4.9" diff --git a/test/TestUtils.hs b/test/TestUtils.hs --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -8,8 +8,7 @@ import Data.List (sort) -import Sound.Tidal.ParseBP (parseBP_E) -import Sound.Tidal.Pattern +import Sound.Tidal.Context import qualified Data.Map.Strict as Map diff --git a/tidal.cabal b/tidal.cabal --- a/tidal.cabal +++ b/tidal.cabal @@ -1,5 +1,5 @@ name: tidal -version: 1.4.8 +version: 1.4.9 synopsis: Pattern language for improvised music -- description: homepage: http://tidalcycles.org/ @@ -37,6 +37,7 @@ Sound.Tidal.ParseBP Sound.Tidal.Pattern Sound.Tidal.Scales + Sound.Tidal.Show Sound.Tidal.Simple Sound.Tidal.Stream Sound.Tidal.Tempo