diff --git a/Dirt.hs b/Dirt.hs deleted file mode 100644 --- a/Dirt.hs +++ /dev/null @@ -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] diff --git a/Parse.hs b/Parse.hs deleted file mode 100644 --- a/Parse.hs +++ /dev/null @@ -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) - diff --git a/Pattern.hs b/Pattern.hs deleted file mode 100644 --- a/Pattern.hs +++ /dev/null @@ -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))] diff --git a/Sound/Tidal/Dirt.hs b/Sound/Tidal/Dirt.hs new file mode 100644 --- /dev/null +++ b/Sound/Tidal/Dirt.hs @@ -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] diff --git a/Sound/Tidal/Parse.hs b/Sound/Tidal/Parse.hs new file mode 100644 --- /dev/null +++ b/Sound/Tidal/Parse.hs @@ -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) + diff --git a/Sound/Tidal/Pattern.hs b/Sound/Tidal/Pattern.hs new file mode 100644 --- /dev/null +++ b/Sound/Tidal/Pattern.hs @@ -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))] diff --git a/Sound/Tidal/Strategies.hs b/Sound/Tidal/Strategies.hs new file mode 100644 --- /dev/null +++ b/Sound/Tidal/Strategies.hs @@ -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) diff --git a/Sound/Tidal/Stream.hs b/Sound/Tidal/Stream.hs new file mode 100644 --- /dev/null +++ b/Sound/Tidal/Stream.hs @@ -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 + + diff --git a/Sound/Tidal/Tempo.hs b/Sound/Tidal/Tempo.hs new file mode 100644 --- /dev/null +++ b/Sound/Tidal/Tempo.hs @@ -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 () + diff --git a/Sound/Tidal/Time.hs b/Sound/Tidal/Time.hs new file mode 100644 --- /dev/null +++ b/Sound/Tidal/Time.hs @@ -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) diff --git a/Sound/Tidal/Utils.hs b/Sound/Tidal/Utils.hs new file mode 100644 --- /dev/null +++ b/Sound/Tidal/Utils.hs @@ -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 diff --git a/Strategies.hs b/Strategies.hs deleted file mode 100644 --- a/Strategies.hs +++ /dev/null @@ -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 diff --git a/Stream.hs b/Stream.hs deleted file mode 100644 --- a/Stream.hs +++ /dev/null @@ -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 - - diff --git a/Tempo.hs b/Tempo.hs deleted file mode 100644 --- a/Tempo.hs +++ /dev/null @@ -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 () - diff --git a/Time.hs b/Time.hs deleted file mode 100644 --- a/Time.hs +++ /dev/null @@ -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) diff --git a/Utils.hs b/Utils.hs deleted file mode 100644 --- a/Utils.hs +++ /dev/null @@ -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 diff --git a/doc/tidal.pandoc b/doc/tidal.pandoc --- a/doc/tidal.pandoc +++ b/doc/tidal.pandoc @@ -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: @@ -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: -### 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: -### 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 ` +## brak +`brak ` + Make a pattern sound a bit like a breakbeat Example: @@ -331,8 +338,14 @@ d1 $ sound (brak "bd sn kurt") ~~~~ -### ` <~ ` and ` ~> ` +## Beat rotation +` <~ ` + +or + +` ~> ` + 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 ` +## Reversal +`rev ` + Reverse a pattern Examples: @@ -351,8 +366,14 @@ d1 $ every 3 (rev) $ sound (density 2 "bd sn kurt") ~~~~ -### `density ` and `slow ` +## Increase/decrease density +`density ` + +or + +`slow ` + Speed up or slow down a pattern. Example: @@ -362,8 +383,10 @@ |+| slow 3 (vowel "a e o") ~~~~ -### `every ` +## Every nth repetition, do this +`every ` + Applies to , but only every repetitions. Example: @@ -372,8 +395,10 @@ d1 $ sound (every 3 (density 2) "bd sn kurt") ~~~~ -### `interlace ` +# Interlace +`interlace ` + 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/ + # Acknowledgments diff --git a/doc/tidal.pdf b/doc/tidal.pdf Binary files a/doc/tidal.pdf and b/doc/tidal.pdf differ diff --git a/tidal.cabal b/tidal.cabal --- a/tidal.cabal +++ b/tidal.cabal @@ -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 diff --git a/tidal.el b/tidal.el --- a/tidal.el +++ b/tidal.el @@ -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))