tidal 1.4.8 → 1.4.9
raw patch · 11 files changed
+251/−106 lines, 11 files
Files
- CHANGELOG.md +8/−0
- src/Sound/Tidal/Context.hs +1/−0
- src/Sound/Tidal/ParseBP.hs +23/−6
- src/Sound/Tidal/Pattern.hs +3/−90
- src/Sound/Tidal/Show.hs +203/−0
- src/Sound/Tidal/Stream.hs +1/−0
- src/Sound/Tidal/UI.hs +6/−3
- src/Sound/Tidal/Utils.hs +2/−3
- src/Sound/Tidal/Version.hs +1/−1
- test/TestUtils.hs +1/−2
- tidal.cabal +2/−1
CHANGELOG.md view
@@ -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
src/Sound/Tidal/Context.hs view
@@ -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
src/Sound/Tidal/ParseBP.hs view
@@ -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
src/Sound/Tidal/Pattern.hs view
@@ -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
+ src/Sound/Tidal/Show.hs view
@@ -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)
src/Sound/Tidal/Stream.hs view
@@ -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)
src/Sound/Tidal/UI.hs view
@@ -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
src/Sound/Tidal/Utils.hs view
@@ -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
src/Sound/Tidal/Version.hs view
@@ -1,4 +1,4 @@ module Sound.Tidal.Version where tidal_version :: String-tidal_version = "1.4.8"+tidal_version = "1.4.9"
test/TestUtils.hs view
@@ -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
tidal.cabal view
@@ -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