tidal 0.2.4 → 0.2.6
raw patch · 20 files changed
+1143/−1109 lines, 20 filesdep ~hoscdep ~websockets
Dependency ranges changed: hosc, websockets
Files
- Dirt.hs +0/−129
- Parse.hs +0/−170
- Pattern.hs +0/−213
- Sound/Tidal/Dirt.hs +128/−0
- Sound/Tidal/Parse.hs +171/−0
- Sound/Tidal/Pattern.hs +224/−0
- Sound/Tidal/Strategies.hs +105/−0
- Sound/Tidal/Stream.hs +179/−0
- Sound/Tidal/Tempo.hs +193/−0
- Sound/Tidal/Time.hs +41/−0
- Sound/Tidal/Utils.hs +27/−0
- Strategies.hs +0/−98
- Stream.hs +0/−171
- Tempo.hs +0/−193
- Time.hs +0/−41
- Utils.hs +0/−27
- doc/tidal.pandoc +55/−30
- doc/tidal.pdf binary
- tidal.cabal +13/−5
- tidal.el +7/−32
− Dirt.hs
@@ -1,129 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}- -module Dirt where--import Stream-import Pattern-import Parse-import Sound.OSC.FD-import qualified Data.Map as Map-import Control.Applicative-import Control.Concurrent.MVar---import Visual-import Data.Colour.SRGB-import Data.Colour.Names-import Data.Hashable-import Data.Bits-import Data.Maybe-import System.Process--dirt :: OscShape-dirt = OscShape {path = "/play",- params = [ S "sound" Nothing,- F "offset" (Just 0),- F "begin" (Just 0),- F "end" (Just 1),- F "speed" (Just 1),- F "pan" (Just 0.5),- F "velocity" (Just 0),- S "vowel" (Just ""),- F "cutoff" (Just 0),- F "resonance" (Just 0),- F "accellerate" (Just 0),- F "shape" (Just 0),- I "kriole" (Just 0)- ],- timestamp = True- }---kriole :: OscShape-kriole = OscShape {path = "/kriole",- params = [ S "kdur" Nothing,- F "kstart" (Just 0),- F "kstop" (Just 0)- ],- timestamp = True- }--dirtstart name = start "127.0.0.1" 7771 dirt-dirtstream name = stream "127.0.0.1" 7771 dirt-kstream name = stream "127.0.0.1" 7771 kriole--doubledirt = do remote <- stream "178.77.72.138" 7777 dirt- local <- stream "192.168.0.102" 7771 dirt- return $ \p -> do remote p- local p- return ()---dirtToColour :: OscPattern -> Pattern ColourD-dirtToColour p = s- where s = fmap (\x -> maybe black (maybe black datumToColour) (Map.lookup (param dirt "sound") x)) p--datumToColour :: Datum -> ColourD-datumToColour = stringToColour . show--stringToColour :: String -> ColourD-stringToColour s = sRGB (r/256) (g/256) (b/256)- where i = (hash s) `mod` 16777216- r = fromIntegral $ (i .&. 0xFF0000) `shiftR` 16;- g = fromIntegral $ (i .&. 0x00FF00) `shiftR` 8;- b = fromIntegral $ (i .&. 0x0000FF);---{--visualcallback :: IO (OscPattern -> IO ())-visualcallback = do t <- ticker- mv <- startVis t- let f p = do let p' = dirtToColour p- swapMVar mv p'- return ()- return f--}----dirtyvisualstream name = do cb <- visualcallback--- streamcallback cb "127.0.0.1" "127.0.0.1" name "127.0.0.1" 7771 dirt- --sound = makeS dirt "sound"-offset = makeF dirt "offset"-begin = makeF dirt "begin"-end = makeF dirt "end"-speed = makeF dirt "speed"-pan = makeF dirt "pan"-velocity = makeF dirt "velocity"-vowel = makeS dirt "vowel"-cutoff = makeF dirt "cutoff"-resonance = makeF dirt "resonance"-accellerate = makeF dirt "accellerate"-shape = makeF dirt "shape"---kdur = makeF kriole "kdur"-kstart = makeF kriole "kstart"-kstop = makeF kriole "kstop"--pick :: String -> Int -> String-pick name n = name ++ "/" ++ (show n)--striate :: Int -> OscPattern -> OscPattern-striate n p = cat $ map (\x -> off (fromIntegral x) p) [0 .. n-1]- where off i p = p - |+| begin (atom (fromIntegral i / fromIntegral n)) - |+| end (atom (fromIntegral (i+1) / fromIntegral n))--striate' :: Int -> Double -> OscPattern -> OscPattern-striate' n f p = cat $ map (\x -> off (fromIntegral x) p) [0 .. n-1]- where off i p = p |+| begin (atom (slot * i) :: Pattern Double) |+| end (atom ((slot * i) + f) :: Pattern Double)- slot = (1 - f) / (fromIntegral n)---striateO :: OscPattern -> Int -> Double -> OscPattern-striateO p n o = cat $ map (\x -> off (fromIntegral x) p) [0 .. n-1]- where off i p = p |+| begin ((atom $ (fromIntegral i / fromIntegral n) + o) :: Pattern Double) |+| end ((atom $ (fromIntegral (i+1) / fromIntegral n) + o) :: Pattern Double)--metronome = slow 2 $ sound (p "[odx, [hh]*8]")--interlace :: OscPattern -> OscPattern -> OscPattern-interlace a b = weave 16 (shape $ ((* 0.9) <$> sinewave1)) [a, b]
− Parse.hs
@@ -1,170 +0,0 @@-{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, OverlappingInstances, IncoherentInstances, FlexibleInstances #-}--module Parse where--import Text.ParserCombinators.Parsec-import qualified Text.ParserCombinators.Parsec.Token as P-import Text.ParserCombinators.Parsec.Language ( haskellDef )-import Pattern-import Data.Ratio-import Data.Colour-import Data.Colour.Names-import Data.Colour.SRGB-import GHC.Exts( IsString(..) )-import Data.Monoid-import Control.Exception as E--class Parseable a where- p :: String -> Pattern a--instance Parseable Double where- p = parseRhythm pDouble--instance Parseable String where- p = parseRhythm pVocable--instance Parseable Bool where- p = parseRhythm pBool--instance Parseable Int where- p = parseRhythm pInt--instance Parseable Rational where- p = parseRhythm pRational--type ColourD = Colour Double--instance Parseable ColourD where- p = parseRhythm pColour--instance (Parseable a) => IsString (Pattern a) where- fromString = p----instance (Parseable a, Pattern p) => IsString (p a) where--- fromString = p :: String -> p a--lexer = P.makeTokenParser haskellDef-braces = P.braces lexer-brackets = P.brackets lexer-parens = P.parens lexer-angles = P.angles lexer-symbol = P.symbol lexer-natural = P.natural lexer-float = P.float lexer-naturalOrFloat = P.naturalOrFloat lexer--data Sign = Positive | Negative--applySign :: Num a => Sign -> a -> a-applySign Positive = id-applySign Negative = negate--sign :: Parser Sign-sign = do char '-'- return Negative- <|> do char '+'- return Positive- <|> return Positive--intOrFloat :: Parser (Either Integer Double)-intOrFloat = do s <- sign- num <- naturalOrFloat- return (case num of- Right x -> Right (applySign s x)- Left x -> Left (applySign s x)- )--r :: Parseable a => String -> Pattern a -> IO (Pattern a)-r s orig = do E.handle - (\err -> do putStrLn (show (err :: E.SomeException))- return orig - )- (return $ p s)--parseRhythm :: Parser (Pattern a) -> String -> (Pattern a)-parseRhythm f input = either (const silence) id $ parse (pRhythm f') "" input- where f' = f- <|> do symbol "~" <?> "rest"- return silence--pRhythm :: Parser (Pattern a) -> GenParser Char () (Pattern a)-pRhythm f = do spaces- pSequence f--pSequence :: Parser (Pattern a) -> GenParser Char () (Pattern a)-pSequence f = do d <- pDensity- ps <- many $ pPart f- return $ density d $ cat ps--pSingle :: Parser (Pattern a) -> Parser (Pattern a)-pSingle f = do part <- f- pMult part--pPart :: Parser (Pattern a) -> Parser (Pattern a)-pPart f = do part <- parens (pSequence f) <|> pSingle f <|> pPoly f- spaces- return part--pPoly :: Parser (Pattern a) -> Parser (Pattern a)-pPoly f = do ps <- brackets (pRhythm f `sepBy` symbol ",")- spaces- pMult $ mconcat ps--pString :: Parser (String)-pString = many1 (letter <|> oneOf "0123456789" <|> char '/') <?> "string"--pVocable :: Parser (Pattern String)-pVocable = do v <- pString- return $ atom v--pDouble :: Parser (Pattern Double)-pDouble = do nf <- intOrFloat <?> "float"- let f = either fromIntegral id nf- return $ atom f--pBool :: Parser (Pattern Bool)-pBool = do oneOf "t1"- return $ atom True- <|>- do oneOf "f0"- return $ atom False--pInt :: Parser (Pattern Int)-pInt = do i <- natural <?> "integer"- return $ atom (fromIntegral i)--pColour :: Parser (Pattern ColourD)-pColour = do name <- many1 letter <?> "colour name"- colour <- readColourName name <?> "known colour"- return $ atom colour--pMult :: Pattern a -> Parser (Pattern a)-pMult thing = do char '*'- spaces- r <- pRatio- return $ density r thing- <|>- do char '/'- spaces- r <- pRatio- return $ slow r thing- <|>- return thing--pRatio :: Parser (Rational)-pRatio = do n <- natural <?> "numerator"- d <- do oneOf "/%"- natural <?> "denominator"- <|>- return 1- return $ n % d--pRational :: Parser (Pattern Rational)-pRational = do r <- pRatio- return $ atom r--pDensity :: Parser (Rational)-pDensity = angles (pRatio <?> "ratio")- <|>- return (1 % 1)-
− Pattern.hs
@@ -1,213 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--module Pattern where--import Control.Applicative-import Data.Monoid-import Data.Fixed-import Data.List-import Data.Maybe-import Data.Ratio-import Debug.Trace-import Data.Typeable-import Data.Function-import System.Random.Mersenne.Pure64-import Time-import Utils--data Pattern a = Pattern {arc :: Arc -> [Event a]}--instance (Show a) => Show (Pattern a) where- show p@(Pattern _) = show $ arc p (0, 1)- -instance Functor Pattern where- fmap f (Pattern a) = Pattern $ fmap (fmap (mapSnd f)) a--instance Applicative Pattern where- pure = atom- (Pattern fs) <*> (Pattern xs) = Pattern $ \a -> concatMap applyX (fs a)- where applyX ((s,e), f) = - map (\(_, x) -> ((s,e), f x)) (filter - (\(a', _) -> isIn a' s)- (xs (s,e))- )--instance Monoid (Pattern a) where- mempty = silence- mappend x y = Pattern $ \a -> (arc x a) ++ (arc y a)--instance Monad Pattern where- return = pure- p >>= f = - Pattern (\a -> concatMap- (\((s,e), x) -> mapFsts (const (s,e)) $- filter- (\(a', _) -> isIn a' s)- (arc (f x) (s,e))- )- (arc p a)- )--atom :: a -> Pattern a-atom x = Pattern f- where f (s, e) = map - (\t -> ((t%1, (t+1)%1), x))- [floor s .. ((ceiling e) - 1)]--silence :: Pattern a-silence = Pattern $ const []--mapQueryArc :: (Arc -> Arc) -> Pattern a -> Pattern a-mapQueryArc f p = Pattern $ \a -> arc p (f a)--mapQueryTime :: (Time -> Time) -> Pattern a -> Pattern a-mapQueryTime = mapQueryArc . mapArc--mapResultArc :: (Arc -> Arc) -> Pattern a -> Pattern a-mapResultArc f p = Pattern $ \a -> mapFsts f $ arc p a--mapResultTime :: (Time -> Time) -> Pattern a -> Pattern a-mapResultTime = mapResultArc . mapArc--overlay :: Pattern a -> Pattern a -> Pattern a-overlay p p' = Pattern $ \a -> (arc p a) ++ (arc p' a)--(>+<) = overlay--stack :: [Pattern a] -> Pattern a-stack ps = foldr overlay silence ps--cat :: [Pattern a] -> Pattern a-cat ps = density (fromIntegral $ length ps) $ slowcat ps--append :: Pattern a -> Pattern a -> Pattern a-append a b = cat [a,b]--append' :: Pattern a -> Pattern a -> Pattern a-append' a b = slow 2 $ cat [a,b]--slowcat' ps = Pattern $ \a -> concatMap f (arcCycles a)- where l = length ps- f (s,e) = arc p (s,e)- where p = ps !! n- n = (floor s) `mod` l---- Concatenates so that the first loop of each pattern is played in--- turn, second loop of each pattern, and so on..--slowcat :: [Pattern a] -> Pattern a-slowcat [] = silence-slowcat ps = Pattern $ \a -> concatMap f (arcCycles a)- where l = length ps- f (s,e) = arc (mapResultTime (+offset) p) (s',e')- where p = ps !! n- r = (floor s) :: Int- n = (r `mod` l) :: Int- offset = (fromIntegral $ r - ((r - n) `div` l)) :: Time- (s', e') = (s-offset, e-offset)--listToPat :: [a] -> Pattern a-listToPat = cat . map atom--run n = listToPat [0 .. n-1]--maybeListToPat :: [Maybe a] -> Pattern a-maybeListToPat = cat . map f- where f Nothing = silence- f (Just x) = atom x--density :: Time -> Pattern a -> Pattern a-density 0 p = p-density 1 p = p-density r p = mapResultTime (/ r) $ mapQueryTime (* r) p--slow :: Time -> Pattern a -> Pattern a-slow 0 = id-slow t = density (1/t) --(<~) :: Time -> Pattern a -> Pattern a-(<~) t p = filterOffsets $ mapResultTime (+ t) $ mapQueryTime (subtract t) p--(~>) :: Time -> Pattern a -> Pattern a-(~>) = (<~) . (0-)--rev :: Pattern a -> Pattern a-rev p = Pattern $ \a -> concatMap - (\a' -> mapFsts mirrorArc $ - (arc p (mirrorArc a')))- (arcCycles a)--when :: (Int -> Bool) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-when test f p = Pattern $ \a -> concatMap apply (arcCycles a)- where apply a | test (floor $ fst a) = (arc $ f p) a- | otherwise = (arc p) a--every :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-every 0 f p = p-every n f p = when ((== 0) . (`mod` n)) f p--palindrome :: Pattern a -> Pattern a-palindrome p = slowcat [p, rev p]--sig :: (Time -> a) -> Pattern a-sig f = Pattern f'- where f' (s,e) | s > e = []- | otherwise = [((s,e), f s)]--sinewave :: Pattern Double-sinewave = sig $ \t -> sin $ pi * 2 * (fromRational t)--sinewave1 :: Pattern Double-sinewave1 = fmap ((/ 2) . (+ 1)) sinewave--sinePhase1 :: Double -> Pattern Double-sinePhase1 offset = (+ offset) <$> sinewave1--triwave1 :: Pattern Double-triwave1 = sig $ \t -> mod' (fromRational t) 1--triwave :: Pattern Double-triwave = ((subtract 1) . (* 2)) <$> triwave1--squarewave1 :: Pattern Double-squarewave1 = sig $ - \t -> fromIntegral $ floor $ (mod' (fromRational t) 1) * 2--squarewave :: Pattern Double-squarewave = ((subtract 1) . (* 2)) <$> squarewave1---- Filter out events that start before range-filterOffsets :: Pattern a -> Pattern a-filterOffsets (Pattern f) = - Pattern $ \(s, e) -> filter ((>= s) . eventStart) $ f (s, e)--seqToRelOnsets :: Arc -> Pattern a -> [(Double, a)]-seqToRelOnsets (s, e) p = mapFsts (fromRational . (/ (e-s)) . (subtract s) . fst) $ arc (filterOffsets p) (s, e)--segment :: Pattern a -> Pattern [a]-segment p = Pattern $ \(s,e) -> filter (\((s',e'),_) -> s' < e && e' > s) $ groupByTime (segment' (arc p (s,e)))--segment' :: [Event a] -> [Event a]-segment' es = foldr split es pts- where pts = nub $ points es--split :: Time -> [Event a] -> [Event a]-split _ [] = []-split t ((ev@((s,e), v)):es) | t > s && t < e = ((s,t),v):((t,e),v):(split t es)- | otherwise = ev:split t es--points :: [Event a] -> [Time]-points [] = []-points (((s,e), _):es) = s:e:(points es)--groupByTime :: [Event a] -> [Event [a]]-groupByTime es = map mrg $ groupBy ((==) `on` fst) $ sortBy (compare `on` fst) es- where mrg es@((a, _):_) = (a, map snd es)--ifp :: (Int -> Bool) -> (Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-ifp test f1 f2 p = Pattern $ \a -> concatMap apply (arcCycles a)- where apply a | test (floor $ fst a) = (arc $ f1 p) a- | otherwise = (arc $ f2 p) a--rand :: Pattern Double-rand = Pattern $ \a -> [(a, fst $ randomDouble $ pureMT $ floor $ (*1000000) $ (midPoint a))]
+ Sound/Tidal/Dirt.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+ +module Sound.Tidal.Dirt where++import Sound.OSC.FD+import qualified Data.Map as Map+import Control.Applicative+import Control.Concurrent.MVar+--import Visual+import Data.Colour.SRGB+import Data.Colour.Names+import Data.Hashable+import Data.Bits+import Data.Maybe+import System.Process++import Sound.Tidal.Stream+import Sound.Tidal.Pattern+import Sound.Tidal.Parse++dirt :: OscShape+dirt = OscShape {path = "/play",+ params = [ S "sound" Nothing,+ F "offset" (Just 0),+ F "begin" (Just 0),+ F "end" (Just 1),+ F "speed" (Just 1),+ F "pan" (Just 0.5),+ F "velocity" (Just 0),+ S "vowel" (Just ""),+ F "cutoff" (Just 0),+ F "resonance" (Just 0),+ F "accellerate" (Just 0),+ F "shape" (Just 0),+ I "kriole" (Just 0)+ ],+ timestamp = True+ }+++kriole :: OscShape+kriole = OscShape {path = "/trigger",+ params = [ I "ksymbol" Nothing,+ F "kpitch" (Just 1)+ ],+ timestamp = True+ }++dirtstart name = start "127.0.0.1" 7771 dirt+dirtstream name = stream "127.0.0.1" 7771 dirt+kstream name = stream "127.0.0.1" 6040 kriole++doubledirt = do remote <- stream "178.77.72.138" 7777 dirt+ local <- stream "192.168.0.102" 7771 dirt+ return $ \p -> do remote p+ local p+ return ()+++dirtToColour :: OscPattern -> Pattern ColourD+dirtToColour p = s+ where s = fmap (\x -> maybe black (maybe black datumToColour) (Map.lookup (param dirt "sound") x)) p++datumToColour :: Datum -> ColourD+datumToColour = stringToColour . show++stringToColour :: String -> ColourD+stringToColour s = sRGB (r/256) (g/256) (b/256)+ where i = (hash s) `mod` 16777216+ r = fromIntegral $ (i .&. 0xFF0000) `shiftR` 16;+ g = fromIntegral $ (i .&. 0x00FF00) `shiftR` 8;+ b = fromIntegral $ (i .&. 0x0000FF);+++{-+visualcallback :: IO (OscPattern -> IO ())+visualcallback = do t <- ticker+ mv <- startVis t+ let f p = do let p' = dirtToColour p+ swapMVar mv p'+ return ()+ return f+-}++--dirtyvisualstream name = do cb <- visualcallback+-- streamcallback cb "127.0.0.1" "127.0.0.1" name "127.0.0.1" 7771 dirt+ ++sound = makeS dirt "sound"+offset = makeF dirt "offset"+begin = makeF dirt "begin"+end = makeF dirt "end"+speed = makeF dirt "speed"+pan = makeF dirt "pan"+velocity = makeF dirt "velocity"+vowel = makeS dirt "vowel"+cutoff = makeF dirt "cutoff"+resonance = makeF dirt "resonance"+accellerate = makeF dirt "accellerate"+shape = makeF dirt "shape"++ksymbol = makeF kriole "ksymbol"+kpitch = makeF kriole "kpitch"+++pick :: String -> Int -> String+pick name n = name ++ "/" ++ (show n)++striate :: Int -> OscPattern -> OscPattern+striate n p = cat $ map (\x -> off (fromIntegral x) p) [0 .. n-1]+ where off i p = p + |+| begin (atom (fromIntegral i / fromIntegral n)) + |+| end (atom (fromIntegral (i+1) / fromIntegral n))++striate' :: Int -> Double -> OscPattern -> OscPattern+striate' n f p = cat $ map (\x -> off (fromIntegral x) p) [0 .. n-1]+ where off i p = p |+| begin (atom (slot * i) :: Pattern Double) |+| end (atom ((slot * i) + f) :: Pattern Double)+ slot = (1 - f) / (fromIntegral n)+++striateO :: OscPattern -> Int -> Double -> OscPattern+striateO p n o = cat $ map (\x -> off (fromIntegral x) p) [0 .. n-1]+ where off i p = p |+| begin ((atom $ (fromIntegral i / fromIntegral n) + o) :: Pattern Double) |+| end ((atom $ (fromIntegral (i+1) / fromIntegral n) + o) :: Pattern Double)++metronome = slow 2 $ sound (p "[odx, [hh]*8]")++interlace :: OscPattern -> OscPattern -> OscPattern+interlace a b = weave 16 (shape $ ((* 0.9) <$> sinewave1)) [a, b]
+ Sound/Tidal/Parse.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, OverlappingInstances, IncoherentInstances, FlexibleInstances #-}++module Sound.Tidal.Parse where++import Text.ParserCombinators.Parsec+import qualified Text.ParserCombinators.Parsec.Token as P+import Text.ParserCombinators.Parsec.Language ( haskellDef )+import Data.Ratio+import Data.Colour+import Data.Colour.Names+import Data.Colour.SRGB+import GHC.Exts( IsString(..) )+import Data.Monoid+import Control.Exception as E++import Sound.Tidal.Pattern++class Parseable a where+ p :: String -> Pattern a++instance Parseable Double where+ p = parseRhythm pDouble++instance Parseable String where+ p = parseRhythm pVocable++instance Parseable Bool where+ p = parseRhythm pBool++instance Parseable Int where+ p = parseRhythm pInt++instance Parseable Rational where+ p = parseRhythm pRational++type ColourD = Colour Double++instance Parseable ColourD where+ p = parseRhythm pColour++instance (Parseable a) => IsString (Pattern a) where+ fromString = p++--instance (Parseable a, Pattern p) => IsString (p a) where+-- fromString = p :: String -> p a++lexer = P.makeTokenParser haskellDef+braces = P.braces lexer+brackets = P.brackets lexer+parens = P.parens lexer+angles = P.angles lexer+symbol = P.symbol lexer+natural = P.natural lexer+float = P.float lexer+naturalOrFloat = P.naturalOrFloat lexer++data Sign = Positive | Negative++applySign :: Num a => Sign -> a -> a+applySign Positive = id+applySign Negative = negate++sign :: Parser Sign+sign = do char '-'+ return Negative+ <|> do char '+'+ return Positive+ <|> return Positive++intOrFloat :: Parser (Either Integer Double)+intOrFloat = do s <- sign+ num <- naturalOrFloat+ return (case num of+ Right x -> Right (applySign s x)+ Left x -> Left (applySign s x)+ )++r :: Parseable a => String -> Pattern a -> IO (Pattern a)+r s orig = do E.handle + (\err -> do putStrLn (show (err :: E.SomeException))+ return orig + )+ (return $ p s)++parseRhythm :: Parser (Pattern a) -> String -> (Pattern a)+parseRhythm f input = either (const silence) id $ parse (pRhythm f') "" input+ where f' = f+ <|> do symbol "~" <?> "rest"+ return silence++pRhythm :: Parser (Pattern a) -> GenParser Char () (Pattern a)+pRhythm f = do spaces+ pSequence f++pSequence :: Parser (Pattern a) -> GenParser Char () (Pattern a)+pSequence f = do d <- pDensity+ ps <- many $ pPart f+ return $ density d $ cat ps++pSingle :: Parser (Pattern a) -> Parser (Pattern a)+pSingle f = do part <- f+ pMult part++pPart :: Parser (Pattern a) -> Parser (Pattern a)+pPart f = do part <- parens (pSequence f) <|> pSingle f <|> pPoly f+ spaces+ return part++pPoly :: Parser (Pattern a) -> Parser (Pattern a)+pPoly f = do ps <- brackets (pRhythm f `sepBy` symbol ",")+ spaces+ pMult $ mconcat ps++pString :: Parser (String)+pString = many1 (letter <|> oneOf "0123456789" <|> char '/') <?> "string"++pVocable :: Parser (Pattern String)+pVocable = do v <- pString+ return $ atom v++pDouble :: Parser (Pattern Double)+pDouble = do nf <- intOrFloat <?> "float"+ let f = either fromIntegral id nf+ return $ atom f++pBool :: Parser (Pattern Bool)+pBool = do oneOf "t1"+ return $ atom True+ <|>+ do oneOf "f0"+ return $ atom False++pInt :: Parser (Pattern Int)+pInt = do i <- natural <?> "integer"+ return $ atom (fromIntegral i)++pColour :: Parser (Pattern ColourD)+pColour = do name <- many1 letter <?> "colour name"+ colour <- readColourName name <?> "known colour"+ return $ atom colour++pMult :: Pattern a -> Parser (Pattern a)+pMult thing = do char '*'+ spaces+ r <- pRatio+ return $ density r thing+ <|>+ do char '/'+ spaces+ r <- pRatio+ return $ slow r thing+ <|>+ return thing++pRatio :: Parser (Rational)+pRatio = do n <- natural <?> "numerator"+ d <- do oneOf "/%"+ natural <?> "denominator"+ <|>+ return 1+ return $ n % d++pRational :: Parser (Pattern Rational)+pRational = do r <- pRatio+ return $ atom r++pDensity :: Parser (Rational)+pDensity = angles (pRatio <?> "ratio")+ <|>+ return (1 % 1)+
+ Sound/Tidal/Pattern.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Sound.Tidal.Pattern where++import Control.Applicative+import Data.Monoid+import Data.Fixed+import Data.List+import Data.Maybe+import Data.Ratio+import Debug.Trace+import Data.Typeable+import Data.Function+import System.Random.Mersenne.Pure64++import Sound.Tidal.Time+import Sound.Tidal.Utils++data Pattern a = Pattern {arc :: Arc -> [Event a]}++instance (Show a) => Show (Pattern a) where+ show p@(Pattern _) = show $ arc p (0, 1)+ +instance Functor Pattern where+ fmap f (Pattern a) = Pattern $ fmap (fmap (mapSnd f)) a++instance Applicative Pattern where+ pure = atom+ (Pattern fs) <*> (Pattern xs) = Pattern $ \a -> concatMap applyX (fs a)+ where applyX ((s,e), f) = + map (\(_, x) -> ((s,e), f x)) (filter + (\(a', _) -> isIn a' s)+ (xs (s,e))+ )++instance Monoid (Pattern a) where+ mempty = silence+ mappend x y = Pattern $ \a -> (arc x a) ++ (arc y a)++instance Monad Pattern where+ return = pure+ p >>= f = + Pattern (\a -> concatMap+ (\((s,e), x) -> mapFsts (const (s,e)) $+ filter+ (\(a', _) -> isIn a' s)+ (arc (f x) (s,e))+ )+ (arc p a)+ )++atom :: a -> Pattern a+atom x = Pattern f+ where f (s, e) = map + (\t -> ((t%1, (t+1)%1), x))+ [floor s .. ((ceiling e) - 1)]++silence :: Pattern a+silence = Pattern $ const []++mapQueryArc :: (Arc -> Arc) -> Pattern a -> Pattern a+mapQueryArc f p = Pattern $ \a -> arc p (f a)++mapQueryTime :: (Time -> Time) -> Pattern a -> Pattern a+mapQueryTime = mapQueryArc . mapArc++mapResultArc :: (Arc -> Arc) -> Pattern a -> Pattern a+mapResultArc f p = Pattern $ \a -> mapFsts f $ arc p a++mapResultTime :: (Time -> Time) -> Pattern a -> Pattern a+mapResultTime = mapResultArc . mapArc++overlay :: Pattern a -> Pattern a -> Pattern a+overlay p p' = Pattern $ \a -> (arc p a) ++ (arc p' a)++(>+<) = overlay++stack :: [Pattern a] -> Pattern a+stack ps = foldr overlay silence ps++cat :: [Pattern a] -> Pattern a+cat ps = density (fromIntegral $ length ps) $ slowcat ps++append :: Pattern a -> Pattern a -> Pattern a+append a b = cat [a,b]++append' :: Pattern a -> Pattern a -> Pattern a+append' a b = slow 2 $ cat [a,b]++slowcat' ps = Pattern $ \a -> concatMap f (arcCycles a)+ where l = length ps+ f (s,e) = arc p (s,e)+ where p = ps !! n+ n = (floor s) `mod` l++-- Concatenates so that the first loop of each pattern is played in+-- turn, second loop of each pattern, and so on..++slowcat :: [Pattern a] -> Pattern a+slowcat [] = silence+slowcat ps = Pattern $ \a -> concatMap f (arcCycles a)+ where l = length ps+ f (s,e) = arc (mapResultTime (+offset) p) (s',e')+ where p = ps !! n+ r = (floor s) :: Int+ n = (r `mod` l) :: Int+ offset = (fromIntegral $ r - ((r - n) `div` l)) :: Time+ (s', e') = (s-offset, e-offset)++listToPat :: [a] -> Pattern a+listToPat = cat . map atom++run n = listToPat [0 .. n-1]++maybeListToPat :: [Maybe a] -> Pattern a+maybeListToPat = cat . map f+ where f Nothing = silence+ f (Just x) = atom x++density :: Time -> Pattern a -> Pattern a+density 0 p = p+density 1 p = p+density r p = mapResultTime (/ r) $ mapQueryTime (* r) p++slow :: Time -> Pattern a -> Pattern a+slow 0 = id+slow t = density (1/t) ++(<~) :: Time -> Pattern a -> Pattern a+(<~) t p = filterOffsets $ mapResultTime (+ t) $ mapQueryTime (subtract t) p++(~>) :: Time -> Pattern a -> Pattern a+(~>) = (<~) . (0-)++rev :: Pattern a -> Pattern a+rev p = Pattern $ \a -> concatMap + (\a' -> mapFsts mirrorArc $ + (arc p (mirrorArc a')))+ (arcCycles a)++when :: (Int -> Bool) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a+when test f p = Pattern $ \a -> concatMap apply (arcCycles a)+ where apply a | test (floor $ fst a) = (arc $ f p) a+ | otherwise = (arc p) a++every :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a+every 0 f p = p+every n f p = when ((== 0) . (`mod` n)) f p++palindrome :: Pattern a -> Pattern a+palindrome p = slowcat [p, rev p]++sig :: (Time -> a) -> Pattern a+sig f = Pattern f'+ where f' (s,e) | s > e = []+ | otherwise = [((s,e), f s)]++sinewave :: Pattern Double+sinewave = sig $ \t -> sin $ pi * 2 * (fromRational t)+sine = sinewave+ratsine = fmap toRational sine++sinewave1 :: Pattern Double+sinewave1 = fmap ((/ 2) . (+ 1)) sinewave+sine1 = sinewave1+ratsine1 = fmap toRational sine1++sinePhase1 :: Double -> Pattern Double+sinePhase1 offset = (+ offset) <$> sinewave1++triwave1 :: Pattern Double+triwave1 = sig $ \t -> mod' (fromRational t) 1+tri1 = triwave1+rattri1 = fmap toRational tri1++triwave :: Pattern Double+triwave = ((subtract 1) . (* 2)) <$> triwave1+tri = triwave+rattri = fmap toRational tri++squarewave1 :: Pattern Double+squarewave1 = sig $ + \t -> fromIntegral $ floor $ (mod' (fromRational t) 1) * 2+square1 = squarewave1++squarewave :: Pattern Double+squarewave = ((subtract 1) . (* 2)) <$> squarewave1+square = squarewave++-- Filter out events that start before range+filterOffsets :: Pattern a -> Pattern a+filterOffsets (Pattern f) = + Pattern $ \(s, e) -> filter ((>= s) . eventStart) $ f (s, e)++seqToRelOnsets :: Arc -> Pattern a -> [(Double, a)]+seqToRelOnsets (s, e) p = mapFsts (fromRational . (/ (e-s)) . (subtract s) . fst) $ arc (filterOffsets p) (s, e)++segment :: Pattern a -> Pattern [a]+segment p = Pattern $ \(s,e) -> filter (\((s',e'),_) -> s' < e && e' > s) $ groupByTime (segment' (arc p (s,e)))++segment' :: [Event a] -> [Event a]+segment' es = foldr split es pts+ where pts = nub $ points es++split :: Time -> [Event a] -> [Event a]+split _ [] = []+split t ((ev@((s,e), v)):es) | t > s && t < e = ((s,t),v):((t,e),v):(split t es)+ | otherwise = ev:split t es++points :: [Event a] -> [Time]+points [] = []+points (((s,e), _):es) = s:e:(points es)++groupByTime :: [Event a] -> [Event [a]]+groupByTime es = map mrg $ groupBy ((==) `on` fst) $ sortBy (compare `on` fst) es+ where mrg es@((a, _):_) = (a, map snd es)++ifp :: (Int -> Bool) -> (Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a+ifp test f1 f2 p = Pattern $ \a -> concatMap apply (arcCycles a)+ where apply a | test (floor $ fst a) = (arc $ f1 p) a+ | otherwise = (arc $ f2 p) a++rand :: Pattern Double+rand = Pattern $ \a -> [(a, fst $ randomDouble $ pureMT $ floor $ (*1000000) $ (midPoint a))]
+ Sound/Tidal/Strategies.hs view
@@ -0,0 +1,105 @@+{-# OPTIONS_GHC -XNoMonomorphismRestriction #-}++module Sound.Tidal.Strategies where++import Data.Ratio+import Control.Applicative++import Sound.Tidal.Dirt+import Sound.Tidal.Pattern+import Sound.Tidal.Stream+import Sound.Tidal.Time+import Sound.Tidal.Utils++stutter n t p = stack $ map (\i -> (t * (fromIntegral i)) ~> p) [0 .. (n-1)]++echo = stutter 2+triple = stutter 3+quad = stutter 4+double = echo++jux f p = stack [p |+| pan (pure 0), f $ p |+| pan (pure 1)]+jux4 f p = stack [p |+| pan (pure 0), f $ p |+| pan (pure 2)]++superimpose f p = stack [p, f p]++-- every 4 (smash 4 [1, 2, 3]) $ sound "[odx sn/2 [~ odx] sn/3, [~ hh]*4]"++smash n xs p = slowcat $ map (\n -> slow n p') xs+ where p' = striate n p++brak = every 2 (((1%4) <~) . (\x -> cat [x, silence]))++-- samples "jvbass [~ latibro] [jvbass [latibro jvbass]]" ((1%2) <~ slow 6 "[1 6 8 7 3]")++samples :: Applicative f => f String -> f Int -> f String+samples p p' = pick <$> p <*> p'++spread :: (a -> t -> Pattern b) -> [a] -> t -> Pattern b+spread f xs p = cat $ map (\x -> f x p) xs++slowspread :: (a -> t -> Pattern b) -> [a] -> t -> Pattern b+slowspread f xs p = slow (fromIntegral $ length $ xs) $ spread f xs p++spread' :: (a -> Pattern b -> Pattern c) -> Pattern a -> Pattern b -> Pattern c+spread' f timepat pat =+ Pattern $ \r -> concatMap (\(r', x) -> (arc (f x pat) r')) (rs r)+ where rs r = arc (filterOffsets timepat) r++{-+scrumple :: Time -> Pattern a -> Pattern a -> Pattern a+scrumple o p p' = p'' -- overlay p (o ~> p'')+ where p'' = Pattern $ \a -> concatMap + (\((s,d), vs) -> map (\x -> ((s,d),+ snd x+ )+ )+ (arc p' (s,s))+ ) (arc p a)+-}++whenmod :: Int -> Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a+whenmod a b = Sound.Tidal.Pattern.when ((\t -> (t `mod` a) >= b ))++--rev :: Pattern a -> Pattern a+--rev p = Pattern $ \a -> concatMap +-- (\a' -> mapFsts mirrorArc $ +-- (arc p (mirrorArc a')))+-- (arcCycles a)++trunc :: Time -> Pattern a -> Pattern a+trunc t p = slow t $ Pattern $ \a -> concatMap f $ arcCycles a+ where f a = mapFsts (stretch . trunc') $ arc p (trunc' a)+ trunc' (s,e) = (min s ((sam s) + t), min e ((sam s) + t))+ stretch (s,e) = (sam s + ((s - sam s) / t), sam s + ((e - sam s) / t))++spin :: Int -> OscPattern -> OscPattern+spin steps p = stack $ map (\n -> (((fromIntegral n)%(fromIntegral steps)) <~ p |+| pan (pure $ (fromIntegral n)/(fromIntegral steps)))) [0 .. steps]+++{-stripe :: Arc -> Pattern a -> Pattern a+stripe (stripeS, stripeE) p = slow t $ Pattern $ \a -> concatMap f $ arcCycles a+ where f a = mapFsts (stretch . stripe') $ arc p (stripe' a)+ trunc' (s,e) = (min s ((sam s) + t), min e ((sam s) + t))+ stretch (s,e) = (sam s + ((s - sam s) / t), sam s + ((e - sam s) / t))+-}+++iter n p = slowcat $ map (\i -> ((fromIntegral i)%(fromIntegral n)) <~ p) [0 .. n]++spin16 step p = stack $ map (\n -> ((toRational n)/16) <~ p |+| pan (pure $ n)) [0,step .. 15]++triwave4 = ((*4) <$> triwave1)+sinewave4 = ((*4) <$> sinewave1)+rand4 = ((*4) <$> rand)++stackwith p ps | null ps = silence+ | otherwise = stack $ map (\(i, p') -> p' |+| (((fromIntegral i) % l) <~ p)) (zip [0 ..] ps)+ where l = fromIntegral $ length ps++cross f p p' = Pattern $ \t -> concat [filter flt $ arc p t,+ filter (not . flt) $ arc p' t+ ]+ where flt = f . cyclePos . fst . fst++inside n f p = density n $ f (slow n p)
+ Sound/Tidal/Stream.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE OverloadedStrings, FlexibleInstances, RankNTypes, NoMonomorphismRestriction #-}++module Sound.Tidal.Stream where++import Data.Maybe+import Sound.OSC.FD+import Sound.OSC.Datum+import Control.Applicative+import Control.Concurrent+import Control.Concurrent.MVar+import Control.Exception as E+import Data.Time (getCurrentTime)+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)+import Data.Ratio++import Sound.Tidal.Pattern+import qualified Sound.Tidal.Parse as P+import Sound.Tidal.Tempo (Tempo, logicalTime, clocked,clockedTick)++import qualified Data.Map as Map++data Param = S {name :: String, sDefault :: Maybe String}+ | F {name :: String, fDefault :: Maybe Double}+ | I {name :: String, iDefault :: Maybe Int}++instance Eq Param where+ a == b = name a == name b++instance Ord Param where+ compare a b = compare (name a) (name b)+instance Show Param where+ show p = name p++data OscShape = OscShape {path :: String,+ params :: [Param],+ timestamp :: Bool+ }+type OscMap = Map.Map Param (Maybe Datum)++type OscPattern = Pattern OscMap++defaultDatum :: Param -> Maybe Datum+defaultDatum (S _ (Just x)) = Just $ string x+defaultDatum (I _ (Just x)) = Just $ int32 x+defaultDatum (F _ (Just x)) = Just $ float x+defaultDatum _ = Nothing++hasDefault :: Param -> Bool+hasDefault (S _ Nothing) = False+hasDefault (I _ Nothing) = False+hasDefault (F _ Nothing) = False+hasDefault _ = True++defaulted :: OscShape -> [Param]+defaulted = filter hasDefault . params++defaultMap :: OscShape -> OscMap+defaultMap s+ = Map.fromList $ map (\x -> (x, defaultDatum x)) (defaulted s)++required :: OscShape -> [Param]+required = filter (not . hasDefault) . params++hasRequired :: OscShape -> OscMap -> Bool+hasRequired s m = isSubset (required s) (Map.keys (Map.filter (\x -> x /= Nothing) m))++isSubset :: (Eq a) => [a] -> [a] -> Bool+isSubset xs ys = all (\x -> elem x ys) xs++tpb = 1+bpb = 2++toMessage :: UDP -> OscShape -> Tempo -> Int -> (Double, OscMap) -> Maybe (IO ())+toMessage s shape change ticks (o, m) =+ do m' <- applyShape' shape m+ let beat = fromIntegral ticks / fromIntegral tpb+ latency = 0.5+ logicalNow = (logicalTime change beat)+ beat' = (fromIntegral ticks + 1) / fromIntegral tpb+ logicalPeriod = (logicalTime change (beat + 1)) - logicalNow+ --logicalOnset = ntpr_to_ut $ logicalNow + (logicalPeriod * o) + latency+ logicalOnset = logicalNow + (logicalPeriod * o) + latency+ sec = floor logicalOnset+ usec = floor $ 1000000 * (logicalOnset - (fromIntegral sec))+ oscdata = catMaybes $ mapMaybe (\x -> Map.lookup x m') (params shape)+ oscdata' = ((int32 sec):(int32 usec):oscdata)+ osc | timestamp shape = sendOSC s $ Message (path shape) oscdata'+ | otherwise = doAt logicalOnset $ sendOSC s $ Message (path shape) oscdata+ return osc++doAt t action = do forkIO $ do now <- getCurrentTime+ let nowf = realToFrac $ utcTimeToPOSIXSeconds now+ threadDelay $ floor $ (t - nowf) * 1000000+ action+ return ()+ +applyShape' :: OscShape -> OscMap -> Maybe OscMap+applyShape' s m | hasRequired s m = Just $ Map.union m (defaultMap s)+ | otherwise = Nothing++start :: String -> Int -> OscShape -> IO (MVar (OscPattern))+start address port shape+ = do patternM <- newMVar silence+ --putStrLn $ "connecting " ++ (show address) ++ ":" ++ (show port)+ s <- openUDP address port+ --putStrLn $ "connected "+ let ot = (onTick s shape patternM) :: Tempo -> Int -> IO ()+ forkIO $ clocked $ ot+ return patternM++stream :: String -> Int -> OscShape -> IO (OscPattern -> IO ())+stream address port shape + = do patternM <- start address port shape+ return $ \p -> do swapMVar patternM (slow bpb p)+ return ()++streamcallback :: (OscPattern -> IO ()) -> String -> Int -> OscShape -> IO (OscPattern -> IO ())+streamcallback callback server port shape + = do f <- stream server port shape+ let f' p = do callback p+ f p+ return f'++onTick :: UDP -> OscShape -> MVar (OscPattern) -> Tempo -> Int -> IO ()+onTick s shape patternM change beats+ = do p <- readMVar patternM+ let --tpb' = 2 :: Integer+ tpb' = 1+ beats' = (fromIntegral beats) :: Integer+ a = beats' % tpb'+ b = (beats' + 1) % tpb'+ messages = mapMaybe + (toMessage s shape change beats) + (seqToRelOnsets (a, b) p)+ --putStrLn $ (show a) ++ ", " ++ (show b)+ --putStrLn $ "tick " ++ show ticks ++ " = " ++ show messages+ E.catch (sequence_ messages) (\msg -> putStrLn $ "oops " ++ show (msg :: E.SomeException))+ return ()++{-ticker :: IO (MVar Rational)+ticker = do mv <- newMVar 0+ --forkIO $ clocked "ticker" "127.0.0.1" "127.0.0.1" tpb (f mv)+ forkIO $ clocked (f mv)+ return mv+ where f mv change ticks = do swapMVar mv ((fromIntegral ticks) / (fromIntegral tpb))+ where f mv ticks = do swapMVar mv (fromIntegral ticks)+ return ()+ tpb = 32+-}++make :: (a -> Datum) -> OscShape -> String -> Pattern a -> OscPattern+make toOsc s nm p = fmap (\x -> Map.singleton nParam (defaultV x)) p+ where nParam = param s nm+ defaultV a = Just $ toOsc a+ --defaultV Nothing = defaultDatum nParam++makeS = make string+makeF = make float++makeI = make int32++param :: OscShape -> String -> Param+param shape n = head $ filter (\x -> name x == n) (params shape)+ +merge :: OscPattern -> OscPattern -> OscPattern+merge x y = Map.union <$> x <*> y++infixl 1 |+|+(|+|) :: OscPattern -> OscPattern -> OscPattern+(|+|) = merge++++weave :: Rational -> OscPattern -> [OscPattern] -> OscPattern+weave t p ps | l == 0 = silence+ | otherwise = slow t $ stack $ map (\(i, p') -> ((density t p') |+| (((fromIntegral i) % l) <~ p))) (zip [0 ..] ps)+ where l = fromIntegral $ length ps++
+ Sound/Tidal/Tempo.hs view
@@ -0,0 +1,193 @@+module Sound.Tidal.Tempo where++import Data.Time (getCurrentTime, UTCTime, diffUTCTime)+import Data.Time.Clock.POSIX+import Control.Monad (forM_, forever)+import Control.Monad.IO.Class (liftIO)+import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.MVar+import Control.Monad.Trans (liftIO)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Network.WebSockets as WS+import qualified Control.Exception as E+import qualified System.IO.Error as Error+import GHC.Conc.Sync (ThreadId)+import System.Environment (getEnv)++import Sound.Tidal.Utils++data Tempo = Tempo {at :: UTCTime, beat :: Double, bps :: Double}++type ClientState = [WS.Connection]++instance Eq WS.Connection++instance Show Tempo where+ show x = show (at x) ++ "," ++ show (beat x) ++ "," ++ show (bps x)++getClockIp :: IO (String)+getClockIp = do addr <- E.try (getEnv "TEMPO_ADDR")+ return $ either (const "127.0.0.1") (id) (addr :: Either E.IOException String)++readTempo :: String -> Tempo+readTempo x = Tempo (read a) (read b) (read c)+ where (a:b:c:_) = wordsBy (== ',') x++logicalTime :: Tempo -> Double -> Double+logicalTime t b = changeT + timeDelta+ where beatDelta = b - (beat t)+ timeDelta = beatDelta / (bps t)+ changeT = realToFrac $ utcTimeToPOSIXSeconds $ at t++tempoMVar :: IO (MVar (Tempo))+tempoMVar = do now <- getCurrentTime+ mv <- newMVar (Tempo now 0 (126/60))+ forkIO $ clocked $ f mv+ return mv+ where f mv change _ = do swapMVar mv change+ return ()++beatNow :: Tempo -> IO (Double)+beatNow t = do now <- getCurrentTime+ let delta = realToFrac $ diffUTCTime now (at t)+ let beatDelta = bps t * delta + return $ beat t + beatDelta++clientApp :: MVar Tempo -> MVar Double -> WS.ClientApp ()+clientApp mTempo mBps conn = do+ --sink <- WS.getSink+ liftIO $ forkIO $ sendBps conn mBps+ forever loop+ where+ loop = do+ msg <- WS.receiveData conn+ let tempo = readTempo $ T.unpack msg+ liftIO $ tryTakeMVar mTempo+ liftIO $ putMVar mTempo tempo++sendBps :: WS.Connection -> MVar Double -> IO ()+sendBps conn mBps = forever $ do+ bps <- takeMVar mBps + WS.sendTextData conn (T.pack $ show bps)++connectClient clockip mTempo mBps = do + E.handle+ ((\err -> + do putStrLn "Couldn't connect to tempo clock, starting local clock.."+ startServer+ threadDelay 500000+ cx "127.0.0.1"+ ) :: E.SomeException -> IO ())+ (cx clockip)+ where cx ip = WS.runClient ip 9160 "/tempo" (clientApp mTempo mBps)+ --where cx ip = WS.connect ip 9160 "/tempo" (clientApp mTempo mBps)++runClient :: IO ((MVar Tempo, MVar Double))+runClient = + do clockip <- getClockIp+ mTempo <- newEmptyMVar + mBps <- newEmptyMVar + forkIO $ connectClient clockip mTempo mBps+ return (mTempo, mBps)++bpsSetter :: IO (Double -> IO ())+bpsSetter = do (_, mBps) <- runClient + return $ (\b -> putMVar mBps b)++clocked :: (Tempo -> Int -> IO ()) -> IO ()+clocked callback = + do (mTempo, mBps) <- runClient+ t <- readMVar mTempo+ now <- getCurrentTime+ let delta = realToFrac $ diffUTCTime now (at t)+ beatDelta = bps t * delta+ nowBeat = beat t + beatDelta+ nextBeat = ceiling nowBeat+ -- next4 = nextBeat + (4 - (nextBeat `mod` 4))+ loop mTempo nextBeat+ where loop mTempo b = + do t <- readMVar mTempo+ now <- getCurrentTime+ let delta = realToFrac $ diffUTCTime now (at t)+ actualBeat = (beat t) + ((bps t) * delta)+ beatDelta = (fromIntegral b) - actualBeat+ delay = beatDelta / (bps t)+ threadDelay $ floor (delay * 1000000)+ callback t b+ loop mTempo $ b + 1++clockedTick :: Int -> (Tempo -> Int -> IO ()) -> IO ()+clockedTick tpb callback = + do (mTempo, mBps) <- runClient+ t <- readMVar mTempo+ now <- getCurrentTime+ let delta = realToFrac $ diffUTCTime now (at t)+ beatDelta = bps t * delta+ nowBeat = beat t + beatDelta+ nextTick = ceiling (nowBeat * (fromIntegral tpb))+ -- next4 = nextBeat + (4 - (nextBeat `mod` 4))+ loop mTempo nextTick+ where loop mTempo tick = + do t <- readMVar mTempo+ now <- getCurrentTime+ let tps = (fromIntegral tpb) * bps t+ delta = realToFrac $ diffUTCTime now (at t)+ actualTick = ((fromIntegral tpb) * beat t) + (tps * delta)+ tickDelta = (fromIntegral tick) - actualTick+ delay = tickDelta / tps+ --putStrLn $ "tick: " ++ (show tick) ++ " actualTick " ++ (show actualTick)+ threadDelay $ floor (delay * 1000000)+ callback t tick+ loop mTempo $ tick + 1++updateTempo :: MVar Tempo -> Maybe Double -> IO ()+updateTempo mt Nothing = return ()+updateTempo mt (Just bps') = do t <- takeMVar mt+ now <- getCurrentTime+ let delta = realToFrac $ diffUTCTime now (at t)+ beat' = (beat t) + ((bps t) * delta)+ putMVar mt $ Tempo now beat' bps'++addClient :: WS.Connection -> ClientState -> ClientState+addClient client clients = client : clients++removeClient :: WS.Connection -> ClientState -> ClientState+removeClient client = filter (/= client)++broadcast :: Text -> ClientState -> IO ()+broadcast message clients = do+ T.putStrLn message+ forM_ clients $ \conn -> WS.sendTextData conn $ message++startServer :: IO (ThreadId)+startServer = do+ start <- getCurrentTime+ tempoState <- newMVar (Tempo start 0 1)+ clientState <- newMVar []+ forkIO $ WS.runServer "0.0.0.0" 9160 $ serverApp tempoState clientState++serverApp :: MVar Tempo -> MVar ClientState -> WS.ServerApp+serverApp tempoState clientState pending = do+ conn <- WS.acceptRequest pending+ tempo <- liftIO $ readMVar tempoState+ liftIO $ WS.sendTextData conn $ T.pack $ show tempo+ clients <- liftIO $ readMVar clientState+ liftIO $ modifyMVar_ clientState $ \s -> return $ addClient conn s+ serverLoop conn tempoState clientState++serverLoop :: WS.Connection -> MVar Tempo -> MVar ClientState -> IO ()+serverLoop conn tempoState clientState = E.handle catchDisconnect $ + forever $ do+ msg <- WS.receiveData conn+ liftIO $ updateTempo tempoState $ maybeRead $ T.unpack msg+ tempo <- liftIO $ readMVar tempoState+ liftIO $ readMVar clientState >>= broadcast (T.pack $ show tempo) + where+ catchDisconnect e = case E.fromException e of+ Just WS.ConnectionClosed -> liftIO $ modifyMVar_ clientState $ \s -> do+ let s' = removeClient conn s+ return s'+ _ -> return ()+
+ Sound/Tidal/Time.hs view
@@ -0,0 +1,41 @@+module Sound.Tidal.Time where++type Time = Rational+type Arc = (Time, Time)+type Event a = (Arc, a)++sam :: Time -> Time+sam = fromIntegral . floor++nextSam :: Time -> Time+nextSam = (1+) . sam++cyclePos :: Time -> Time+cyclePos t = t - sam t++isIn :: Arc -> Time -> Bool+isIn (s,e) t = t >= s && t < e++-- chop arc into arcs within unit cycles+arcCycles :: Arc -> [Arc]+arcCycles (s,e) | s >= e = []+ | sam s == sam e = [(s,e)]+ | otherwise = (s, nextSam s) : (arcCycles (nextSam s, e))++subArc :: Arc -> Arc -> Maybe Arc+subArc (s, e) (s',e') | s'' < e'' = Just (s'', e'')+ | otherwise = Nothing+ where s'' = max s s'+ e'' = min e e'++mapArc :: (Time -> Time) -> Arc -> Arc+mapArc f (s,e) = (f s, f e)++mirrorArc :: Arc -> Arc+mirrorArc (s, e) = (sam s + (nextSam s - e), nextSam s - (s - sam s))++eventStart :: Event a -> Time+eventStart = fst . fst++midPoint :: Arc -> Time+midPoint (s,e) = s + ((e - s) / 2)
+ Sound/Tidal/Utils.hs view
@@ -0,0 +1,27 @@+module Sound.Tidal.Utils where++import Data.Maybe (listToMaybe)++enumerate :: [a] -> [(Int, a)]+enumerate = zip [0..]++mapFst :: (a -> b) -> (a, c) -> (b, c)+mapFst f (x,y) = (f x,y)++mapFsts :: (a -> b) -> [(a, c)] -> [(b, c)]+mapFsts = map . mapFst++mapSnd :: (a -> b) -> (c, a) -> (c, b)+mapSnd f (x,y) = (x,f y)++mapSnds :: (a -> b) -> [(c, a)] -> [(c, b)]+mapSnds = fmap . mapSnd++wordsBy :: (a -> Bool) -> [a] -> [[a]]+wordsBy p s = case dropWhile p s of+ [] -> []+ s':rest -> (s':w) : wordsBy p (drop 1 s'')+ where (w, s'') = break p rest++maybeRead :: String -> Maybe Double+maybeRead = fmap fst . listToMaybe . reads
− Strategies.hs
@@ -1,98 +0,0 @@-{-# OPTIONS_GHC -XNoMonomorphismRestriction #-}--module Strategies where--import Pattern-import Time-import Dirt-import Data.Ratio-import Control.Applicative-import Stream--import Utils--stutter n t p = stack $ map (\i -> (t * (fromIntegral i)) ~> p) [0 .. (n-1)]--echo = stutter 2-triple = stutter 3-quad = stutter 4-double = echo--jux f p = stack [p |+| pan (pure 0), f $ p |+| pan (pure 1)]-jux16 f p = stack [p |+| pan (pure 0), f $ p |+| pan (pure 8)]--superimpose f p = stack [p, f p]---- every 4 (smash 4 [1, 2, 3]) $ sound "[odx sn/2 [~ odx] sn/3, [~ hh]*4]"--smash n xs p = slowcat $ map (\n -> slow n p') xs- where p' = striate n p--brak = every 2 (((1%4) <~) . (\x -> cat [x, silence]))---- samples "jvbass [~ latibro] [jvbass [latibro jvbass]]" ((1%2) <~ slow 6 "[1 6 8 7 3]")--samples :: Applicative f => f String -> f Int -> f String-samples p p' = pick <$> p <*> p'--spread :: (a -> t -> Pattern b) -> [a] -> t -> Pattern b-spread f xs p = cat $ map (\x -> f x p) xs--slowspread :: (a -> t -> Pattern b) -> [a] -> t -> Pattern b-slowspread f xs p = slow (fromIntegral $ length $ xs) $ spread f xs p--spread' :: (a -> Pattern b -> Pattern c) -> Pattern a -> Pattern b -> Pattern c-spread' f timepat pat =- Pattern $ \r -> concatMap (\(r', x) -> (arc (f x pat) r')) (rs r)- where rs r = arc (filterOffsets timepat) r--{--scrumple :: Time -> Pattern a -> Pattern a -> Pattern a-scrumple o p p' = p'' -- overlay p (o ~> p'')- where p'' = Pattern $ \a -> concatMap - (\((s,d), vs) -> map (\x -> ((s,d),- snd x- )- )- (arc p' (s,s))- ) (arc p a)--}--whenmod :: Int -> Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a-whenmod a b = Pattern.when ((\t -> (t `mod` a) >= b ))----rev :: Pattern a -> Pattern a---rev p = Pattern $ \a -> concatMap --- (\a' -> mapFsts mirrorArc $ --- (arc p (mirrorArc a')))--- (arcCycles a)--trunc :: Time -> Pattern a -> Pattern a-trunc t p = slow t $ Pattern $ \a -> concatMap f $ arcCycles a- where f a = mapFsts (stretch . trunc') $ arc p (trunc' a)- trunc' (s,e) = (min s ((sam s) + t), min e ((sam s) + t))- stretch (s,e) = (sam s + ((s - sam s) / t), sam s + ((e - sam s) / t))--spin :: Int -> OscPattern -> OscPattern-spin steps p = stack $ map (\n -> (((fromIntegral n)%(fromIntegral steps)) <~ p |+| pan (pure $ (fromIntegral n)/(fromIntegral steps)))) [0 .. steps]---{-stripe :: Arc -> Pattern a -> Pattern a-stripe (stripeS, stripeE) p = slow t $ Pattern $ \a -> concatMap f $ arcCycles a- where f a = mapFsts (stretch . stripe') $ arc p (stripe' a)- trunc' (s,e) = (min s ((sam s) + t), min e ((sam s) + t))- stretch (s,e) = (sam s + ((s - sam s) / t), sam s + ((e - sam s) / t))--}---iter n p = slowcat $ map (\i -> ((fromIntegral i)%(fromIntegral n)) <~ p) [0 .. n]--spin16 step p = stack $ map (\n -> ((toRational n)/16) <~ p |+| pan (pure $ n)) [0,step .. 15]--triwave16 = ((*16) <$> triwave1)-sinewave16 = ((*16) <$> sinewave1)-rand16 = ((*16) <$> rand)--stackwith p ps | null ps = silence- | otherwise = stack $ map (\(i, p') -> p' |+| (((fromIntegral i) % l) <~ p)) (zip [0 ..] ps)- where l = fromIntegral $ length ps
− Stream.hs
@@ -1,171 +0,0 @@-{-# LANGUAGE OverloadedStrings, FlexibleInstances, RankNTypes, NoMonomorphismRestriction #-}--module Stream where--import Data.Maybe-import Sound.OSC.FD-import Sound.OSC.Datum-import Control.Applicative-import Tempo (Tempo, logicalTime, clocked,clockedTick)-import Control.Concurrent-import Control.Concurrent.MVar-import Pattern-import Data.Ratio-import Control.Exception as E-import qualified Parse as P--import qualified Data.Map as Map--data Param = S {name :: String, sDefault :: Maybe String}- | F {name :: String, fDefault :: Maybe Double}- | I {name :: String, iDefault :: Maybe Int}--instance Eq Param where- a == b = name a == name b--instance Ord Param where- compare a b = compare (name a) (name b)-instance Show Param where- show p = name p--data OscShape = OscShape {path :: String,- params :: [Param],- timestamp :: Bool- }-type OscMap = Map.Map Param (Maybe Datum)--type OscPattern = Pattern OscMap--defaultDatum :: Param -> Maybe Datum-defaultDatum (S _ (Just x)) = Just $ string x-defaultDatum (I _ (Just x)) = Just $ int32 x-defaultDatum (F _ (Just x)) = Just $ float x-defaultDatum _ = Nothing--hasDefault :: Param -> Bool-hasDefault (S _ Nothing) = False-hasDefault (I _ Nothing) = False-hasDefault (F _ Nothing) = False-hasDefault _ = True--defaulted :: OscShape -> [Param]-defaulted = filter hasDefault . params--defaultMap :: OscShape -> OscMap-defaultMap s- = Map.fromList $ map (\x -> (x, defaultDatum x)) (defaulted s)--required :: OscShape -> [Param]-required = filter (not . hasDefault) . params--hasRequired :: OscShape -> OscMap -> Bool-hasRequired s m = isSubset (required s) (Map.keys (Map.filter (\x -> x /= Nothing) m))--isSubset :: (Eq a) => [a] -> [a] -> Bool-isSubset xs ys = all (\x -> elem x ys) xs--tpb = 1-bpb = 2--toMessage :: OscShape -> Tempo -> Int -> (Double, OscMap) -> Maybe Message-toMessage s change ticks (o, m) =- do m' <- applyShape' s m- let beat = fromIntegral ticks / fromIntegral tpb- latency = 0.04- logicalNow = (logicalTime change beat)- beat' = (fromIntegral ticks + 1) / fromIntegral tpb- logicalPeriod = (logicalTime change (beat + 1)) - logicalNow- --logicalOnset = ntpr_to_ut $ logicalNow + (logicalPeriod * o) + latency- logicalOnset = logicalNow + (logicalPeriod * o) + latency- sec = floor logicalOnset- usec = floor $ 1000000 * (logicalOnset - (fromIntegral sec))- oscdata = catMaybes $ mapMaybe (\x -> Map.lookup x m') (params s)- oscdata' = ((int32 sec):(int32 usec):oscdata)- osc | timestamp s = Message (path s) oscdata'- | otherwise = Message (path s) oscdata- return osc---applyShape' :: OscShape -> OscMap -> Maybe OscMap-applyShape' s m | hasRequired s m = Just $ Map.union m (defaultMap s)- | otherwise = Nothing--start :: String -> Int -> OscShape -> IO (MVar (OscPattern))-start address port shape- = do patternM <- newMVar silence- putStrLn $ "connecting " ++ (show address) ++ ":" ++ (show port)- s <- openUDP address port- putStrLn $ "connected "- let ot = (onTick s shape patternM) :: Tempo -> Int -> IO ()- forkIO $ clocked $ ot- return patternM--stream :: String -> Int -> OscShape -> IO (OscPattern -> IO ())-stream address port shape - = do patternM <- start address port shape- return $ \p -> do swapMVar patternM (slow bpb p)- return ()--streamcallback :: (OscPattern -> IO ()) -> String -> Int -> OscShape -> IO (OscPattern -> IO ())-streamcallback callback server port shape - = do f <- stream server port shape- let f' p = do callback p- f p- return f'--onTick :: UDP -> OscShape -> MVar (OscPattern) -> Tempo -> Int -> IO ()-onTick s shape patternM change beats- = do p <- readMVar patternM- let --tpb' = 2 :: Integer- tpb' = 1- beats' = (fromIntegral beats) :: Integer- a = beats' % tpb'- b = (beats' + 1) % tpb'- messages = mapMaybe - (toMessage shape change beats) - (seqToRelOnsets (a, b) p)- --putStrLn $ (show a) ++ ", " ++ (show b)- --putStrLn $ "tick " ++ show ticks ++ " = " ++ show messages- E.catch (mapM_ (sendOSC s) messages) (\msg -> putStrLn $ "oops " ++ show (msg :: E.SomeException))- return ()--{-ticker :: IO (MVar Rational)-ticker = do mv <- newMVar 0- --forkIO $ clocked "ticker" "127.0.0.1" "127.0.0.1" tpb (f mv)- forkIO $ clocked (f mv)- return mv- where f mv change ticks = do swapMVar mv ((fromIntegral ticks) / (fromIntegral tpb))- where f mv ticks = do swapMVar mv (fromIntegral ticks)- return ()- tpb = 32--}--make :: (a -> Datum) -> OscShape -> String -> Pattern a -> OscPattern-make toOsc s nm p = fmap (\x -> Map.singleton nParam (defaultV x)) p- where nParam = param s nm- defaultV a = Just $ toOsc a- --defaultV Nothing = defaultDatum nParam--makeS = make string-makeF = make float--makeI = make int32--param :: OscShape -> String -> Param-param shape n = head $ filter (\x -> name x == n) (params shape)- -merge :: OscPattern -> OscPattern -> OscPattern-merge x y = Map.union <$> x <*> y--infixl 1 |+|-(|+|) :: OscPattern -> OscPattern -> OscPattern-(|+|) = merge----weave :: Rational -> OscPattern -> [OscPattern] -> OscPattern-weave t p ps | l == 0 = silence- | otherwise = slow t $ stack $ map (\(i, p') -> ((density t p') |+| (((fromIntegral i) % l) <~ p))) (zip [0 ..] ps)- where l = fromIntegral $ length ps--
− Tempo.hs
@@ -1,193 +0,0 @@-module Tempo where--import Data.Time (getCurrentTime, UTCTime, diffUTCTime)-import Data.Time.Clock.POSIX-import Control.Monad (forM_, forever)-import Control.Monad.IO.Class (liftIO)-import Control.Concurrent (forkIO, threadDelay)-import Control.Concurrent.MVar-import Control.Monad.Trans (liftIO)-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.IO as T-import qualified Network.WebSockets as WS-import qualified Control.Exception as E-import qualified System.IO.Error as Error-import GHC.Conc.Sync (ThreadId)-import System.Environment (getEnv)--import Utils--data Tempo = Tempo {at :: UTCTime, beat :: Double, bps :: Double}--type Client = WS.Sink WS.Hybi00-type ClientState = [Client]--instance Show Tempo where- show x = show (at x) ++ "," ++ show (beat x) ++ "," ++ show (bps x)--getClockIp :: IO (String)-getClockIp = do addr <- E.try (getEnv "TEMPO_ADDR")- return $ either (const "127.0.0.1") (id) (addr :: Either E.IOException String)--readTempo :: String -> Tempo-readTempo x = Tempo (read a) (read b) (read c)- where (a:b:c:_) = wordsBy (== ',') x--logicalTime :: Tempo -> Double -> Double-logicalTime t b = changeT + timeDelta- where beatDelta = b - (beat t)- timeDelta = beatDelta / (bps t)- changeT = realToFrac $ utcTimeToPOSIXSeconds $ at t--tempoMVar :: IO (MVar (Tempo))-tempoMVar = do now <- getCurrentTime- mv <- newMVar (Tempo now 0 (126/60))- forkIO $ clocked $ f mv- return mv- where f mv change _ = do swapMVar mv change- return ()--beatNow :: Tempo -> IO (Double)-beatNow t = do now <- getCurrentTime- let delta = realToFrac $ diffUTCTime now (at t)- let beatDelta = bps t * delta - return $ beat t + beatDelta--clientApp :: MVar Tempo -> MVar Double -> WS.WebSockets WS.Hybi10 ()-clientApp mTempo mBps = do- sink <- WS.getSink- liftIO $ forkIO $ sendBps sink mBps- forever loop- where- loop = do- msg <- WS.receiveData- let tempo = readTempo $ T.unpack msg- liftIO $ tryTakeMVar mTempo- liftIO $ putMVar mTempo tempo--sendBps :: (WS.TextProtocol p) => WS.Sink p -> MVar Double -> IO ()-sendBps sink mBps = forever $ do- bps <- takeMVar mBps - WS.sendSink sink $ WS.textData $ T.pack $ show bps--connectClient clockip mTempo mBps = do - E.handle- ((\err -> - do putStrLn "Couldn't connect to tempo clock, starting local clock.."- startServer- threadDelay 500000- cx "127.0.0.1"- ) :: E.SomeException -> IO ())- (cx clockip)- where cx ip = WS.connect ip 9160 "/tempo" (clientApp mTempo mBps)--runClient :: IO ((MVar Tempo, MVar Double))-runClient = - do clockip <- getClockIp- mTempo <- newEmptyMVar - mBps <- newEmptyMVar - forkIO $ connectClient clockip mTempo mBps- return (mTempo, mBps)--bpsSetter :: IO (Double -> IO ())-bpsSetter = do (_, mBps) <- runClient - return $ (\b -> putMVar mBps b)--clocked :: (Tempo -> Int -> IO ()) -> IO ()-clocked callback = - do (mTempo, mBps) <- runClient- t <- readMVar mTempo- now <- getCurrentTime- let delta = realToFrac $ diffUTCTime now (at t)- beatDelta = bps t * delta- nowBeat = beat t + beatDelta- nextBeat = ceiling nowBeat- -- next4 = nextBeat + (4 - (nextBeat `mod` 4))- loop mTempo nextBeat- where loop mTempo b = - do t <- readMVar mTempo- now <- getCurrentTime- let delta = realToFrac $ diffUTCTime now (at t)- actualBeat = (beat t) + ((bps t) * delta)- beatDelta = (fromIntegral b) - actualBeat- delay = beatDelta / (bps t)- threadDelay $ floor (delay * 1000000)- callback t b- loop mTempo $ b + 1--clockedTick :: Int -> (Tempo -> Int -> IO ()) -> IO ()-clockedTick tpb callback = - do (mTempo, mBps) <- runClient- t <- readMVar mTempo- now <- getCurrentTime- let delta = realToFrac $ diffUTCTime now (at t)- beatDelta = bps t * delta- nowBeat = beat t + beatDelta- nextTick = ceiling (nowBeat * (fromIntegral tpb))- -- next4 = nextBeat + (4 - (nextBeat `mod` 4))- loop mTempo nextTick- where loop mTempo tick = - do t <- readMVar mTempo- now <- getCurrentTime- let tps = (fromIntegral tpb) * bps t- delta = realToFrac $ diffUTCTime now (at t)- actualTick = ((fromIntegral tpb) * beat t) + (tps * delta)- tickDelta = (fromIntegral tick) - actualTick- delay = tickDelta / tps- --putStrLn $ "tick: " ++ (show tick) ++ " actualTick " ++ (show actualTick)- threadDelay $ floor (delay * 1000000)- callback t tick- loop mTempo $ tick + 1--updateTempo :: MVar Tempo -> Maybe Double -> IO ()-updateTempo mt Nothing = return ()-updateTempo mt (Just bps') = do t <- takeMVar mt- now <- getCurrentTime- let delta = realToFrac $ diffUTCTime now (at t)- beat' = (beat t) + ((bps t) * delta)- putMVar mt $ Tempo now beat' bps'--addClient :: Client -> ClientState -> ClientState-addClient client clients = client : clients--removeClient :: Client -> ClientState -> ClientState-removeClient client = filter (/= client)--broadcast :: Text -> ClientState -> IO ()-broadcast message clients = do- T.putStrLn message- forM_ clients $ \sink -> WS.sendSink sink $ WS.textData message--startServer :: IO (ThreadId)-startServer = do- start <- getCurrentTime- tempoState <- newMVar (Tempo start 0 1)- clientState <- newMVar []- forkIO $ WS.runServer "0.0.0.0" 9160 $ serverApp tempoState clientState--serverApp :: MVar Tempo -> MVar ClientState -> WS.Request -> WS.WebSockets WS.Hybi00 ()-serverApp tempoState clientState rq = do- WS.acceptRequest rq- -- WS.getVersion >>= liftIO . putStrLn . ("Client version: " ++)- sink <- WS.getSink- tempo <- liftIO $ readMVar tempoState- liftIO $ WS.sendSink sink $ WS.textData $ T.pack $ show tempo- clients <- liftIO $ readMVar clientState- liftIO $ modifyMVar_ clientState $ \s -> return $ addClient sink s- serverLoop tempoState clientState sink--serverLoop :: WS.Protocol p => MVar Tempo -> MVar ClientState -> Client -> WS.WebSockets p ()-serverLoop tempoState clientState client = flip WS.catchWsError catchDisconnect $ - forever $ do- msg <- WS.receiveData- liftIO $ updateTempo tempoState $ maybeRead $ T.unpack msg- tempo <- liftIO $ readMVar tempoState- liftIO $ readMVar clientState >>= broadcast (T.pack $ show tempo)- where- catchDisconnect e = case E.fromException e of- Just WS.ConnectionClosed -> liftIO $ modifyMVar_ clientState $ \s -> do- let s' = removeClient client s- return s'- _ -> return ()-
− Time.hs
@@ -1,41 +0,0 @@-module Time where--type Time = Rational-type Arc = (Time, Time)-type Event a = (Arc, a)--sam :: Time -> Time-sam = fromIntegral . floor--nextSam :: Time -> Time-nextSam = (1+) . sam--cyclePos :: Time -> Time-cyclePos t = t - sam t--isIn :: Arc -> Time -> Bool-isIn (s,e) t = t >= s && t < e---- chop arc into arcs within unit cycles-arcCycles :: Arc -> [Arc]-arcCycles (s,e) | s >= e = []- | sam s == sam e = [(s,e)]- | otherwise = (s, nextSam s) : (arcCycles (nextSam s, e))--subArc :: Arc -> Arc -> Maybe Arc-subArc (s, e) (s',e') | s'' < e'' = Just (s'', e'')- | otherwise = Nothing- where s'' = max s s'- e'' = min e e'--mapArc :: (Time -> Time) -> Arc -> Arc-mapArc f (s,e) = (f s, f e)--mirrorArc :: Arc -> Arc-mirrorArc (s, e) = (sam s + (nextSam s - e), nextSam s - (s - sam s))--eventStart :: Event a -> Time-eventStart = fst . fst--midPoint :: Arc -> Time-midPoint (s,e) = s + ((e - s) / 2)
− Utils.hs
@@ -1,27 +0,0 @@-module Utils where--import Data.Maybe (listToMaybe)--enumerate :: [a] -> [(Int, a)]-enumerate = zip [0..]--mapFst :: (a -> b) -> (a, c) -> (b, c)-mapFst f (x,y) = (f x,y)--mapFsts :: (a -> b) -> [(a, c)] -> [(b, c)]-mapFsts = map . mapFst--mapSnd :: (a -> b) -> (c, a) -> (c, b)-mapSnd f (x,y) = (x,f y)--mapSnds :: (a -> b) -> [(c, a)] -> [(c, b)]-mapSnds = fmap . mapSnd--wordsBy :: (a -> Bool) -> [a] -> [[a]]-wordsBy p s = case dropWhile p s of- [] -> []- s':rest -> (s':w) : wordsBy p (drop 1 s'')- where (w, s'') = break p rest--maybeRead :: String -> Maybe Double-maybeRead = fmap fst . listToMaybe . reads
doc/tidal.pandoc view
@@ -1,4 +1,4 @@-# Tidal -- Domain specific language for live coding of pattern +% Tidal -- Domain specific language for live coding of pattern Homepage and mailing list: <http://yaxu.org/tidal/> @@ -9,31 +9,35 @@ Great Good" (which has a free online version). Or, you could just try learning enough by playing around with Tidal. -## Installation+# Installation -Tidal is developed under Linux, and although it should be possible to-run it under a different operating system, this has not yet been-tried.+Tidal is developed under Linux, and although some have got it to work+under Macs, the process hasn't been fully documented, and Dirt+synthesiser has not yet been ported to Windows. Feel free to ask+questions and share problems and success stories on the mailing list. -### Installing Dirt+## Installing Dirt Tidal does not include a synthesiser, but instead communicates with an external synthesiser using the Open Sound Control protocol. It has been developed for use with a particular software sampler called "dirt". You'll need to run it with "jack audio". Here's an example of the commands needed to compile it under a debian-derived linux-distribution (including ubuntu and mint).+distribution (including ubuntu and mint): sudo apt-get install build-essential libsndfile1-dev libsamplerate0-dev \- liblo-dev libjack-jackd2-dev jackd git+ liblo-dev libjack-jackd2-dev qjackctl jackd git git clone https://github.com/yaxu/Dirt.git cd Dirt make clean; make -Then you'll have to start jack:+Then you'll have to start jack, using the 'qjackctl' app under Linux,+or otherwise from the commandline: jackd -d alsa & +(On MacOS X, you would do this instead: jackd -d coreaudio & )+ If that doesn't work, you might well have something called "pulseaudio" in control of your sound. In that case, this should work: @@ -48,8 +52,7 @@ software. Some more info is here: <https://help.ubuntu.com/community/HowToJACKConfiguration> -### Tidal-+## Tidal Tidal is embedded in the Haskell language, so you'll have to install the haskell interpreter and some libraries, including tidal@@ -63,7 +66,7 @@ cabal update cabal install tidal -### Emacs+## Emacs Currently about the only interface to Tidal is the emacs editor. Debian users can install emacs, along with its haskell@@ -76,12 +79,14 @@ exist, create it. Then, add the following, replacing `~/projects/tidal` with the location of the `tidal.el` file. - (add-to-list 'load-path "~/projects/tidal")- (require 'tidal)+~~~~+ (add-to-list 'load-path "~/projects/tidal")+ (require 'tidal)+~~~~ If tidal.el did not come with this document, you can grab it here: <https://raw.github.com/yaxu/Tidal/master/tidal.el> -### Testing, testing...+## Testing, testing... Now start emacs, and open a new file called something like "helloworld.tidal". Once the file is opened, you still have to start@@ -90,7 +95,7 @@ All being well you should now be able to start making some sounds, lets start with some simple sequences. -## Sequences+# Sequences Tidal starts with nine connections to the dirt synthesiser, named from `d1` to `d9`. Here's a minimal example, that plays a bass drum every loop:@@ -184,7 +189,7 @@ d1 $ sound "[bd sn sn*3]/2 [bd sn*3 bd*4]/3" ~~~~ -## Samples+# Samples All the samples can be found in the `samples` subfolder of the Dirt distribution. Here's some you could try:@@ -203,7 +208,7 @@ If you want to add your own samples, just create a new folder in the samples director, and put `wav` files in it. -## Continuous patterns+# Continuous patterns As well as making patterns as sequences, we can also use continuous patterns. This makes particular sense for parameters such as `pan`@@ -222,7 +227,7 @@ also exist, but they go between `-1` and `1`, which is often not what you want. -## Transforming patterns+# Transforming patterns Tidal comes into its own when you start building things up with functions which transform the patterns in various ways.@@ -292,7 +297,7 @@ In the above, the sinewave pan has been slowed down, so that the transition between speakers happens over 16 loops. -## Mapping over patterns+# Mapping over patterns Sometimes you want to transform all the events inside a pattern, and not the time structure of the pattern itself. For example, if you@@ -307,9 +312,9 @@ The above applies the function `(/ 2)` (which simply means divide by two), to all the values inside the `sinewave1` pattern. -## Parameters+# Parameters -These are all the synthesis parameters you can use+These are the synthesis parameters you can use * `sound` - a pattern of strings representing sound sample names (required) * `pan` - a pattern of numbers between 0 and 1, from left to right (assuming stereo)@@ -319,10 +324,12 @@ * `resonance` - a pattern of numbers from 0 to 1 * `speed` - a pattern of numbers from 0 to 1, which changes the speed of sample playback, i.e. a cheap way of changing pitch -## Pattern transformers+# Pattern transformers -### `brak <pattern>`+## brak +`brak <pattern>`+ Make a pattern sound a bit like a breakbeat Example:@@ -331,8 +338,14 @@ d1 $ sound (brak "bd sn kurt") ~~~~ -### `<number> <~ <pattern>` and `<number> ~> <pattern>`+## Beat rotation +`<number> <~ <pattern>`++or++`<number> ~> <pattern>`+ Rotate a loop either to the left or the right. Example:@@ -341,8 +354,10 @@ d1 $ every 4 (0.25 <~) $ sound (density 2 "bd sn kurt") ~~~~ -### `rev <pattern>`+## Reversal +`rev <pattern>`+ Reverse a pattern Examples:@@ -351,8 +366,14 @@ d1 $ every 3 (rev) $ sound (density 2 "bd sn kurt") ~~~~ -### `density <number> <pattern>` and `slow <number> <pattern>`+## Increase/decrease density +`density <number> <pattern>`++or++`slow <number> <pattern>`+ Speed up or slow down a pattern. Example:@@ -362,8 +383,10 @@ |+| slow 3 (vowel "a e o") ~~~~ -### `every <number> <function> <pattern>`+## Every nth repetition, do this +`every <number> <function> <pattern>`+ Applies <function> to <pattern>, but only every <number> repetitions. Example:@@ -372,8 +395,10 @@ d1 $ sound (every 3 (density 2) "bd sn kurt") ~~~~ -### `interlace <pattern> <pattern>`+# Interlace +`interlace <pattern> <pattern>`+ Shifts between two patterns, using distortion. Example:@@ -386,7 +411,7 @@ You can find a stream of minimal cycles written in Tidal in the following twitter feed:- http://twitter.com/tidalcycles/+ <http://twitter.com/tidalcycles/> # Acknowledgments
doc/tidal.pdf view
binary file changed (158788 → 59112 bytes)
tidal.cabal view
@@ -1,5 +1,5 @@ name: tidal-version: 0.2.4+version: 0.2.6 synopsis: Pattern language for improvised music -- description: homepage: http://yaxu.org/tidal/@@ -7,7 +7,8 @@ license-file: LICENSE author: Alex McLean maintainer: alex@slab.org--- copyright: +Stability: Experimental+Copyright: (c) Alex McLean and others, 2013 category: Sound build-type: Simple cabal-version: >=1.4@@ -17,7 +18,14 @@ Description: Tidal is a domain specific language for live coding pattern. library- Exposed-modules: Strategies, Dirt, Pattern, Stream, Parse, Tempo, Time- Other-modules: Utils+ Exposed-modules: Sound.Tidal.Strategies+ Sound.Tidal.Dirt+ Sound.Tidal.Pattern+ Sound.Tidal.Stream+ Sound.Tidal.Parse+ Sound.Tidal.Tempo+ Sound.Tidal.Time - Build-depends: base < 5, process, parsec, hosc > 0.13, hashable, colour, containers, time, websockets, text, mtl, transformers, mersenne-random-pure64,binary + Other-modules: Sound.Tidal.Utils++ Build-depends: base < 5, process, parsec, hosc > 0.13, hashable, colour, containers, time, websockets > 0.8, text, mtl, transformers, mersenne-random-pure64,binary
tidal.el view
@@ -27,25 +27,6 @@ ) "*Arguments to the haskell interpreter (default=none).") -(defvar tidal-run-control- "~/.tidal.hs"- "*Run control file (default=~/.tidal.hs)")--(defvar tidal-modules- (list "import Control.Concurrent"- "import Control.Monad"- "import Data.List"- "import Control.Applicative"- "import Parse"- "import Pattern"- "import Stream"- "import Dirt"- "import Strategies"- "import Data.Ratio"- "import Tempo"- )- "*List of modules (possibly qualified) to bring into interpreter context.")- (defvar tidal-literate-p t "*Flag to indicate if we are in literate mode (default=t).")@@ -61,16 +42,6 @@ '() (cons e (cons (car l) (tidal-intersperse e (cdr l)))))) -(defun tidal-write-default-run-control ()- "Write default run control file if no file exists."- (if (not (file-exists-p tidal-run-control))- (with-temp-file- tidal-run-control- (mapc- (lambda (s)- (insert (concat s "\n")))- tidal-modules))))- (defun tidal-start-haskell () "Start haskell." (interactive)@@ -83,9 +54,8 @@ nil tidal-interpreter-arguments) (tidal-see-output))- (tidal-write-default-run-control)- (tidal-send-string (concat ":l " tidal-run-control))- (tidal-send-string ":set prompt \"tidal> \"")+ (tidal-send-string ":set prompt \"\"")+ (tidal-send-string ":module Control.Concurrent Control.Monad Data.List Control.Applicative Data.Ratio Sound.Tidal.Parse Sound.Tidal.Pattern Sound.Tidal.Stream Sound.Tidal.Dirt Sound.Tidal.Strategies Sound.Tidal.Tempo") (tidal-send-string "d1 <- dirtstream \"d1\"") (tidal-send-string "d2 <- dirtstream \"d2\"") (tidal-send-string "d3 <- dirtstream \"d3\"")@@ -97,6 +67,7 @@ (tidal-send-string "d9 <- dirtstream \"d9\"") (tidal-send-string "bps <- bpsSetter") (tidal-send-string "let hush = mapM_ ($ silence) [d1,d2,d3,d4,d5,d6,d7,d8,d9]")+ (tidal-send-string ":set prompt \"tidal> \"") ) (defun tidal-see-output ()@@ -279,6 +250,8 @@ tidal-mode "Literate Haskell Tidal" "Major mode for interacting with an inferior haskell process."+ (set (make-local-variable 'paragraph-start) "\f\\|[ \t]*$")+ (set (make-local-variable 'paragraph-separate) "[ \t\f]*$") (setq tidal-literate-p t) (setq haskell-literate 'bird) (turn-on-font-lock))@@ -290,6 +263,8 @@ haskell-mode "Haskell Tidal" "Major mode for interacting with an inferior haskell process."+ (set (make-local-variable 'paragraph-start) "\f\\|[ \t]*$")+ (set (make-local-variable 'paragraph-separate) "[ \t\f]*$") (setq tidal-literate-p nil) (turn-on-font-lock))