packages feed

tidal 0.2.1 → 0.2.2

raw patch · 7 files changed

+398/−10 lines, 7 filesdep ~basedep ~websockets

Dependency ranges changed: base, websockets

Files

+ Parse.hs view
@@ -0,0 +1,168 @@+{-# OPTIONS_GHC -XTypeSynonymInstances -XOverlappingInstances -XIncoherentInstances -XOverloadedStrings -XFlexibleInstances #-}++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++pPart :: Parser (Pattern a) -> Parser (Pattern a)+pPart f = do part <- parens (pSequence f) <|> f <|> pPoly f+             spaces+             return part++pPoly :: Parser (Pattern a) -> Parser (Pattern a)+pPoly f = do ps <- brackets (pRhythm f `sepBy` symbol ",")+             spaces+             m <- pMult+             return $ density m $ 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 :: Parser (Rational)+pMult = do char '*'+           spaces+           r <- pRatio+           return r+        <|>+        do char '/'+           spaces+           r <- pRatio+           return $ 1 / r+        <|>+        return 1+           ++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)+
+ Tempo.hs view
@@ -0,0 +1,153 @@+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+++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)++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+++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 view
@@ -0,0 +1,39 @@+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+
+ Utils.hs view
@@ -0,0 +1,24 @@+module Utils where++import Data.Maybe (listToMaybe)++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,5 +1,7 @@ # Tidal -- Domain specific language for live coding of pattern  +Homepage and mailing list: <http://yaxu.org/tidal/>+ Tidal is a language for live coding pattern, embedded in the Haskell language. You don't really have to learn Haskell to use Tidal, but it might help to pick up an introduction. You could try Graham Hutton's@@ -22,7 +24,8 @@ the commands needed to compile it under a debian-derived linux distribution (including ubuntu and mint). -    apt-get install build-essential libsndfile1-dev libsamplerate0-dev liblo-dev libjack-dev jackd git+    sudo apt-get install build-essential libsndfile1-dev libsamplerate0-dev \+                         liblo-dev libjack-jackd2-dev jackd git     git clone https://github.com/yaxu/Dirt.git     cd Dirt     make clean; make@@ -49,9 +52,10 @@     sudo apt-get install ghc6 cabal-install -Or otherwise you could grab it from http://www.haskell.org/platform/+Or otherwise you could grab it from <http://www.haskell.org/platform/>  Once Haskell is installed, you can install tidal like this:+   cabal update    cabal install tidal  ### Emacs@@ -71,12 +75,13 @@   (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+    <https://raw.github.com/yaxu/Tidal/master/tidal.el>  ### Testing, testing...  Now start emacs, and open a new file called something like-"helloworld.tidal". To start tidal, you type `Ctrl-C` then `Ctrl-S`.+"helloworld.tidal". Once the file is opened, you still have to start+tidal, you do that by typing `Ctrl-C` then `Ctrl-S`.  All being well you should now be able to start making some sounds, lets start with some simple sequences.@@ -356,11 +361,10 @@ d1 $ interlace (sound  "bd sn kurt") (every 3 rev $ sound  "bd sn/2") ~~~~ - Plus more to be discovered!  # Acknowledgments -Special thanks to l'ull cec (http://lullcec.org) and hangar-(http://hangar.org) for supporting the documentation and release of+Special thanks to l'ull cec (<http://lullcec.org>) and hangar+(<http://hangar.org>) for supporting the documentation and release of tidal as part of the ADDICTED2RANDOM project.
doc/tidal.pdf view

binary file changed (156148 → 43958 bytes)

tidal.cabal view
@@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version:             0.2.1+Version:             0.2.2  -- A short (one-line) description of the package. Synopsis:            Pattern language for improvised music@@ -48,13 +48,13 @@  Library   -- Modules exported by the library.-  Exposed-modules:     Strategies, Dirt, Pattern, Stream +  Exposed-modules:     Strategies, Dirt, Pattern, Stream, Parse, Tempo, Time      -- Packages needed in order to build this package.   Build-depends: base < 5, process, parsec, hosc == 0.13, hashable, colour, containers, time, websockets, text, mtl, transformers      -- Modules not exported by this package.-  -- Other-modules:       +  Other-modules: Utils      -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.   -- Build-tools: