tidal 1.8.1 → 1.9.0
raw patch · 25 files changed
+1034/−885 lines, 25 filesdep +tidal-linkdep −bifunctorsdep ~transformers
Dependencies added: tidal-link
Dependencies removed: bifunctors
Dependency ranges changed: transformers
Files
- BootTidal.hs +1/−2
- CHANGELOG.md +58/−0
- src/Sound/Tidal/Carabiner.hs +0/−83
- src/Sound/Tidal/Chords.hs +41/−0
- src/Sound/Tidal/Config.hs +14/−3
- src/Sound/Tidal/Context.hs +0/−2
- src/Sound/Tidal/Control.hs +3/−3
- src/Sound/Tidal/Core.hs +19/−0
- src/Sound/Tidal/EspGrid.hs +0/−72
- src/Sound/Tidal/ParseBP.hs +129/−38
- src/Sound/Tidal/Pattern.hs +60/−9
- src/Sound/Tidal/Safe/Context.hs +3/−6
- src/Sound/Tidal/Stream.hs +224/−193
- src/Sound/Tidal/StreamTypes.hs +21/−0
- src/Sound/Tidal/Tempo.hs +252/−195
- src/Sound/Tidal/Transition.hs +3/−21
- src/Sound/Tidal/UI.hs +26/−24
- src/Sound/Tidal/Version.hs +1/−1
- test/Sound/Tidal/ControlTest.hs +14/−6
- test/Sound/Tidal/ParseTest.hs +36/−0
- test/Sound/Tidal/PatternTest.hs +0/−11
- test/Sound/Tidal/UITest.hs +13/−0
- test/TestUtils.hs +9/−5
- tidal.cabal +5/−6
- tidal.el +102/−205
BootTidal.hs view
@@ -6,8 +6,7 @@ import System.IO (hSetEncoding, stdout, utf8) hSetEncoding stdout utf8 --- total latency = oLatency + cFrameTimespan-tidal <- startTidal (superdirtTarget {oLatency = 0.1, oAddress = "127.0.0.1", oPort = 57120}) (defaultConfig {cVerbose = True, cFrameTimespan = 1/20})+tidal <- startTidal (superdirtTarget {oLatency = 0.05, oAddress = "127.0.0.1", oPort = 57120}) (defaultConfig {cVerbose = True, cFrameTimespan = 1/20}) :{ let only = (hush >>)
CHANGELOG.md view
@@ -1,5 +1,63 @@ # TidalCycles log of changes +## 1.9.0++## What's Changed++### General enhancements+* Rename linux binary name by @ndr-brt in https://github.com/tidalcycles/Tidal/pull/911+* Fix echo by @ndr-brt in https://github.com/tidalcycles/Tidal/pull/910+* If first argument of euclid is negative, apply euclidInv by @polymorphicengine in https://github.com/tidalcycles/Tidal/pull/916+* Add squeeze operators (`||+`, `*||`, etc) by @yaxu in https://github.com/tidalcycles/Tidal/pull/919+* Make chunk reverse direction with negative number by @ndr-brt in https://github.com/tidalcycles/Tidal/pull/918+* overhaul of the chord parser by @polymorphicengine in https://github.com/tidalcycles/Tidal/pull/931++### New ableton link support+* Use ableton link for scheduling by @Zalastax in https://github.com/tidalcycles/Tidal/pull/898+* tidal-link: add link source files to extra-source-files, fixes #924 by @yaxu in https://github.com/tidalcycles/Tidal/pull/925+* Use target latency in all send modes by @Zalastax in https://github.com/tidalcycles/Tidal/pull/927+* Rename cCyclesPerBeat -> cBeatsPerCycle by @Zalastax in https://github.com/tidalcycles/Tidal/pull/939++### Emacs plugin updates+* formatting fixes in tidal.el by @zzkt in https://github.com/tidalcycles/Tidal/pull/932+* a window-excursion for tidal.el by @zzkt in https://github.com/tidalcycles/Tidal/pull/933+* autoloads for tidal.el by @zzkt in https://github.com/tidalcycles/Tidal/pull/934+* avoid race in loading bootscript during restart by @zzkt in https://github.com/tidalcycles/Tidal/pull/937++### Tidal-parse (estuary) updates+* Various updates to tidal-parse by @dktr0 in https://github.com/tidalcycles/Tidal/pull/913 and https://github.com/tidalcycles/Tidal/pull/941++### Maintenance+* Increase upper bounds of text dependency by @yaxu in https://github.com/tidalcycles/Tidal/pull/948+* Use system-cxx-std-lib by @Zalastax in https://github.com/tidalcycles/Tidal/pull/944+* Use c++ extra library for MacOS by @giuseppelillo in https://github.com/tidalcycles/Tidal/pull/946++## New Contributors+* @Zalastax made their first contribution in https://github.com/tidalcycles/Tidal/pull/898+* @zzkt made their first contribution in https://github.com/tidalcycles/Tidal/pull/932+* @giuseppelillo made their first contribution in https://github.com/tidalcycles/Tidal/pull/946++**Full Changelog**: https://github.com/tidalcycles/Tidal/compare/v1.8.0...v1.9.0++## 1.8.1++* Removed executable from tidal.cabal file (while latest ghc on windows fails to build it)++## 1.8.0 - Sanquhar++* move tidal-listener code by @polymorphicengine in #885+* Fix a typo incurred (I assume) by a filename change. by @JeffreyBenjaminBrown in #886+* Hide contexts from Events per default by @polymorphicengine in #887+* Allow sending/receiving of broadcasted OSC control messages by @yaxu in #894+* tidal-listener: Add minimal install notes by @gamar3is in #895+* Add rolled function with variants by @thgrund in #820+* Valuable instance for Note by @yaxu in #899+* Add parsers for ints and floats that don't consume trailing whitespace by @polymorphicengine in #900+* Introduce echo and echoWith, deprecate stut and stutWith by @ndr-brt in #904+* tidal-listener: Optional WITH_GHC environment variable by @mindofmatthew in #903++Commit list: https://github.com/tidalcycles/Tidal/compare/1.7.10...v1.8.0+ ## 1.7.10 - Tama b * Derive RealFrac for Note by @ndr-brt in https://github.com/tidalcycles/Tidal/pull/876
− src/Sound/Tidal/Carabiner.hs
@@ -1,83 +0,0 @@-{-# OPTIONS_GHC -fno-warn-dodgy-imports -fno-warn-name-shadowing #-}-module Sound.Tidal.Carabiner where--{-- Carabiner.hs - For syncing with the Link protocol over Carabiner.- Copyright (C) 2020, Alex McLean and contributors-- This library is free software: you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation, either version 3 of the License, or- (at your option) any later version.-- This library is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this library. If not, see <http://www.gnu.org/licenses/>.--}--import Network.Socket hiding (send, sendTo, recv, recvFrom)-import Network.Socket.ByteString (send, recv)-import qualified Data.ByteString.Char8 as B8-import Control.Concurrent (forkIO, takeMVar, putMVar)-import qualified Sound.Tidal.Stream as S-import Sound.Tidal.Tempo-import System.Clock-import Text.Read (readMaybe)-import Control.Monad (when, forever)-import Data.Maybe (isJust, fromJust)-import qualified Sound.OSC.FD as O--carabiner :: S.Stream -> Int -> Double -> IO Socket-carabiner tidal bpc latency = do sock <- client tidal bpc latency "127.0.0.1" 17000- sendMsg sock "status\n"- return sock--client :: S.Stream -> Int -> Double -> String -> Int -> IO Socket-client tidal bpc latency host port = withSocketsDo $- do addrInfo <- getAddrInfo Nothing (Just host) (Just $ show port)- let serverAddr = head addrInfo- sock <- socket (addrFamily serverAddr) Stream defaultProtocol- connect sock (addrAddress serverAddr)- _ <- forkIO $ listener tidal bpc latency sock- -- sendMsg sock "status\n"- -- threadDelay 10000000- return sock--listener :: S.Stream -> Int -> Double -> Socket -> IO ()-listener tidal bpc latency sock =- forever $ do rMsg <- recv sock 1024- let msg = B8.unpack rMsg- (name:_:ws) = words msg- pairs = pairs' ws- pairs' (a:b:xs) = (a,b):pairs' xs- pairs' _ = []- act tidal bpc latency name pairs--act :: S.Stream -> Int -> Double -> String -> [(String, String)] -> IO ()-act tidal bpc latency "status" pairs- = do let start = (lookup ":start" pairs >>= readMaybe) :: Maybe Integer- bpm = (lookup ":bpm" pairs >>= readMaybe) :: Maybe Double- beat = (lookup ":beat" pairs >>= readMaybe) :: Maybe Double- when (and [isJust start, isJust bpm, isJust beat]) $ do- nowM <- getTime Monotonic- nowO <- O.time- let m = fromIntegral (sec nowM) + (fromIntegral (nsec nowM)/1000000000)- d = nowO - m- start' = fromIntegral (fromJust start) / 1000000- startO = start' + d- -- cyc = toRational $ (fromJust beat) / (fromIntegral bpc)- tempo <- takeMVar (S.sTempoMV tidal)- let tempo' = tempo {atTime = startO + latency,- atCycle = 0,- cps = (fromJust bpm / 60) / fromIntegral bpc- }- putMVar (S.sTempoMV tidal) tempo'-act _ _ _ name _ = putStr $ "Unhandled thingie " ++ name--sendMsg :: Socket -> String -> IO ()-sendMsg sock msg = do _ <- send sock $ B8.pack msg- return ()
src/Sound/Tidal/Chords.hs view
@@ -274,3 +274,44 @@ chordList :: String chordList = unwords $ map fst (chordTable :: [(String, [Int])]) +data Modifier = Range Int | Drop Int | Invert | Open deriving Eq++instance Show Modifier where+ show (Range i) = "Range " ++ show i+ show (Drop i) = "Drop " ++ show i+ show Invert = "Invert"+ show Open = "Open"++applyModifier :: (Enum a, Num a) => Modifier -> [a] -> [a]+applyModifier (Range i) ds = take i $ concatMap (\x -> map (+ x) ds) [0,12..]+applyModifier Invert [] = []+applyModifier Invert (d:ds) = ds ++ [d+12]+applyModifier Open ds = case length ds > 2 of+ True -> [ (ds !! 0 - 12), (ds !! 2 - 12), (ds !! 1) ] ++ reverse (take (length ds - 3) (reverse ds))+ False -> ds+applyModifier (Drop i) ds = case length ds < i of+ True -> ds+ False -> (ds!!s - 12):(xs ++ drop 1 ys)+ where (xs,ys) = splitAt s ds+ s = length ds - i++applyModifierPat :: (Num a, Enum a) => Pattern [a] -> Pattern [Modifier] -> Pattern [a]+applyModifierPat pat modsP = do+ ch <- pat+ ms <- modsP+ return $ foldl (flip applyModifier) ch ms++applyModifierPatSeq :: (Num a, Enum a) => (a -> b) -> Pattern [a] -> [Pattern [Modifier]] -> Pattern [b]+applyModifierPatSeq f pat [] = fmap (map f) pat+applyModifierPatSeq f pat (mP:msP) = applyModifierPatSeq f (applyModifierPat pat mP) msP++chordToPatSeq :: (Num a, Enum a) => (a -> b) -> Pattern a -> Pattern String -> [Pattern [Modifier]] -> Pattern b+chordToPatSeq f noteP nameP modsP = uncollect $ do+ n <- noteP+ name <- nameP+ let ch = map (+ n) (fromMaybe [0] $ lookup name chordTable)+ applyModifierPatSeq f (return ch) modsP++-- | turns a given pattern of some Num type, a pattern of chord names and a list of patterns of modifiers into a chord pattern+chord :: (Num a, Enum a) => Pattern a -> Pattern String -> [Pattern [Modifier]] -> Pattern a+chord = chordToPatSeq id
src/Sound/Tidal/Config.hs view
@@ -1,5 +1,8 @@ module Sound.Tidal.Config where +import Data.Int(Int64)+import Foreign.C.Types (CDouble)+ {- Config.hs - For default Tidal configuration values. Copyright (C) 2020, Alex McLean and contributors@@ -23,11 +26,15 @@ cCtrlPort :: Int, cCtrlBroadcast :: Bool, cFrameTimespan :: Double,+ cEnableLink :: Bool,+ cProcessAhead :: Double, cTempoAddr :: String, cTempoPort :: Int, cTempoClientPort :: Int,- cSkipTicks :: Int,- cVerbose :: Bool+ cSkipTicks :: Int64,+ cVerbose :: Bool,+ cQuantum :: CDouble,+ cBeatsPerCycle :: CDouble } defaultConfig :: Config@@ -36,9 +43,13 @@ cCtrlPort = 6010, cCtrlBroadcast = False, cFrameTimespan = 1/20,+ cEnableLink = True,+ cProcessAhead = 3/10, cTempoAddr = "127.0.0.1", cTempoPort = 9160, cTempoClientPort = 0, -- choose at random cSkipTicks = 10,- cVerbose = True+ cVerbose = True,+ cQuantum = 4,+ cBeatsPerCycle = 4 }
src/Sound/Tidal/Context.hs view
@@ -22,7 +22,6 @@ import Data.Ratio as C -import Sound.Tidal.Carabiner as C import Sound.Tidal.Config as C import Sound.Tidal.Control as C import Sound.Tidal.Core as C@@ -36,4 +35,3 @@ import Sound.Tidal.Transition as C import Sound.Tidal.UI as C import Sound.Tidal.Version as C-import Sound.Tidal.EspGrid as C
src/Sound/Tidal/Control.hs view
@@ -350,21 +350,21 @@ This adds a bit of echo: @- d1 $ echo 4 0.5 0.2 $ sound "bd sn"+ d1 $ echo 4 0.2 0.5 $ sound "bd sn" @ The above results in 4 echos, each one 50% quieter than the last, with 1/5th of a cycle between them. It is possible to reverse the echo: @- d1 $ echo 4 0.5 (-0.2) $ sound "bd sn"+ d1 $ echo 4 (-0.2) 0.5 $ sound "bd sn" @ -} echo :: Pattern Integer -> Pattern Rational -> Pattern Double -> ControlPattern -> ControlPattern echo = tParam3 _echo _echo :: Integer -> Rational -> Double -> ControlPattern -> ControlPattern-_echo count time feedback p = stack (p:map (\x -> ((x%1)*time) `rotR` (p |* P.gain (pure $ (* feedback) (fromIntegral x)))) [1..(count-1)])+_echo count time feedback p = _echoWith count time (|* P.gain (pure $ feedback)) p {- | Allows to apply a function for each step and overlays the result delayed by the given time.
src/Sound/Tidal/Core.hs view
@@ -150,13 +150,18 @@ a |+ b = (+) <$> a <* b ( +|) :: Num a => Pattern a -> Pattern a -> Pattern a a +| b = (+) <$> a *> b+(||+) :: Num a => Pattern a -> Pattern a -> Pattern a+a ||+ b = (+) <$> a <<* b + (|++|) :: Applicative a => a String -> a String -> a String a |++| b = (++) <$> a <*> b (|++ ) :: Pattern String -> Pattern String -> Pattern String a |++ b = (++) <$> a <* b ( ++|) :: Pattern String -> Pattern String -> Pattern String a ++| b = (++) <$> a *> b+(||++) :: Pattern String -> Pattern String -> Pattern String+a ||++ b = (++) <$> a <<* b (|/|) :: (Applicative a, Fractional b) => a b -> a b -> a b a |/| b = (/) <$> a <*> b@@ -164,6 +169,8 @@ a |/ b = (/) <$> a <* b ( /|) :: Fractional a => Pattern a -> Pattern a -> Pattern a a /| b = (/) <$> a *> b+(||/) :: Fractional a => Pattern a -> Pattern a -> Pattern a+a ||/ b = (/) <$> a <<* b (|*|) :: (Applicative a, Num b) => a b -> a b -> a b a |*| b = (*) <$> a <*> b@@ -171,6 +178,8 @@ a |* b = (*) <$> a <* b ( *|) :: Num a => Pattern a -> Pattern a -> Pattern a a *| b = (*) <$> a *> b+(||*) :: Num a => Pattern a -> Pattern a -> Pattern a+a ||* b = (*) <$> a <<* b (|-|) :: (Applicative a, Num b) => a b -> a b -> a b a |-| b = (-) <$> a <*> b@@ -178,6 +187,8 @@ a |- b = (-) <$> a <* b ( -|) :: Num a => Pattern a -> Pattern a -> Pattern a a -| b = (-) <$> a *> b+(||-) :: Num a => Pattern a -> Pattern a -> Pattern a+a ||- b = (-) <$> a <<* b (|%|) :: (Applicative a, Moddable b) => a b -> a b -> a b a |%| b = gmod <$> a <*> b@@ -185,6 +196,8 @@ a |% b = gmod <$> a <* b ( %|) :: Moddable a => Pattern a -> Pattern a -> Pattern a a %| b = gmod <$> a *> b+(||%) :: Moddable a => Pattern a -> Pattern a -> Pattern a+a ||% b = gmod <$> a <<* b (|**|) :: (Applicative a, Floating b) => a b -> a b -> a b a |**| b = (**) <$> a <*> b@@ -192,6 +205,8 @@ a |** b = (**) <$> a <* b ( **|) :: Floating a => Pattern a -> Pattern a -> Pattern a a **| b = (**) <$> a *> b+(||**) :: Floating a => Pattern a -> Pattern a -> Pattern a+a ||** b = (**) <$> a <<* b (|>|) :: (Applicative a, Unionable b) => a b -> a b -> a b a |>| b = flip union <$> a <*> b@@ -199,6 +214,8 @@ a |> b = flip union <$> a <* b ( >|) :: Unionable a => Pattern a -> Pattern a -> Pattern a a >| b = flip union <$> a *> b+(||>) :: Unionable a => Pattern a -> Pattern a -> Pattern a+a ||> b = flip union <$> a <<* b (|<|) :: (Applicative a, Unionable b) => a b -> a b -> a b a |<| b = union <$> a <*> b@@ -206,6 +223,8 @@ a |< b = union <$> a <* b ( <|) :: Unionable a => Pattern a -> Pattern a -> Pattern a a <| b = union <$> a *> b+(||<) :: Unionable a => Pattern a -> Pattern a -> Pattern a+a ||< b = union <$> a <<* b -- Backward compatibility - structure from left, values from right. (#) :: Unionable b => Pattern b -> Pattern b -> Pattern b
− src/Sound/Tidal/EspGrid.hs
@@ -1,72 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-} - -module Sound.Tidal.EspGrid (tidalEspGridLink,cpsEsp,espgrid) where - -{- - EspGrid.hs - Provides ability to sync via the ESP Grid - Copyright (C) 2020, David Ogborn and contributors - - This library is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this library. If not, see <http://www.gnu.org/licenses/>. --} - -import Control.Concurrent.MVar -import Control.Concurrent (forkIO,threadDelay) -import Control.Monad (forever) -import Control.Exception -import Sound.OSC.FD -import Sound.Tidal.Tempo -import Sound.Tidal.Stream (Stream, sTempoMV) - -parseEspTempo :: [Datum] -> Maybe (Tempo -> Tempo) -parseEspTempo d = do - on :: Integer <- datum_integral (d!!0) - bpm <- datum_floating (d!!1) - t1 :: Integer <- datum_integral (d!!2) - t2 <- datum_integral (d!!3) - n :: Integer <- datum_integral (d!!4) - let nanos = (t1*1000000000) + t2 - return $ \t -> t { - atTime = ut_to_ntpr $ realToFrac nanos / 1000000000, - atCycle = fromIntegral n, - cps = bpm/60, - paused = on == 0 - } - -changeTempo :: MVar Tempo -> Packet -> IO () -changeTempo t (Packet_Message msg) = - case parseEspTempo (messageDatum msg) of - Just f -> modifyMVarMasked_ t $ \t0 -> return (f t0) - Nothing -> putStrLn "Warning: Unable to parse message from EspGrid as Tempo" -changeTempo _ _ = putStrLn "Serious error: Can only process Packet_Message" - -tidalEspGridLink :: MVar Tempo -> IO () -tidalEspGridLink _ = putStrLn "Function no longer supported, please use 'espgrid tidal' to connect to ESPgrid instead." - -espgrid :: Stream -> IO () -espgrid st = do - let t = sTempoMV st - socket <- openUDP "127.0.0.1" 5510 - _ <- forkIO $ forever $ do - (do - sendMessage socket $ Message "/esp/tempo/q" [] - response <- waitAddress socket "/esp/tempo/r" - Sound.Tidal.EspGrid.changeTempo t response - threadDelay 200000) - `catch` (\e -> putStrLn $ "exception caught in tidalEspGridLink: " ++ show (e :: SomeException)) - return () - -cpsEsp :: Real t => t -> IO () -cpsEsp t = do - socket <- openUDP "127.0.0.1" 5510 - sendMessage socket $ Message "/esp/beat/tempo" [float (t*60)]
src/Sound/Tidal/ParseBP.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, FlexibleInstances, CPP, DeriveFunctor #-}+{-# LANGUAGE OverloadedStrings, FlexibleInstances, CPP, DeriveFunctor, GADTs, StandaloneDeriving #-} {-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans -fno-warn-unused-do-bind #-} @@ -42,7 +42,7 @@ import Sound.Tidal.Pattern import Sound.Tidal.UI import Sound.Tidal.Core-import Sound.Tidal.Chords (chordTable)+import Sound.Tidal.Chords import Sound.Tidal.Utils (fromRight) data TidalParseError = TidalParseError {parsecError :: ParseError,@@ -62,23 +62,60 @@ -- | AST representation of patterns -data TPat a = TPat_Atom (Maybe ((Int, Int), (Int, Int))) a- | TPat_Fast (TPat Time) (TPat a)- | TPat_Slow (TPat Time) (TPat a)- | TPat_DegradeBy Int Double (TPat a)- | TPat_CycleChoose Int [TPat a]- | TPat_Euclid (TPat Int) (TPat Int) (TPat Int) (TPat a)- | TPat_Stack [TPat a]- | TPat_Polyrhythm (Maybe (TPat Rational)) [TPat a]- | TPat_Seq [TPat a]- | TPat_Silence- | TPat_Foot- | TPat_Elongate Rational (TPat a)- | TPat_Repeat Int (TPat a)- | TPat_EnumFromTo (TPat a) (TPat a)- | TPat_Var String- deriving (Show, Functor)+data TPat a where+ TPat_Atom :: (Maybe ((Int, Int), (Int, Int))) -> a -> (TPat a)+ TPat_Fast :: (TPat Time) -> (TPat a) -> (TPat a)+ TPat_Slow :: (TPat Time) -> (TPat a) -> (TPat a)+ TPat_DegradeBy :: Int -> Double -> (TPat a) -> (TPat a)+ TPat_CycleChoose :: Int -> [TPat a] -> (TPat a)+ TPat_Euclid :: (TPat Int) -> (TPat Int) -> (TPat Int) -> (TPat a) -> (TPat a)+ TPat_Stack :: [TPat a] -> (TPat a)+ TPat_Polyrhythm :: (Maybe (TPat Rational)) -> [TPat a] -> (TPat a)+ TPat_Seq :: [TPat a] -> (TPat a)+ TPat_Silence :: (TPat a)+ TPat_Foot :: (TPat a)+ TPat_Elongate :: Rational -> (TPat a) -> (TPat a)+ TPat_Repeat :: Int -> (TPat a) -> (TPat a)+ TPat_EnumFromTo :: (TPat a) -> (TPat a) -> (TPat a)+ TPat_Var :: String -> (TPat a)+ TPat_Chord :: (Num b, Enum b, Parseable b, Enumerable b) => (b -> a) -> (TPat b) -> (TPat String) -> [TPat [Modifier]] -> (TPat a) +instance Show a => Show (TPat a) where+ show (TPat_Atom c v) = "TPat_Atom (" ++ show c ++ ") (" ++ show v ++ ")"+ show (TPat_Fast t v) = "TPat_Fast (" ++ show t ++ ") (" ++ show v ++ ")"+ show (TPat_Slow t v) = "TPat_Slow (" ++ show t ++ ") (" ++ show v ++ ")"+ show (TPat_DegradeBy x r v) = "TPat_DegradeBy (" ++ show x ++ ") (" ++ show r ++ ") (" ++ show v ++ ")"+ show (TPat_CycleChoose x vs) = "TPat_CycleChoose (" ++ show x ++ ") (" ++ show vs ++ ")"+ show (TPat_Euclid a b c v) = "TPat_Euclid (" ++ show a ++ ") (" ++ show b ++ ") (" ++ show c ++ ") " ++ show v ++ ")"+ show (TPat_Stack vs) = "TPat_Stack " ++ show vs+ show (TPat_Polyrhythm mSteprate vs) = "TPat_Polyrhythm (" ++ show mSteprate ++ ") " ++ show vs+ show (TPat_Seq vs) = "TPat_Seq " ++ show vs+ show TPat_Silence = "TPat_Silence"+ show TPat_Foot = "TPat_Foot"+ show (TPat_Elongate r v) = "TPat_Elongate (" ++ show r ++ ") (" ++ show v ++ ")"+ show (TPat_Repeat r v) = "TPat_Repeat (" ++ show r ++ ") (" ++ show v ++ ")"+ show (TPat_EnumFromTo a b) = "TPat_EnumFromTo (" ++ show a ++ ") (" ++ show b ++ ")"+ show (TPat_Var s) = "TPat_Var " ++ show s+ show (TPat_Chord g iP nP msP) = "TPat_Chord (" ++ (show $ fmap g iP) ++ ") (" ++ show nP ++ ") (" ++ show msP ++ ")"++instance Functor TPat where+ fmap f (TPat_Atom c v) = TPat_Atom c (f v)+ fmap f (TPat_Fast t v) = TPat_Fast t (fmap f v)+ fmap f (TPat_Slow t v) = TPat_Slow t (fmap f v)+ fmap f (TPat_DegradeBy x r v) = TPat_DegradeBy x r (fmap f v)+ fmap f (TPat_CycleChoose x vs) = TPat_CycleChoose x (map (fmap f) vs)+ fmap f (TPat_Euclid a b c v) = TPat_Euclid a b c (fmap f v)+ fmap f (TPat_Stack vs) = TPat_Stack (map (fmap f) vs)+ fmap f (TPat_Polyrhythm mSteprate vs) = TPat_Polyrhythm mSteprate (map (fmap f) vs)+ fmap f (TPat_Seq vs) = TPat_Seq (map (fmap f) vs)+ fmap _ TPat_Silence = TPat_Silence+ fmap _ TPat_Foot = TPat_Foot+ fmap f (TPat_Elongate r v) = TPat_Elongate r (fmap f v)+ fmap f (TPat_Repeat r v) = TPat_Repeat r (fmap f v)+ fmap f (TPat_EnumFromTo a b) = TPat_EnumFromTo (fmap f a) (fmap f b)+ fmap _ (TPat_Var s) = TPat_Var s+ fmap f (TPat_Chord g iP nP msP) = TPat_Chord (f . g) iP nP msP+ tShowList :: (Show a) => [TPat a] -> String tShowList vs = "[" ++ intercalate "," (map tShow vs) ++ "]" @@ -107,6 +144,7 @@ tShow TPat_Silence = "silence" tShow (TPat_EnumFromTo a b) = "unwrap $ fromTo <$> (" ++ tShow a ++ ") <*> (" ++ tShow b ++ ")" tShow (TPat_Var s) = "getControl " ++ s+tShow (TPat_Chord f n name mods) = "chord (" ++ (tShow $ fmap f n) ++ ") (" ++ tShow name ++ ")" ++ tShowList mods tShow a = "can't happen? " ++ show a @@ -132,6 +170,7 @@ | otherwise = pure $ fst $ head pats TPat_Seq xs -> snd $ resolve_seq xs TPat_Var s -> getControl s+ TPat_Chord f iP nP mP -> chordToPatSeq f (toPat iP) (toPat nP) (map toPat mP) _ -> silence resolve_tpat :: (Enumerable a, Parseable a) => TPat a -> (Rational, Pattern a)@@ -431,23 +470,29 @@ pChar = wrapPos $ TPat_Atom Nothing <$> pCharNum pDouble :: MyParser (TPat Double)-pDouble = wrapPos $ do s <- sign- f <- choice [fromRational <$> pRatio, parseNote] <?> "float"- let v = applySign s f- do TPat_Stack . map (TPat_Atom Nothing . (+ v)) <$> parseChord- <|> return (TPat_Atom Nothing v)- <|>- do TPat_Stack . map (TPat_Atom Nothing) <$> parseChord+pDouble = try $ do d <- pDoubleWithoutChord+ pChord d <|> return d+ <|> pChord (TPat_Atom Nothing 0)+ <|> pDoubleWithoutChord +pDoubleWithoutChord :: MyParser (TPat Double)+pDoubleWithoutChord = pPart $ wrapPos $ do s <- sign+ f <- choice [fromRational <$> pRatio, parseNote] <?> "float"+ return $ TPat_Atom Nothing (applySign s f)+ pNote :: MyParser (TPat Note)-pNote = wrapPos $ fmap (fmap Note) $ do s <- sign- f <- choice [intOrFloat, parseNote] <?> "float"- let v = applySign s f- do TPat_Stack . map (TPat_Atom Nothing . (+ v)) <$> parseChord- <|> return (TPat_Atom Nothing v)- <|> do TPat_Stack . map (TPat_Atom Nothing) <$> parseChord- <|> do TPat_Atom Nothing . fromRational <$> pRatio+pNote = try $ do n <- pNoteWithoutChord+ pChord n <|> return n+ <|> pChord (TPat_Atom Nothing 0)+ <|> pNoteWithoutChord+ <|> do TPat_Atom Nothing . fromRational <$> pRatio +pNoteWithoutChord :: MyParser (TPat Note)+pNoteWithoutChord = pPart $ wrapPos $ do s <- sign+ f <- choice [intOrFloat, parseNote] <?> "float"+ return $ TPat_Atom Nothing (Note $ applySign s f)++ pBool :: MyParser (TPat Bool) pBool = wrapPos $ do oneOf "t1" return $ TPat_Atom Nothing True@@ -462,13 +507,15 @@ then return $ applySign s $ round d else fail "not an integer" -pIntegral :: Integral a => MyParser (TPat a)-pIntegral = wrapPos $ do i <- parseIntNote- do TPat_Stack . map (TPat_Atom Nothing . (+i)) <$> parseChord- <|> return (TPat_Atom Nothing i)- <|>- do TPat_Stack . map (TPat_Atom Nothing) <$> parseChord+pIntegral :: (Integral a, Parseable a, Enumerable a) => MyParser (TPat a)+pIntegral = try $ do i <- pIntegralWithoutChord+ pChord i <|> return i+ <|> pChord (TPat_Atom Nothing 0)+ <|> pIntegralWithoutChord +pIntegralWithoutChord :: (Integral a, Parseable a, Enumerable a) => MyParser (TPat a)+pIntegralWithoutChord = pPart $ wrapPos $ fmap (TPat_Atom Nothing) parseIntNote+ parseChord :: (Enum a, Num a) => MyParser [a] parseChord = do char '\'' name <- many1 $ letter <|> digit@@ -607,3 +654,47 @@ isInt :: RealFrac a => a -> Bool isInt x = x == fromInteger (round x)++---++instance Parseable [Modifier] where+ tPatParser = pModifiers+ doEuclid = euclidOff++instance Enumerable [Modifier] where+ fromTo a b = fastFromList [a,b]+ fromThenTo a b c = fastFromList [a,b,c]++parseModInv :: MyParser Modifier+parseModInv = char 'i' >> return Invert++parseModInvNum :: MyParser [Modifier]+parseModInvNum = do+ char 'i'+ n <- pInteger+ return $ replicate (round n) Invert++parseModDrop :: MyParser [Modifier]+parseModDrop = do+ char 'd'+ n <- pInteger+ return $ [Drop $ round n]++parseModOpen :: MyParser Modifier+parseModOpen = char 'o' >> return Open++parseModRange :: MyParser Modifier+parseModRange = parseIntNote >>= \i -> return $ Range $ fromIntegral i++parseModifiers :: MyParser [Modifier]+parseModifiers = (many1 parseModOpen) <|> parseModDrop <|> (fmap pure parseModRange) <|> try parseModInvNum <|> (many1 parseModInv) <?> "modifier"++pModifiers :: MyParser (TPat [Modifier])+pModifiers = wrapPos $ TPat_Atom Nothing <$> parseModifiers++pChord :: (Enum a, Num a, Parseable a, Enumerable a) => TPat a -> MyParser (TPat a)+pChord i = do+ char '\''+ n <- pPart pVocable <?> "chordname"+ ms <- option [] $ many1 $ (char '\'' >> pPart pModifiers)+ return $ TPat_Chord id i n ms
src/Sound/Tidal/Pattern.hs view
@@ -37,7 +37,7 @@ import Control.Monad ((>=>)) import qualified Data.Map.Strict as Map import Data.Maybe (isJust, fromJust, catMaybes, mapMaybe)-import Data.List (delete, findIndex, sort)+import Data.List (delete, findIndex, (\\)) import Data.Word (Word8) import Data.Data (Data) -- toConstr import Data.Typeable (Typeable)@@ -79,7 +79,11 @@ (*>) :: Pattern (a -> b) -> Pattern a -> Pattern b (*>) = applyPatToPatRight -infixl 4 <*, *>+-- | Like <*>, but the 'wholes' come from the left+(<<*) :: Pattern (a -> b) -> Pattern a -> Pattern b+(<<*) = applyPatToPatSqueeze++infixl 4 <*, *>, <<* applyPatToPat :: (Maybe Arc -> Maybe Arc -> Maybe (Maybe Arc)) -> Pattern (a -> b) -> Pattern a -> Pattern b applyPatToPat combineWholes pf px = Pattern q where q st = catMaybes $ concatMap match $ query pf st@@ -126,6 +130,9 @@ part' <- subArc (part ef) (part ex) return (Event (combineContexts [context ef, context ex]) whole' part' (value ef $ value ex)) +applyPatToPatSqueeze :: Pattern (a -> b) -> Pattern a -> Pattern b+applyPatToPatSqueeze pf px = squeezeJoin $ (\f -> f <$> px) <$> pf+ -- * Monad and friends -- Note there are four ways of joining - the default 'unwrap' used by @>>=@, as well@@ -341,7 +348,7 @@ empty = Pattern {query = const []} queryArc :: Pattern a -> Arc -> [Event a]-queryArc p a = query p $ State a Map.empty +queryArc p a = query p $ State a Map.empty -- | Splits queries that span cycles. For example `query p (0.5, 1.5)` would be -- turned into two queries, `(0.5,1)` and `(1,1.5)`, and the results@@ -422,7 +429,7 @@ _fastGap :: Time -> Pattern a -> Pattern a _fastGap 0 _ = empty-_fastGap r p = splitQueries $ +_fastGap r p = splitQueries $ withResultArc (\(Arc s e) -> Arc (sam s + ((s - sam s)/r')) (sam s + ((e - sam s)/r')) ) $ p {query = f}@@ -573,11 +580,6 @@ onsetIn :: Arc -> Event a -> Bool onsetIn a e = isIn a (wholeStart e) --- | Compares two lists of events, attempting to combine fragmented events in the process--- for a 'truer' compare-compareDefrag :: (Ord a) => [Event a] -> [Event a] -> Bool-compareDefrag as bs = sort (defragParts as) == sort (defragParts bs)- -- | Returns a list of events, with any adjacent parts of the same whole combined defragParts :: Eq a => [Event a] -> [Event a] defragParts [] = []@@ -833,3 +835,52 @@ valueToPattern :: Value -> Pattern Value valueToPattern (VPattern pat) = pat valueToPattern v = pure v++--- functions relating to chords/patterns of lists+++sameDur :: Event a -> Event a -> Bool+sameDur e1 e2 = (whole e1 == whole e2) && (part e1 == part e2)++groupEventsBy :: Eq a => (Event a -> Event a -> Bool) -> [Event a] -> [[Event a]]+groupEventsBy _ [] = []+groupEventsBy f (e:es) = eqs:(groupEventsBy f (es \\ eqs))+ where eqs = e:[x | x <- es, f e x]++-- assumes that all events in the list have same whole/part+collectEvent :: [Event a] -> Maybe (Event [a])+collectEvent [] = Nothing+collectEvent l@(e:_) = Just $ e {context = con, value = vs}+ where con = unionC $ map context l+ vs = map value l+ unionC [] = Context []+ unionC ((Context is):cs) = Context (is ++ iss)+ where Context iss = unionC cs++collectEventsBy :: Eq a => (Event a -> Event a -> Bool) -> [Event a] -> [Event [a]]+collectEventsBy f es = remNo $ map collectEvent (groupEventsBy f es)+ where+ remNo [] = []+ remNo (Nothing:cs) = remNo cs+ remNo ((Just c):cs) = c : (remNo cs)++-- | collects all events satisfying the same constraint into a list+collectBy :: Eq a => (Event a -> Event a -> Bool) -> Pattern a -> Pattern [a]+collectBy f = withEvents (collectEventsBy f)++-- | collects all events occuring at the exact same time into a list+collect :: Eq a => Pattern a -> Pattern [a]+collect = collectBy sameDur++uncollectEvent :: Event [a] -> [Event a]+uncollectEvent e = [e {value = (value e)!!i, context = resolveContext i (context e)} | i <-[0..length (value e) - 1]]+ where resolveContext i (Context xs) = case length xs <= i of+ True -> Context []+ False -> Context [xs!!i]++uncollectEvents :: [Event [a]] -> [Event a]+uncollectEvents = concatMap uncollectEvent++-- | merges all values in a list into one pattern by stacking the values+uncollect :: Pattern [a] -> Pattern a+uncollect = withEvents uncollectEvents
src/Sound/Tidal/Safe/Context.hs view
@@ -46,12 +46,11 @@ , streamSetB , transition , module C- , startTidal, superdirtTarget, Target(..)+ , Target(..) ) where import Data.Ratio as C-import Sound.Tidal.Carabiner as C import Sound.Tidal.Config as C import Sound.Tidal.Control as C import Sound.Tidal.Core as C@@ -65,11 +64,9 @@ -- import Sound.Tidal.Transition as C import Sound.Tidal.UI as C import Sound.Tidal.Version as C-import Sound.Tidal.EspGrid as C import qualified Sound.Tidal.Context as C-import Sound.Tidal.Context- (Stream, Pattern, ControlPattern, Time)+import Sound.Tidal.Context (Stream) import Control.Monad.Reader import Control.Monad.Catch @@ -77,7 +74,7 @@ deriving (Functor, Applicative, Monad, MonadCatch,MonadThrow) exec :: Stream -> Op r -> IO r-exec s (Op m) = runReaderT m s+exec stream (Op m) = runReaderT m stream op1 f = Op $ do a <- ask; lift $ f a op2 f b = Op $ do a <- ask; lift $ f a b
src/Sound/Tidal/Stream.hs view
@@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-missing-fields #-} {-# language DeriveGeneric, StandaloneDeriving #-} -module Sound.Tidal.Stream where+module Sound.Tidal.Stream (module Sound.Tidal.Stream) where {- Stream.hs - Tidal's thingie for turning patterns into OSC streams@@ -26,9 +26,12 @@ import Control.Concurrent.MVar import Control.Concurrent import Control.Monad (forM_, when)+import Data.Coerce (coerce) import qualified Data.Map.Strict as Map import Data.Maybe (fromJust, fromMaybe, catMaybes, isJust) import qualified Control.Exception as E+import Foreign+import Foreign.C.Types import System.IO (hPutStrLn, stderr) import qualified Sound.OSC.FD as O@@ -37,6 +40,7 @@ import Sound.Tidal.Config import Sound.Tidal.Core (stack, silence, (#)) import Sound.Tidal.ID+import qualified Sound.Tidal.Link as Link import Sound.Tidal.Params (pS) import Sound.Tidal.Pattern import qualified Sound.Tidal.Tempo as T@@ -45,23 +49,23 @@ import Data.List (sortOn) import System.Random (getStdRandom, randomR) import Sound.Tidal.Show ()-import Data.Word (Word8) import Sound.Tidal.Version +import Sound.Tidal.StreamTypes as Sound.Tidal.Stream+ data Stream = Stream {sConfig :: Config, sBusses :: MVar [Int], sStateMV :: MVar ValueMap, -- sOutput :: MVar ControlPattern,+ sLink :: Link.AbletonLink, sListen :: Maybe O.UDP, sPMapMV :: MVar PlayMap,- sTempoMV :: MVar T.Tempo,+ sActionsMV :: MVar [T.TempoAction], sGlobalFMV :: MVar (ControlPattern -> ControlPattern), sCxs :: [Cx] } -type PatId = String- data Cx = Cx {cxTarget :: Target, cxUDP :: O.UDP, cxOSCs :: [OSC],@@ -99,15 +103,18 @@ | OSCContext {path :: String} deriving Show -data PlayState = PlayState {pattern :: ControlPattern,- mute :: Bool,- solo :: Bool,- history :: [ControlPattern]- }- deriving Show--type PlayMap = Map.Map PatId PlayState-+data ProcessedEvent =+ ProcessedEvent {+ peHasOnset :: Bool,+ peEvent :: Event ValueMap,+ peCps :: Link.BPM,+ peDelta :: Link.Micros,+ peCycle :: Time,+ peOnWholeOrPart :: Link.Micros,+ peOnWholeOrPartOsc :: O.Time,+ peOnPart :: Link.Micros,+ peOnPartOsc :: O.Time+ } sDefault :: String -> Maybe Value sDefault x = Just $ VS x@@ -186,13 +193,19 @@ -- ("id", iDefault 0) ] +defaultCps :: O.Time+defaultCps = 0.5625++-- Start an instance of Tidal+-- Spawns a thread within Tempo that acts as the clock+-- Spawns a thread that listens to and acts on OSC control messages startStream :: Config -> [(Target, [OSC])] -> IO Stream startStream config oscmap = do sMapMV <- newMVar Map.empty pMapMV <- newMVar Map.empty bussesMV <- newMVar [] globalFMV <- newMVar id- tempoMV <- newEmptyMVar+ actionsMV <- newEmptyMVar tidal_status_string >>= verbose config verbose config $ "Listening for external controls on " ++ cCtrlAddr config ++ ":" ++ show (cCtrlPort config)@@ -208,17 +221,27 @@ ) (oAddress target) (oPort target) return $ Cx {cxUDP = u, cxAddr = remote_addr, cxBusAddr = remote_bus_addr, cxTarget = target, cxOSCs = os} ) oscmap+ let bpm = (coerce defaultCps) * 60 * (cBeatsPerCycle config)+ abletonLink <- Link.create bpm let stream = Stream {sConfig = config, sBusses = bussesMV, sStateMV = sMapMV,+ sLink = abletonLink, sListen = listen, sPMapMV = pMapMV,- sTempoMV = tempoMV,+ sActionsMV = actionsMV, sGlobalFMV = globalFMV, sCxs = cxs } sendHandshakes stream- _ <- T.clocked config tempoMV $ onTick stream+ let ac = T.ActionHandler {+ T.onTick = onTick stream,+ T.onSingleTick = onSingleTick stream,+ T.updatePattern = updatePattern stream+ }+ -- Spawn a thread that acts as the clock+ _ <- T.clocked config sMapMV pMapMV actionsMV ac abletonLink+ -- Spawn a thread to handle OSC control messages _ <- forkIO $ ctrlResponder 0 config stream return stream @@ -250,6 +273,7 @@ addr:_ <- N.getAddrInfo (Just hints) (Just host) (Just port) return addr +-- Start an instance of Tidal with superdirt OSC startTidal :: Target -> Config -> IO Stream startTidal target config = startStream config [(target, [superdirtShape])] @@ -314,106 +338,148 @@ else not (mute pState) ) $ Map.elems pMap -toOSC :: Double -> [Int] -> Event ValueMap -> T.Tempo -> OSC -> [(Double, Bool, O.Message)]-toOSC latency busses e tempo osc@(OSC _ _)+toOSC :: [Int] -> ProcessedEvent -> OSC -> [(Double, Bool, O.Message)]+toOSC busses pe osc@(OSC _ _) = catMaybes (playmsg:busmsgs)- where (playmap, busmap) = Map.partitionWithKey (\k _ -> null k || head k /= '^') $ value e- -- swap in bus ids where needed- playmap' = Map.union (Map.mapKeys tail $ Map.map (\(VI i) -> VS ('c':(show $ toBus i))) busmap) playmap- addExtra = Map.union playmap' extra- playmsg | eventHasOnset e = do vs <- toData osc (e {value = addExtra})- mungedPath <- substitutePath (path osc) playmap'- return (ts,- False, -- bus message ?- O.Message mungedPath vs- )- | otherwise = Nothing- toBus n | null busses = n- | otherwise = busses !!! n- busmsgs = map- (\(('^':k), (VI b)) -> do v <- Map.lookup k playmap- return $ (tsPart,- True, -- bus message ?- O.Message "/c_set" [O.int32 b, toDatum v]- )- )- (Map.toList busmap)- onPart = sched tempo $ start $ part e- on = sched tempo $ start $ wholeOrPart e- off = sched tempo $ stop $ wholeOrPart e- delta = off - on- -- If there is already cps in the event, the union will preserve that.- extra = Map.fromList [("cps", (VF (T.cps tempo))),- ("delta", VF delta),- ("cycle", VF (fromRational $ start $ wholeOrPart e)) - ]- nudge = fromJust $ getF $ fromMaybe (VF 0) $ Map.lookup "nudge" $ playmap- ts = on + nudge + latency- tsPart = onPart + nudge + latency--toOSC latency _ e tempo (OSCContext oscpath)- = map cToM $ contextPosition $ context e+ -- playmap is a ValueMap where the keys don't start with ^ and are not ""+ -- busmap is a ValueMap containing the rest of the keys from the event value+ -- The partition is performed in order to have special handling of bus ids.+ where+ (playmap, busmap) = Map.partitionWithKey (\k _ -> null k || head k /= '^') $ val pe+ -- Map in bus ids where needed.+ --+ -- Bus ids are integers+ -- If busses is empty, the ids to send are directly contained in the the values of the busmap.+ -- Otherwise, the ids to send are contained in busses at the indices of the values of the busmap.+ -- Both cases require that the values of the busmap are only ever integers,+ -- that is, they are Values with constructor VI+ -- (but perhaps we should explicitly crash with an error message if it contains something else?).+ -- Map.mapKeys tail is used to remove ^ from the keys.+ -- In case (value e) has the key "", we will get a crash here.+ playmap' = Map.union (Map.mapKeys tail $ Map.map (\(VI i) -> VS ('c':(show $ toBus i))) busmap) playmap+ val = value . peEvent+ -- Only events that start within the current nowArc are included+ playmsg | peHasOnset pe = do+ -- If there is already cps in the event, the union will preserve that.+ let extra = Map.fromList [("cps", (VF (coerce $! peCps pe))),+ ("delta", VF (T.addMicrosToOsc (peDelta pe) 0)),+ ("cycle", VF (fromRational (peCycle pe))) + ]+ addExtra = Map.union playmap' extra+ ts = (peOnWholeOrPartOsc pe) + nudge -- + latency+ vs <- toData osc ((peEvent pe) {value = addExtra})+ mungedPath <- substitutePath (path osc) playmap'+ return (ts,+ False, -- bus message ?+ O.Message mungedPath vs+ )+ | otherwise = Nothing+ toBus n | null busses = n+ | otherwise = busses !!! n+ busmsgs = map+ (\(('^':k), (VI b)) -> do v <- Map.lookup k playmap+ return $ (tsPart,+ True, -- bus message ?+ O.Message "/c_set" [O.int32 b, toDatum v]+ )+ )+ (Map.toList busmap)+ where+ tsPart = (peOnPartOsc pe) + nudge -- + latency+ nudge = fromJust $ getF $ fromMaybe (VF 0) $ Map.lookup "nudge" $ playmap+toOSC _ pe (OSCContext oscpath)+ = map cToM $ contextPosition $ context $ peEvent pe where cToM :: ((Int,Int),(Int,Int)) -> (Double, Bool, O.Message) cToM ((x, y), (x',y')) = (ts, False, -- bus message ?- O.Message oscpath $ (O.string ident):(O.float delta):(O.float cyc):(map O.int32 [x,y,x',y'])+ O.Message oscpath $ (O.string ident):(O.float (peDelta pe)):(O.float cyc):(map O.int32 [x,y,x',y']) )- on = sched tempo $ start $ wholeOrPart e- off = sched tempo $ stop $ wholeOrPart e- delta = off - on cyc :: Double- cyc = fromRational $ start $ wholeOrPart e- nudge = fromMaybe 0 $ Map.lookup "nudge" (value e) >>= getF- ident = fromMaybe "unknown" $ Map.lookup "_id_" (value e) >>= getS- ts = on + nudge + latency+ cyc = fromRational $ peCycle pe+ nudge = fromMaybe 0 $ Map.lookup "nudge" (value $ peEvent pe) >>= getF+ ident = fromMaybe "unknown" $ Map.lookup "_id_" (value $ peEvent pe) >>= getS+ ts = (peOnWholeOrPartOsc pe) + nudge -- + latency -doCps :: MVar T.Tempo -> (Double, Maybe Value) -> IO ()-doCps tempoMV (d, Just (VF cps)) =- do _ <- forkIO $ do threadDelay $ floor $ d * 1000000- -- hack to stop things from stopping !- -- TODO is this still needed?- _ <- T.setCps tempoMV (max 0.00001 cps)- return ()- return ()-doCps _ _ = return ()+-- Used for Tempo callback+updatePattern :: Stream -> ID -> ControlPattern -> IO ()+updatePattern stream k pat = do+ let x = queryArc pat (Arc 0 0)+ pMap <- seq x $ takeMVar (sPMapMV stream)+ let playState = updatePS $ Map.lookup (fromID k) pMap+ putMVar (sPMapMV stream) $ Map.insert (fromID k) playState pMap+ where updatePS (Just playState) = do playState {pattern = pat', history = pat:(history playState)}+ updatePS Nothing = PlayState pat' False False [pat']+ pat' = pat # pS "_id_" (pure $ fromID k) -onTick :: Stream -> T.State -> IO ()-onTick stream st- = do doTick False stream st+processCps :: T.LinkOperations -> [Event ValueMap] -> IO [ProcessedEvent]+processCps ops = mapM processEvent+ where+ processEvent :: Event ValueMap -> IO ProcessedEvent+ processEvent e = do+ let wope = wholeOrPart e+ partStartCycle = start $ part e+ partStartBeat = (T.cyclesToBeat ops) (realToFrac partStartCycle)+ onCycle = start wope+ onBeat = (T.cyclesToBeat ops) (realToFrac onCycle)+ offCycle = stop wope+ offBeat = (T.cyclesToBeat ops) (realToFrac offCycle)+ on <- (T.timeAtBeat ops) onBeat+ onPart <- (T.timeAtBeat ops) partStartBeat+ when (eventHasOnset e) (do+ let cps' = Map.lookup "cps" (value e) >>= getF+ maybe (return ()) (\newCps -> (T.setTempo ops) ((T.cyclesToBeat ops) (newCps * 60)) on) $ coerce cps' + )+ off <- (T.timeAtBeat ops) offBeat+ bpm <- (T.getTempo ops)+ let cps = ((T.beatToCycles ops) bpm) / 60+ let delta = off - on+ return $! ProcessedEvent {+ peHasOnset = eventHasOnset e,+ peEvent = e,+ peCps = cps,+ peDelta = delta,+ peCycle = onCycle,+ peOnWholeOrPart = on,+ peOnWholeOrPartOsc = (T.linkToOscTime ops) on,+ peOnPart = onPart,+ peOnPartOsc = (T.linkToOscTime ops) onPart+ } -processCps :: T.Tempo -> [Event ValueMap] -> ([(T.Tempo, Event ValueMap)], T.Tempo)-processCps t [] = ([], t)--- If an event has a tempo change, that affects the following events..-processCps t (e:evs) = (((t', e):es'), t'')- where cps' | eventHasOnset e = do x <- Map.lookup "cps" $ value e- getF x- | otherwise = Nothing- t' = (maybe t (\newCps -> T.changeTempo' t newCps (eventPartStart e)) cps')- (es', t'') = processCps t' evs +-- streamFirst but with random cycle instead of always first cicle streamOnce :: Stream -> ControlPattern -> IO () streamOnce st p = do i <- getStdRandom $ randomR (0, 8192) streamFirst st $ rotL (toRational (i :: Int)) p +-- here let's do modifyMVar_ on actions streamFirst :: Stream -> ControlPattern -> IO ()-streamFirst stream pat = do now <- O.time- tempo <- readMVar (sTempoMV stream)- pMapMV <- newMVar $ Map.singleton "fake"- (PlayState {pattern = pat,- mute = False,- solo = False,- history = []- }- )- let cps = T.cps tempo- state = T.State {T.ticks = 0,- T.start = now,- T.nowTimespan = (now, now + (1/cps)),- T.starting = True, -- really?- T.nowArc = (Arc 0 1)- }- doTick True (stream {sPMapMV = pMapMV}) state+streamFirst stream pat = modifyMVar_ (sActionsMV stream) (\actions -> return $ (T.SingleTick pat) : actions) +-- Used for Tempo callback+onTick :: Stream -> TickState -> T.LinkOperations -> ValueMap -> IO ValueMap+onTick stream st ops s+ = doTick stream st ops s++-- Used for Tempo callback+-- Tempo changes will be applied.+-- However, since the full arc is processed at once and since Link does not support+-- scheduling, tempo change may affect scheduling of events that happen earlier+-- in the normal stream (the one handled by onTick).+onSingleTick :: Stream -> T.LinkOperations -> ValueMap -> ControlPattern -> IO ValueMap+onSingleTick stream ops s pat = do+ pMapMV <- newMVar $ Map.singleton "fake"+ (PlayState {pattern = pat,+ mute = False,+ solo = False,+ history = []+ }+ )++ -- The nowArc is a full cycle+ let state = TickState {tickArc = (Arc 0 1), tickNudge = 0}+ doTick (stream {sPMapMV = pMapMV}) state ops s++ -- | Query the current pattern (contained in argument @stream :: Stream@) -- for the events in the current arc (contained in argument @st :: T.State@), -- translate them to OSC messages, and send these.@@ -427,62 +493,42 @@ -- this function prints a warning and resets the current pattern -- to the previous one (or to silence if there isn't one) and continues, -- because the likely reason is that something is wrong with the current pattern.-doTick :: Bool -> Stream -> T.State -> IO ()-doTick fake stream st =+doTick :: Stream -> TickState -> T.LinkOperations -> ValueMap -> IO ValueMap+doTick stream st ops sMap = E.handle (\ (e :: E.SomeException) -> do hPutStrLn stderr $ "Failed to Stream.doTick: " ++ show e hPutStrLn stderr $ "Return to previous pattern." setPreviousPatternOrSilence stream- ) $- modifyState $ \(tempo, sMap) -> do- pMap <- readMVar (sPMapMV stream)- busses <- readMVar (sBusses stream)- sGlobalF <- readMVar (sGlobalFMV stream)- -- putStrLn $ show st- let config = sConfig stream- cxs = sCxs stream- cycleNow = T.timeToCycles tempo $ T.start st- patstack = sGlobalF $ playStack pMap- -- If a 'fake' tick, it'll be aligned with cycle zero- pat | fake = withResultTime (+ cycleNow) patstack- | otherwise = patstack- frameEnd = snd $ T.nowTimespan st- -- add cps to state- sMap' = Map.insert "_cps" (VF (T.cps tempo)) sMap- --filterOns = filter eventHasOnset- extraLatency | fake = 0- | otherwise = cFrameTimespan config + T.nudged tempo- -- First the state is used to query the pattern- es = sortOn (start . part) $ query pat (State {arc = T.nowArc st,+ return sMap) (do+ pMap <- readMVar (sPMapMV stream)+ busses <- readMVar (sBusses stream)+ sGlobalF <- readMVar (sGlobalFMV stream)+ bpm <- (T.getTempo ops)+ let+ cxs = sCxs stream+ patstack = sGlobalF $ playStack pMap+ cps = ((T.beatToCycles ops) bpm) / 60+ sMap' = Map.insert "_cps" (VF $ coerce cps) sMap+ extraLatency = tickNudge st+ -- First the state is used to query the pattern+ es = sortOn (start . part) $ query patstack (State {arc = tickArc st, controls = sMap'- }+ } ) -- Then it's passed through the events- (sMap'', es') = resolveState sMap' es- - -- TODO onset is calculated in toOSC as well..- on e tempo'' = (sched tempo'' $ start $ wholeOrPart e)- (tes, tempo') = processCps tempo $ es'- forM_ cxs $ \cx@(Cx target _ oscs _ _) -> do- let latency = oLatency target + extraLatency- ms = concatMap (\(t, e) ->- if (fake || (on e t) < frameEnd)- then concatMap (toOSC latency busses e t) oscs- else []- ) tes- forM_ ms $ \ m -> send (sListen stream) cx m `E.catch` \ (e :: E.SomeException) -> do- hPutStrLn stderr $ "Failed to send. Is the '" ++ oName target ++ "' target running? " ++ show e-- when (tempo /= tempo') $ T.sendTempo tempo'-- (tempo', sMap'') `seq` return (tempo', sMap'')- where modifyState :: ((T.Tempo, ValueMap) -> IO (T.Tempo, ValueMap)) -> IO ()- modifyState io = E.mask $ \restore -> do- s <- takeMVar (sStateMV stream)- t <- takeMVar (sTempoMV stream)- (t', s') <- restore (io (t, s)) `E.onException` (do {putMVar (sStateMV stream) s; putMVar (sTempoMV stream) t; return ()})- putMVar (sStateMV stream) s'- putMVar (sTempoMV stream) t'+ (sMap'', es') = resolveState sMap' es+ tes <- processCps ops es'+ -- For each OSC target+ forM_ cxs $ \cx@(Cx target _ oscs _ _) -> do+ -- Latency is configurable per target.+ -- Latency is only used when sending events live.+ let latency = oLatency target+ ms = concatMap (\e -> concatMap (toOSC busses e) oscs) tes+ -- send the events to the OSC target+ forM_ ms $ \ m -> (do+ send (sListen stream) cx latency extraLatency m) `E.catch` \ (e :: E.SomeException) -> do+ hPutStrLn stderr $ "Failed to send. Is the '" ++ oName target ++ "' target running? " ++ show e+ sMap'' `seq` return sMap'') setPreviousPatternOrSilence :: Stream -> IO () setPreviousPatternOrSilence stream =@@ -491,36 +537,35 @@ _:p:ps -> pMap { pattern = p, history = p:ps } _ -> pMap { pattern = silence, history = [silence] } )- -send :: Maybe O.UDP -> Cx -> (Double, Bool, O.Message) -> IO ()-send listen cx (time, isBusMsg, m)- | oSchedule target == Pre BundleStamp = sendBndl isBusMsg listen cx $ O.Bundle time [m]++-- send has three modes:+-- Send events early using timestamp in the OSC bundle - used by Superdirt+-- Send events early by adding timestamp to the OSC message - used by Dirt+-- Send events live by delaying the thread+send :: Maybe O.UDP -> Cx -> Double -> Double -> (Double, Bool, O.Message) -> IO ()+send listen cx latency extraLatency (time, isBusMsg, m)+ | oSchedule target == Pre BundleStamp = sendBndl isBusMsg listen cx $ O.Bundle timeWithLatency [m] | oSchedule target == Pre MessageStamp = sendO isBusMsg listen cx $ addtime m- | otherwise = do _ <- forkIO $ do now <- O.time- threadDelay $ floor $ (time - now) * 1000000+ | otherwise = do _ <- forkOS $ do now <- O.time+ threadDelay $ floor $ (timeWithLatency - now) * 1000000 sendO isBusMsg listen cx m return () where addtime (O.Message mpath params) = O.Message mpath ((O.int32 sec):((O.int32 usec):params))- ut = O.ntpr_to_ut time+ ut = O.ntpr_to_ut timeWithLatency sec :: Int sec = floor ut usec :: Int usec = floor $ 1000000 * (ut - (fromIntegral sec)) target = cxTarget cx--sched :: T.Tempo -> Rational -> Double-sched tempo c = ((fromRational $ c - (T.atCycle tempo)) / T.cps tempo)- + (T.atTime tempo)+ timeWithLatency = time - latency + extraLatency -- Interaction streamNudgeAll :: Stream -> Double -> IO ()-streamNudgeAll s nudge = do tempo <- takeMVar $ sTempoMV s- putMVar (sTempoMV s) $ tempo {T.nudged = nudge}+streamNudgeAll s nudge = T.setNudge (sActionsMV s) nudge streamResetCycles :: Stream -> IO ()-streamResetCycles s = do _ <- T.resetCycles (sTempoMV s)- return ()+streamResetCycles s =T.resetCycles (sActionsMV s) hasSolo :: Map.Map k PlayState -> Bool hasSolo = (>= 1) . length . filter solo . Map.elems@@ -539,25 +584,7 @@ streamReplace :: Stream -> ID -> ControlPattern -> IO () streamReplace s k !pat- = E.catch (do let x = queryArc pat (Arc 0 0)- tempo <- readMVar $ sTempoMV s- input <- takeMVar $ sStateMV s- -- put pattern id and change time in control input- now <- O.time- let cyc = T.timeToCycles tempo now- putMVar (sStateMV s) $- Map.insert ("_t_all") (VR cyc) $ Map.insert ("_t_" ++ fromID k) (VR cyc) input- -- update the pattern itself- pMap <- seq x $ takeMVar $ sPMapMV s- let playState = updatePS $ Map.lookup (fromID k) pMap- putMVar (sPMapMV s) $ Map.insert (fromID k) playState pMap- return ()- )- (\(e :: E.SomeException) -> hPutStrLn stderr $ "Error in pattern: " ++ show e- )- where updatePS (Just playState) = do playState {pattern = pat', history = pat:(history playState)}- updatePS Nothing = PlayState pat' False False [pat']- pat' = pat # pS "_id_" (pure $ fromID k)+ = modifyMVar_ (sActionsMV s) (\actions -> return $ (T.StreamReplace k pat) : actions) streamMute :: Stream -> ID -> IO () streamMute s k = withPatIds s [k] (\x -> x {mute = True})@@ -638,6 +665,7 @@ catchAny :: IO a -> (E.SomeException -> IO a) -> IO a catchAny = E.catch +-- Listen to and act on OSC control messages ctrlResponder :: Int -> Config -> Stream -> IO () ctrlResponder waits c (stream@(Stream {sListen = Just sock})) = do ms <- recvMessagesTimeout 2 sock@@ -699,20 +727,23 @@ withID _ _ = return () ctrlResponder _ _ _ = return () - verbose :: Config -> String -> IO () verbose c s = when (cVerbose c) $ putStrLn s recvMessagesTimeout :: (O.Transport t) => Double -> t -> IO [O.Message] recvMessagesTimeout n sock = fmap (maybe [] O.packetMessages) $ O.recvPacketTimeout n sock --streamGetcps :: Stream -> IO O.Time-streamGetcps s = do tempo <- readMVar $ sTempoMV s- return $ T.cps tempo+streamGetcps :: Stream -> IO Double+streamGetcps s = do+ let config = sConfig s+ ss <- Link.createAndCaptureAppSessionState (sLink s)+ bpm <- Link.getTempo ss+ return $! coerce $ bpm / (cBeatsPerCycle config) / 60 streamGetnow :: Stream -> IO Double-streamGetnow s = do tempo <- readMVar $ sTempoMV s- now <- O.time- return $ fromRational $ T.timeToCycles tempo now-+streamGetnow s = do+ let config = sConfig s+ ss <- Link.createAndCaptureAppSessionState (sLink s)+ now <- Link.clock (sLink s)+ beat <- Link.beatAtTime ss now (cQuantum config)+ return $! coerce $ beat / (cBeatsPerCycle config)
+ src/Sound/Tidal/StreamTypes.hs view
@@ -0,0 +1,21 @@+module Sound.Tidal.StreamTypes where++import qualified Data.Map.Strict as Map+import Sound.Tidal.Pattern+import Sound.Tidal.Show ()++data PlayState = PlayState {pattern :: ControlPattern,+ mute :: Bool,+ solo :: Bool,+ history :: [ControlPattern]+ }+ deriving Show++type PatId = String+type PlayMap = Map.Map PatId PlayState++data TickState = TickState {+ tickArc :: Arc,+ tickNudge :: Double+ }+ deriving Show
src/Sound/Tidal/Tempo.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, FlexibleContexts, ScopedTypeVariables, BangPatterns #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns -fno-warn-orphans #-} @@ -6,14 +7,21 @@ import Control.Concurrent.MVar import qualified Sound.Tidal.Pattern as P import qualified Sound.OSC.FD as O-import qualified Network.Socket as N import Control.Concurrent (forkIO, ThreadId, threadDelay)-import Control.Monad (forever, when, foldM)-import Data.List (nub)+import Control.Monad (when)+import qualified Data.Map.Strict as Map import qualified Control.Exception as E+import Sound.Tidal.ID import Sound.Tidal.Config import Sound.Tidal.Utils (writeError)+import qualified Sound.Tidal.Link as Link+import Foreign.C.Types (CDouble(..))+import System.IO (hPutStrLn, stderr)+import Data.Int(Int64) +import Sound.Tidal.StreamTypes+import Sound.Tidal.Core (silence)+ {- Tempo.hs - Tidal's scheduler Copyright (C) 2020, Alex McLean and contributors@@ -35,210 +43,259 @@ instance Show O.UDP where show _ = "-unshowable-" -data Tempo = Tempo {atTime :: O.Time,- atCycle :: Rational,- cps :: O.Time,- paused :: Bool,- nudged :: Double,- localUDP :: O.UDP,- remoteAddr :: N.SockAddr,- synched :: Bool- }- deriving Show+type TransitionMapper = P.Time -> [P.ControlPattern] -> P.ControlPattern -instance Eq Tempo where- (==) t t' = and [(atTime t) == (atTime t'),- (atCycle t) == (atCycle t'),- (cps t) == (cps t'),- (paused t) == (paused t'),- (nudged t) == (nudged t')- ]+data TempoAction =+ ResetCycles+ | SingleTick P.ControlPattern+ | SetNudge Double+ | StreamReplace ID P.ControlPattern+ | Transition Bool TransitionMapper ID P.ControlPattern -data State = State {ticks :: Int,- start :: O.Time,- nowTimespan :: (O.Time, O.Time),- nowArc :: P.Arc,- starting :: Bool+data State = State {ticks :: Int64,+ start :: Link.Micros,+ nowEnd :: Link.Micros,+ nowArc :: P.Arc,+ nudged :: Double } deriving Show -changeTempo :: MVar Tempo -> (O.Time -> Tempo -> Tempo) -> IO Tempo-changeTempo tempoMV f = do t <- O.time- tempo <- takeMVar tempoMV- let tempo' = f t tempo- sendTempo tempo'- putMVar tempoMV tempo'- return tempo'--changeTempo' :: Tempo -> O.Time -> Rational -> Tempo-changeTempo' tempo newCps cyc = tempo {atTime = cyclesToTime tempo cyc,- cps = newCps,- atCycle = cyc- }--resetCycles :: MVar Tempo -> IO Tempo-resetCycles tempoMV = changeTempo tempoMV (\t tempo -> tempo {atTime = t, atCycle = 0})+data ActionHandler =+ ActionHandler {+ onTick :: TickState -> LinkOperations -> P.ValueMap -> IO P.ValueMap,+ onSingleTick :: LinkOperations -> P.ValueMap -> P.ControlPattern -> IO P.ValueMap,+ updatePattern :: ID -> P.ControlPattern -> IO ()+ } -setCps :: MVar Tempo -> O.Time -> IO Tempo-setCps tempoMV newCps = changeTempo tempoMV (\t tempo -> tempo {atTime = t,- atCycle = timeToCycles tempo t,- cps = newCps- })+data LinkOperations =+ LinkOperations {+ timeAtBeat :: Link.Beat -> IO Link.Micros,+ timeToCycles :: Link.Micros -> IO P.Time,+ getTempo :: IO Link.BPM,+ setTempo :: Link.BPM -> Link.Micros -> IO (),+ linkToOscTime :: Link.Micros -> O.Time,+ beatToCycles :: CDouble -> CDouble,+ cyclesToBeat :: CDouble -> CDouble+ } -defaultCps :: O.Time-defaultCps = 0.5625+resetCycles :: MVar [TempoAction] -> IO ()+resetCycles actionsMV = modifyMVar_ actionsMV (\actions -> return $ ResetCycles : actions) -defaultTempo :: O.Time -> O.UDP -> N.SockAddr -> Tempo-defaultTempo t local remote = Tempo {atTime = t,- atCycle = 0,- cps = defaultCps,- paused = False,- nudged = 0,- localUDP = local,- remoteAddr = remote,- synched = False- }+setNudge :: MVar [TempoAction] -> Double -> IO ()+setNudge actionsMV nudge = modifyMVar_ actionsMV (\actions -> return $ SetNudge nudge : actions) --- | Returns the given time in terms of--- cycles relative to metrical grid of a given Tempo-timeToCycles :: Tempo -> O.Time -> Rational-timeToCycles tempo t = atCycle tempo + toRational cycleDelta- where delta = t - atTime tempo- cycleDelta = realToFrac (cps tempo) * delta+timeToCycles' :: Config -> Link.SessionState -> Link.Micros -> IO P.Time+timeToCycles' config ss time = do+ beat <- Link.beatAtTime ss time (cQuantum config)+ return $! (toRational beat) / (toRational (cBeatsPerCycle config)) -cyclesToTime :: Tempo -> Rational -> O.Time-cyclesToTime tempo cyc = atTime tempo + fromRational timeDelta- where cycleDelta = cyc - atCycle tempo- timeDelta = cycleDelta / toRational (cps tempo)+cyclesToTime :: Config -> Link.SessionState -> P.Time -> IO Link.Micros+cyclesToTime config ss cyc = do+ let beat = (fromRational cyc) * (cBeatsPerCycle config)+ Link.timeAtBeat ss beat (cQuantum config) -{--getCurrentCycle :: MVar Tempo -> IO Rational-getCurrentCycle t = (readMVar t) >>= (cyclesNow) >>= (return . toRational)--}+addMicrosToOsc :: Link.Micros -> O.Time -> O.Time+addMicrosToOsc m t = ((fromIntegral m) / 1000000) + t -clocked :: Config -> MVar Tempo -> (State -> IO ()) -> IO [ThreadId]-clocked config tempoMV callback- = do s <- O.time- -- TODO - do something with thread id- _ <- serverListen config- listenTid <- clientListen config tempoMV s- let st = State {ticks = 0,- start = s,- nowTimespan = (s, s + frameTimespan),+-- clocked assumes tempoMV is empty+clocked :: Config -> MVar P.ValueMap -> MVar PlayMap -> MVar [TempoAction] -> ActionHandler -> Link.AbletonLink -> IO [ThreadId]+clocked config stateMV mapMV actionsMV ac abletonLink+ = do -- TODO - do something with thread id+ clockTid <- forkIO $ loopInit+ return $! [clockTid]+ where frameTimespan :: Link.Micros+ frameTimespan = round $ (cFrameTimespan config) * 1000000+ quantum :: CDouble+ quantum = cQuantum config+ beatsPerCycle :: CDouble+ beatsPerCycle = cBeatsPerCycle config+ loopInit :: IO a+ loopInit =+ do+ when (cEnableLink config) $ Link.enable abletonLink+ sessionState <- Link.createAndCaptureAppSessionState abletonLink+ now <- Link.clock abletonLink+ let startAt = now + processAhead+ Link.requestBeatAtTime sessionState 0 startAt quantum+ Link.commitAppSessionState abletonLink sessionState+ putMVar actionsMV []+ let st = State {ticks = 0,+ start = now,+ nowEnd = logicalTime now 1, nowArc = P.Arc 0 0,- starting = True+ nudged = 0 }- clockTid <- forkIO $ loop st- return [listenTid, clockTid]- where frameTimespan :: Double- frameTimespan = cFrameTimespan config- loop st =- do -- putStrLn $ show $ nowArc ts- tempo <- readMVar tempoMV- t <- O.time- let logicalT ticks' = start st + fromIntegral ticks' * frameTimespan- logicalNow = logicalT $ ticks st + 1- -- Wait maximum of two frames- delta = min (frameTimespan * 2) (logicalNow - t)- e = timeToCycles tempo logicalNow- s = if starting st && synched tempo- then timeToCycles tempo (logicalT $ ticks st)- else P.stop $ nowArc st- when (t < logicalNow) $ threadDelay (floor $ delta * 1000000)- t' <- O.time- let actualTick = floor $ (t' - start st) / frameTimespan- -- reset ticks if ahead/behind by skipTicks or more- ahead = abs (actualTick - ticks st) > cSkipTicks config- newTick | ahead = actualTick- | otherwise = ticks st + 1- st' = st {ticks = newTick,- nowArc = P.Arc s e,- nowTimespan = (logicalNow, logicalNow + frameTimespan),- starting = not (synched tempo)- }- when ahead $ writeError $ "skip: " ++ show (actualTick - ticks st)- callback st'- {-putStrLn ("actual tick: " ++ show actualTick- ++ " old tick: " ++ show (ticks st)- ++ " new tick: " ++ show newTick- )-}- loop st'--clientListen :: Config -> MVar Tempo -> O.Time -> IO ThreadId-clientListen config tempoMV s =- do -- Listen on random port- let tempoClientPort = cTempoClientPort config- hostname = cTempoAddr config- port = cTempoPort config- (remote_addr:_) <- N.getAddrInfo Nothing (Just hostname) Nothing- local <- O.udpServer "0.0.0.0" tempoClientPort- let (N.SockAddrInet _ a) = N.addrAddress remote_addr- remote = N.SockAddrInet (fromIntegral port) a- t = defaultTempo s local remote- putMVar tempoMV t- -- Send to clock port from same port that's listened to- O.sendTo local (O.p_message "/hello" []) remote- -- Make tempo mvar- -- Listen to tempo changes- forkIO $ listenTempo local tempoMV--sendTempo :: Tempo -> IO ()-sendTempo tempo = O.sendTo (localUDP tempo) (O.p_bundle (atTime tempo) [m]) (remoteAddr tempo)- where m = O.Message "/transmit/cps/cycle" [O.Float $ fromRational $ atCycle tempo,- O.Float $ realToFrac $ cps tempo,- O.Int32 $ if paused tempo then 1 else 0- ]--listenTempo :: O.UDP -> MVar Tempo -> IO ()-listenTempo udp tempoMV = forever $ do pkt <- O.recvPacket udp- act Nothing pkt- return ()- where act _ (O.Packet_Bundle (O.Bundle ts ms)) = mapM_ (act (Just ts) . O.Packet_Message) ms- act (Just ts) (O.Packet_Message (O.Message "/cps/cycle" [O.Float atCycle',- O.Float cps',- O.Int32 paused'- ]- )- ) =- do tempo <- takeMVar tempoMV- putMVar tempoMV $ tempo {atTime = ts,- atCycle = realToFrac atCycle',- cps = realToFrac cps',- paused = paused' == 1,- synched = True- }- act _ pkt = writeError $ "Unknown packet (client): " ++ show pkt--serverListen :: Config -> IO (Maybe ThreadId)-serverListen config = catchAny run (\_ -> return Nothing) -- probably just already running)- where run = do let port = cTempoPort config- -- iNADDR_ANY deprecated - what's the right way to do this?- udp <- O.udpServer "0.0.0.0" port- cpsMessage <- defaultCpsMessage- tid <- forkIO $ loop udp ([], cpsMessage)- return $ Just tid- loop udp (cs, msg) = do (pkt,c) <- O.recvFrom udp- (cs', msg') <- act udp c Nothing (cs,msg) pkt- loop udp (cs', msg')- act :: O.UDP -> N.SockAddr -> Maybe O.Time -> ([N.SockAddr], O.Packet) -> O.Packet -> IO ([N.SockAddr], O.Packet)- act udp c _ (cs,msg) (O.Packet_Bundle (O.Bundle ts ms)) = foldM (act udp c (Just ts)) (cs,msg) $ map O.Packet_Message ms- act udp c _ (cs,msg) (O.Packet_Message (O.Message "/hello" []))- = do O.sendTo udp msg c- return (nub (c:cs),msg)- act udp _ (Just ts) (cs,_) (O.Packet_Message (O.Message "/transmit/cps/cycle" params)) =- do let path' = "/cps/cycle"- msg' = O.p_bundle ts [O.Message path' params]- mapM_ (O.sendTo udp msg') cs- return (cs, msg')- act _ x _ (cs,msg) pkt = do writeError $ "Unknown packet (serv): " ++ show pkt ++ " / " ++ show x- return (cs,msg)- catchAny :: IO a -> (E.SomeException -> IO a) -> IO a- catchAny = E.catch- defaultCpsMessage = do ts <- O.time- return $ O.p_bundle ts [O.Message "/cps/cycle" [O.Float 0,- O.Float $ realToFrac defaultCps,- O.Int32 0- ]- ]-+ checkArc $! st+ -- Time is processed at a fixed rate according to configuration+ -- logicalTime gives the time when a tick starts based on when+ -- processing first started.+ logicalTime :: Link.Micros -> Int64 -> Link.Micros+ logicalTime startTime ticks' = startTime + ticks' * frameTimespan+ -- tick moves the logical time forward or recalculates the ticks in case+ -- the logical time is out of sync with Link time.+ -- tick delays the thread when logical time is ahead of Link time.+ tick :: State -> IO a+ tick st = do+ now <- Link.clock abletonLink+ let preferredNewTick = ticks st + 1+ logicalNow = logicalTime (start st) preferredNewTick+ aheadOfNow = now + processAhead+ actualTick = (aheadOfNow - start st) `div` frameTimespan+ drifted = abs (actualTick - preferredNewTick) > cSkipTicks config+ newTick | drifted = actualTick+ | otherwise = preferredNewTick+ st' = st {ticks = newTick}+ delta = min frameTimespan (logicalNow - aheadOfNow)+ if drifted+ then writeError $ "skip: " ++ (show (actualTick - ticks st))+ else when (delta > 0) $ threadDelay $ fromIntegral delta+ checkArc st'+ -- The reference time Link uses,+ -- is the time the audio for a certain beat hits the speaker.+ -- Processing of the nowArc should happen early enough for+ -- all events in the nowArc to hit the speaker, but not too early.+ -- Processing thus needs to happen a short while before the start+ -- of nowArc. How far ahead is controlled by cProcessAhead.+ processAhead :: Link.Micros+ processAhead = round $ (cProcessAhead config) * 1000000+ checkArc :: State -> IO a+ checkArc st = do+ actions <- swapMVar actionsMV [] + st' <- processActions st actions+ let logicalEnd = logicalTime (start st') $ ticks st' + 1+ nextArcStartCycle = P.stop $ nowArc st'+ ss <- Link.createAndCaptureAppSessionState abletonLink+ arcStartTime <- cyclesToTime config ss nextArcStartCycle+ Link.destroySessionState ss+ if (arcStartTime < logicalEnd)+ then processArc st'+ else tick st'+ processArc :: State -> IO a + processArc st =+ do+ streamState <- takeMVar stateMV+ let logicalEnd = logicalTime (start st) $ ticks st + 1+ startCycle = P.stop $ nowArc st+ sessionState <- Link.createAndCaptureAppSessionState abletonLink+ endCycle <- timeToCycles' config sessionState logicalEnd+ let st' = st {nowArc = P.Arc startCycle endCycle,+ nowEnd = logicalEnd+ }+ nowOsc <- O.time+ nowLink <- Link.clock abletonLink+ let ops = LinkOperations {+ timeAtBeat = \beat -> Link.timeAtBeat sessionState beat quantum ,+ timeToCycles = timeToCycles' config sessionState,+ getTempo = Link.getTempo sessionState,+ setTempo = Link.setTempo sessionState,+ linkToOscTime = \lt -> addMicrosToOsc (lt - nowLink) nowOsc,+ beatToCycles = btc,+ cyclesToBeat = ctb+ }+ let state = TickState {+ tickArc = nowArc st',+ tickNudge = nudged st'+ }+ streamState' <- (onTick ac) state ops streamState+ Link.commitAndDestroyAppSessionState abletonLink sessionState+ putMVar stateMV streamState'+ tick st'+ btc :: CDouble -> CDouble+ btc beat = beat / beatsPerCycle+ ctb :: CDouble -> CDouble+ ctb cyc = cyc * beatsPerCycle+ processActions :: State -> [TempoAction] -> IO State+ processActions st [] = return $! st+ processActions st actions = do+ streamState <- takeMVar stateMV+ (st', streamState') <- handleActions st actions streamState+ putMVar stateMV streamState'+ return $! st'+ handleActions :: State -> [TempoAction] -> P.ValueMap -> IO (State, P.ValueMap)+ handleActions st [] streamState = return (st, streamState)+ handleActions st (ResetCycles : otherActions) streamState =+ do+ (st', streamState') <- handleActions st otherActions streamState+ sessionState <- Link.createAndCaptureAppSessionState abletonLink + let logicalEnd = logicalTime (start st') $ ticks st' + 1+ st'' = st' {+ nowArc = P.Arc 0 0,+ nowEnd = logicalEnd + frameTimespan+ }+ now <- Link.clock abletonLink+ Link.requestBeatAtTime sessionState 0 now quantum+ Link.commitAndDestroyAppSessionState abletonLink sessionState+ return (st'', streamState')+ handleActions st (SingleTick pat : otherActions) streamState =+ do+ (st', streamState') <- handleActions st otherActions streamState+ -- onSingleTick assumes it runs at beat 0.+ -- The best way to achieve that is to use forceBeatAtTime.+ -- But using forceBeatAtTime means we can not commit its session state.+ -- Another session state, which we will commit,+ -- is introduced to keep track of tempo changes.+ sessionState <- Link.createAndCaptureAppSessionState abletonLink+ zeroedSessionState <- Link.createAndCaptureAppSessionState abletonLink+ nowOsc <- O.time+ nowLink <- Link.clock abletonLink+ Link.forceBeatAtTime zeroedSessionState 0 (nowLink + processAhead) quantum+ let ops = LinkOperations {+ timeAtBeat = \beat -> Link.timeAtBeat zeroedSessionState beat quantum,+ timeToCycles = timeToCycles' config zeroedSessionState,+ getTempo = Link.getTempo zeroedSessionState,+ setTempo = \bpm micros ->+ Link.setTempo zeroedSessionState bpm micros >>+ Link.setTempo sessionState bpm micros,+ linkToOscTime = \lt -> addMicrosToOsc (lt - nowLink) nowOsc,+ beatToCycles = btc,+ cyclesToBeat = ctb+ }+ streamState'' <- (onSingleTick ac) ops streamState' pat+ Link.commitAndDestroyAppSessionState abletonLink sessionState+ Link.destroySessionState zeroedSessionState+ return (st', streamState'')+ handleActions st (SetNudge nudge : otherActions) streamState =+ do+ (st', streamState') <- handleActions st otherActions streamState+ let st'' = st' {nudged = nudge}+ return (st'', streamState')+ handleActions st (StreamReplace k pat : otherActions) streamState =+ do+ (st', streamState') <- handleActions st otherActions streamState+ E.catch (+ do+ now <- Link.clock abletonLink+ sessionState <- Link.createAndCaptureAppSessionState abletonLink+ cyc <- timeToCycles' config sessionState now+ Link.destroySessionState sessionState+ -- put pattern id and change time in control input+ let streamState'' = Map.insert ("_t_all") (P.VR $! cyc) $ Map.insert ("_t_" ++ fromID k) (P.VR $! cyc) streamState'+ (updatePattern ac) k pat+ return (st', streamState'')+ )+ (\(e :: E.SomeException) -> do+ hPutStrLn stderr $ "Error in pattern: " ++ show e+ return (st', streamState')+ )+ handleActions st (Transition historyFlag f patId pat : otherActions) streamState =+ do+ (st', streamState') <- handleActions st otherActions streamState+ let+ appendPat flag = if flag then (pat:) else id+ updatePS (Just playState) = playState {history = (appendPat historyFlag) (history playState)}+ updatePS Nothing = PlayState {pattern = silence,+ mute = False,+ solo = False,+ history = (appendPat historyFlag) (silence:[])+ }+ transition' pat' = do now <- Link.clock abletonLink+ ss <- Link.createAndCaptureAppSessionState abletonLink+ c <- timeToCycles' config ss now+ return $! f c pat'+ pMap <- readMVar mapMV+ let playState = updatePS $ Map.lookup (fromID patId) pMap+ pat' <- transition' $ appendPat (not historyFlag) (history playState)+ let pMap' = Map.insert (fromID patId) (playState {pattern = pat'}) pMap+ _ <- swapMVar mapMV pMap'+ return (st', streamState')
src/Sound/Tidal/Transition.hs view
@@ -4,9 +4,8 @@ import Prelude hiding ((<*), (*>)) -import Control.Concurrent.MVar (readMVar, swapMVar)+import Control.Concurrent.MVar (modifyMVar_) -import qualified Sound.OSC.FD as O import qualified Data.Map.Strict as Map -- import Data.Maybe (fromJust) @@ -16,7 +15,7 @@ import Sound.Tidal.Params (gain, pan) import Sound.Tidal.Pattern import Sound.Tidal.Stream-import Sound.Tidal.Tempo (timeToCycles)+import Sound.Tidal.Tempo as T import Sound.Tidal.UI (fadeOutFrom, fadeInFrom) import Sound.Tidal.Utils (enumerate) @@ -42,24 +41,7 @@ -- the "historyFlag" determines if the new pattern should be placed on the history stack or not transition :: Stream -> Bool -> (Time -> [ControlPattern] -> ControlPattern) -> ID -> ControlPattern -> IO () transition stream historyFlag f patId !pat =- do pMap <- readMVar (sPMapMV stream)- let playState = updatePS $ Map.lookup (fromID patId) pMap- pat' <- transition' $ appendPat (not historyFlag) (history playState)- let pMap' = Map.insert (fromID patId) (playState {pattern = pat'}) pMap- _ <- swapMVar (sPMapMV stream) pMap'- return ()- where- appendPat flag = if flag then (pat:) else id- updatePS (Just playState) = playState {history = (appendPat historyFlag) (history playState)}- updatePS Nothing = PlayState {pattern = silence,- mute = False,- solo = False,- history = (appendPat historyFlag) (silence:[])- }- transition' pat' = do tempo <- readMVar $ sTempoMV stream- now <- O.time- let c = timeToCycles tempo now- return $ f c pat'+ modifyMVar_ (sActionsMV stream) (\actions -> return $! (T.Transition historyFlag f patId pat) : actions) mortalOverlay :: Time -> Time -> [Pattern a] -> Pattern a mortalOverlay _ _ [] = silence
src/Sound/Tidal/UI.hs view
@@ -110,7 +110,7 @@ rand = Pattern (\(State a@(Arc s e) _) -> [Event (Context []) Nothing a (realToFrac $ (timeToRand ((e + s)/2) :: Double))]) -- | Boolean rand - a continuous stream of true/false values, with a 50/50 chance.-brand :: Pattern Bool +brand :: Pattern Bool brand = _brandBy 0.5 -- | Boolean rand with probability as input, e.g. brandBy 0.25 is 25% chance of being true.@@ -718,6 +718,8 @@ to the structure given by the `e 3 8`. It ends up picking two `bd` sounds, a `cp` and missing the `sn` entirely. +A negative first argument provides the inverse of the euclidean pattern.+ These types of sequences use "Bjorklund's algorithm", which wasn't made for music but for an application in nuclear physics, which is exciting. More exciting still is that it is very similar in structure to the one of the first@@ -755,7 +757,8 @@ euclid = tParam2 _euclid _euclid :: Int -> Int -> Pattern a -> Pattern a-_euclid n k a = fastcat $ fmap (bool silence a) $ bjorklund (n,k)+_euclid n k a | n >= 0 = fastcat $ fmap (bool silence a) $ bjorklund (n,k)+ | otherwise = fastcat $ fmap (bool a silence) $ bjorklund (-n,k) {- | `euclidfull n k pa pb` stacks @e n k pa@ with @einv n k pb@ -} euclidFull :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a -> Pattern a@@ -809,7 +812,7 @@ euclidInv = tParam2 _euclidInv _euclidInv :: Int -> Int -> Pattern a -> Pattern a-_euclidInv n k a = fastcat $ fmap (bool a silence) $ bjorklund (n,k)+_euclidInv n k a = _euclid (-n) k a index :: Real b => b -> Pattern b -> Pattern c -> Pattern c index sz indexpat pat =@@ -960,7 +963,7 @@ -- | @randcat ps@: does a @slowcat@ on the list of patterns @ps@ but -- randomises the order in which they are played. randcat :: [Pattern a] -> Pattern a-randcat ps = spread' rotL (_segment 1 $ (%1) . fromIntegral <$> (_irand (length ps) :: Pattern Int)) (slowcat ps)+randcat ps = spread' rotL (_segment 1 $ (% 1) . fromIntegral <$> (_irand (length ps) :: Pattern Int)) (slowcat ps) wrandcat :: [(Pattern a, Double)] -> Pattern a wrandcat ps = unwrap $ wchooseBy (segment 1 rand) ps@@ -1228,33 +1231,32 @@ p' = density cyc p from' = density cyc from -{-| @chunk n f p@ treats the given pattern @p@ as having @n@ chunks, and applies the function @f@ to one of those sections per cycle, running from left to right.+{-|+ Treats the given pattern @p@ as having @n@ chunks, and applies the function @f@ to one of those sections per cycle.+ Running:+ - from left to right if chunk number is positive+ - from right to left if chunk number is negative -@-d1 $ chunk 4 (density 4) $ sound "cp sn arpy [mt lt]"-@+ @+ d1 $ chunk 4 (fast 4) $ sound "cp sn arpy [mt lt]"+ @ -}-_chunk :: Int -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b-_chunk n f p = cat [withinArc (Arc (i % fromIntegral n) ((i+1) % fromIntegral n)) f p | i <- [0 .. fromIntegral n - 1]]-- chunk :: Pattern Int -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b-chunk npat f p = innerJoin $ (\n -> _chunk n f p) <$> npat---- deprecated (renamed to chunk)-runWith :: Int -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b-runWith = _chunk+chunk npat f p = innerJoin $ (\n -> _chunk n f p) <$> npat -{-| @chunk'@ works much the same as `chunk`, but runs from right to left.--}--- this was throwing a parse error when I ran it in tidal whenever I changed the function name..-_chunk' :: Integral a => a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b-_chunk' n f p = do i <- _slow (toRational n) $ rev $ run (fromIntegral n)- withinArc (Arc (i % fromIntegral n) ((i+)1 % fromIntegral n)) f p+_chunk :: Integral a => a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b+_chunk n f p | n >= 0 = cat [withinArc (Arc (i % fromIntegral n) ((i+1) % fromIntegral n)) f p | i <- [0 .. fromIntegral n - 1]]+ | otherwise = do i <- _slow (toRational (-n)) $ rev $ run (fromIntegral (-n))+ withinArc (Arc (i % fromIntegral (-n)) ((i+1) % fromIntegral (-n))) f p +-- | DEPRECATED, use 'chunk' with negative numbers instead chunk' :: Integral a1 => Pattern a1 -> (Pattern a2 -> Pattern a2) -> Pattern a2 -> Pattern a2 chunk' npat f p = innerJoin $ (\n -> _chunk' n f p) <$> npat +-- | DEPRECATED, use '_chunk' with negative numbers instead+_chunk' :: Integral a => a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b+_chunk' n f p = _chunk (-n) f p+ _inside :: Time -> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a _inside n f p = _fast n $ f (_slow n p) @@ -1468,7 +1470,7 @@ rolledWith :: Ratio Integer -> Pattern a -> Pattern a rolledWith t = withEvents aux where aux es = concatMap (steppityIn) (groupBy (\a b -> whole a == whole b) $ ((isRev t) es))- isRev b = (\x -> if x > 0 then id else reverse ) b + isRev b = (\x -> if x > 0 then id else reverse ) b steppityIn xs = mapMaybe (\(n, ev) -> (timeguard n xs ev t)) $ enumerate xs timeguard _ _ ev 0 = return ev timeguard n xs ev _ = (shiftIt n (length xs) ev)
src/Sound/Tidal/Version.hs view
@@ -21,7 +21,7 @@ -} tidal_version :: String-tidal_version = "1.8.1"+tidal_version = "1.9.0" tidal_status :: IO () tidal_status = tidal_status_string >>= putStrLn
test/Sound/Tidal/ControlTest.hs view
@@ -18,15 +18,23 @@ describe "echo" $ do it "should echo the event by the specified time and multiply the gain factor" $ do- compareP (Arc 0 1)- (echo 2 0.25 0.5 $ s "bd" # gain "1")- (stack [rotR 0 "bd" # gain 1, rotR 0.25 "bd" # gain 0.5])+ comparePD (Arc 0 1)+ (echo 3 0.2 0.5 $ s "bd" # gain "1")+ (stack [+ rotR 0 $ s "bd" # gain 1,+ rotR 0.2 $ s "bd" # gain 0.5,+ rotR 0.4 $ s "bd" # gain 0.25+ ]) describe "echoWith" $ do it "should echo the event by the specified time and apply the specified function" $ do- compareP (Arc 0 1)- (echoWith 2 0.25 (|* speed 2) $ s "bd" # speed "1")- (stack [rotR 0 "bd" # speed 1, rotR 0.25 "bd" # speed 2])+ comparePD (Arc 0 1)+ (echoWith 3 0.25 (|* speed 2) $ s "bd" # speed "1")+ (stack [+ rotR 0 $ s "bd" # speed 1,+ rotR 0.25 $ s "bd" # speed 2,+ rotR 0.5 $ s "bd" # speed 4+ ]) describe "stutWith" $ do it "can mimic stut" $ do
test/Sound/Tidal/ParseTest.hs view
@@ -160,6 +160,42 @@ compareP (Arc 0 2) ("c'major c'minor" :: Pattern Note) ("'major 'minor")+ it "can invert chords" $ do+ compareP (Arc 0 2)+ ("c'major'i" :: Pattern Note)+ ("[4,7,12]")+ it "can invert chords using a number" $ do+ compareP (Arc 0 2)+ ("c'major'i2" :: Pattern Note)+ ("[7,12,16]")+ it "spread chords over a range" $ do+ compareP (Arc 0 2)+ ("c'major'5 e'min7'5" :: Pattern Note)+ ("[0,4,7,12,16] [4,7,11,14,16]")+ it "can open chords" $ do+ compareP (Arc 0 2)+ ("c'major'o" :: Pattern Note)+ ("[-12,-5,4]")+ it "can drop notes in a chord" $ do+ compareP (Arc 0 2)+ ("c'major'd1" :: Pattern Note)+ ("[-5,0,4]")+ it "can apply multiple modifiers" $ do+ compareP (Arc 0 2)+ ("c'major'i'5" :: Pattern Note)+ ("[4,7,12,16,19]")+ it "can pattern modifiers" $ do+ compareP (Arc 0 2)+ ("c'major'<i 5>" :: Pattern Note)+ ("<[4,7,12] [0,4,7,12,16]>")+ it "can pattern chord names" $ do+ compareP (Arc 0 2)+ ("c'<major minor>'i" :: Pattern Note)+ ("<[4,7,12] [3,7,12]>")+ it "can pattern chord notes" $ do+ compareP (Arc 0 2)+ ("<c e>'<major minor>'i" :: Pattern Note)+ ("<[4,7,12] [7,11,16]>") it "handle trailing and leading whitespaces" $ do compareP (Arc 0 1) (" bd " :: Pattern String)
test/Sound/Tidal/PatternTest.hs view
@@ -428,17 +428,6 @@ let res = defragParts [(Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5), (Event (Context []) (Just $ Arc 7 8) (Arc 4 3) (5 :: Int))] property $ [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5, Event (Context []) (Just $ Arc 7 8) (Arc 4 3) (5 :: Int)] === res - describe "compareDefrag" $ do - it "compare list with Events with empty list of Events" $ do- let res = compareDefrag [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int), Event (Context []) (Just $ Arc 1 2) (Arc 4 3) (5 :: Int)] []- property $ False === res - it "compare lists containing same Events but of different length" $ do - let res = compareDefrag [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int), Event (Context []) (Just $ Arc 1 2) (Arc 4 3) 5] [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)]- property $ True === res- it "compare lists of same length with same Events" $ do - let res = compareDefrag [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)] [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)]- property $ True === res - describe "sect" $ do it "take two Arcs and return - Arc (max of two starts) (min of two ends)" $ do let res = sect (Arc 2.2 3) (Arc 2 2.9)
test/Sound/Tidal/UITest.hs view
@@ -306,7 +306,16 @@ (euclid 11 24 "x", "x ~ ~ x ~ x ~ x ~ x ~ x ~ ~ x ~ x ~ x ~ x ~ x ~"), (euclid 13 24 "x", "x ~ x x ~ x ~ x ~ x ~ x ~ x x ~ x ~ x ~ x ~ x ~") ] :: [(Pattern String, String)])+ it "can be called with a negative first value to give the inverse" $ do+ compareP (Arc 0 1)+ (euclid (-3) 8 ("bd" :: Pattern String))+ (euclidInv 3 8 ("bd" :: Pattern String))+ it "can be called with a negative first value to give the inverse (patternable)" $ do+ compareP (Arc 0 1)+ (euclid (-3) 8 ("bd" :: Pattern String))+ ("bd(-3,8)" :: Pattern String) + describe "wedge" $ do it "should not freeze tidal amount is 1" $ do compareP (Arc 0 1)@@ -360,6 +369,10 @@ compareP (Arc 0 4) (chunk 2 (fast 2) $ "a b" :: Pattern String) (slow 2 $ "a b b _ a _ a b" :: Pattern String)+ it "should chunk backward with a negative number" $ do+ compareP (Arc 0 4)+ (chunk (-2) (rev) $ ("a b c d" :: Pattern String))+ (slow 2 $ "a b b a d c c d" :: Pattern String) describe "binary" $ do it "converts a number to a pattern of boolean" $ do
test/TestUtils.hs view
@@ -36,13 +36,17 @@ -- | Compare the events of two patterns using the given arc compareP :: (Ord a, Show a) => Arc -> Pattern a -> Pattern a -> Property-compareP a p p' = (sort $ query (stripContext p) $ State a Map.empty) `shouldBe` (sort $ query (stripContext p') $ State a Map.empty)+compareP a p p' =+ (sort $ queryArc (stripContext p) a)+ `shouldBe`+ (sort $ queryArc (stripContext p') a) -- | Like @compareP@, but tries to 'defragment' the events-comparePD :: (Ord a) => Arc -> Pattern a -> Pattern a -> Bool-comparePD a p p' = compareDefrag es es'- where es = query (stripContext p) (State a Map.empty)- es' = query (stripContext p') (State a Map.empty)+comparePD :: (Ord a, Show a) => Arc -> Pattern a -> Pattern a -> Property+comparePD a p p' =+ (sort $ defragParts $ queryArc (stripContext p) a)+ `shouldBe`+ (sort $ defragParts $ queryArc (stripContext p') a) -- | Like @compareP@, but for control patterns, with some tolerance for floating point error compareTol :: Arc -> ControlPattern -> ControlPattern -> Bool
tidal.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.0 name: tidal-version: 1.8.1+version: 1.9.0 synopsis: Pattern language for improvised music description: Tidal is a domain specific language for live coding patterns. homepage: http://tidalcycles.org/@@ -28,13 +28,11 @@ autogen-modules: Paths_tidal Exposed-modules: Sound.Tidal.Bjorklund- Sound.Tidal.Carabiner Sound.Tidal.Chords Sound.Tidal.Config Sound.Tidal.Control Sound.Tidal.Context Sound.Tidal.Core- Sound.Tidal.EspGrid Sound.Tidal.ID Sound.Tidal.Params Sound.Tidal.ParseBP@@ -45,6 +43,7 @@ Sound.Tidal.Show Sound.Tidal.Simple Sound.Tidal.Stream+ Sound.Tidal.StreamTypes Sound.Tidal.Tempo Sound.Tidal.Time Sound.Tidal.Transition@@ -57,11 +56,10 @@ , containers < 0.7 , colour < 2.4 , hosc >= 0.17 && < 0.20- , text < 1.3+ , text < 2.1 , parsec >= 3.1.12 && < 3.2 , network < 3.2- , bifunctors < 5.6- , transformers >= 0.5 && < 0.5.7+ , transformers >= 0.5 && < 0.6.1 , bytestring < 0.12 , clock < 0.9 , deepseq >= 1.1.0.0@@ -69,6 +67,7 @@ , random < 1.3 , exceptions < 0.11 , mtl >= 2.2+ , tidal-link test-suite tests type: exitcode-stdio-1.0
tidal.el view
@@ -5,9 +5,9 @@ ;; Author: alex@slab.org ;; Homepage: https://github.com/tidalcycles/Tidal-;; Version: 0+;; Version: 0.0.1 ;; Keywords: tools-;; Package-Requires: ((haskell-mode "16") (emacs "24"))+;; Package-Requires: ((haskell-mode "16") (emacs "25.1")) ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by@@ -33,7 +33,6 @@ ;;; Code: - (require 'scheme) (require 'comint) (require 'thingatpt)@@ -63,22 +62,16 @@ (cond ((string-equal system-type "windows-nt") '(("path" . "echo off && for /f %a in ('ghc-pkg latest tidal') do (for /f \"tokens=2\" %i in ('ghc-pkg describe %a ^| findstr data-dir') do (echo %i))")- ("separator" . "\\")- ))+ ("separator" . "\\"))) ((or (string-equal system-type "darwin") (string-equal system-type "gnu/linux")) '(("path" . "echo -n data-dir: && ghc -e 'import Paths_tidal' -e 'getDataDir>>=putStr' 2>/dev/null")- ("separator" . "/")- ))- )- ))+ ("separator" . "/") ))))) (concat (string-trim (cadr (split-string (shell-command-to-string (cdr (assoc "path" filepath))) ":"))) (cdr (assoc "separator" filepath))- "BootTidal.hs")- )- "*Full path to BootTidal.hs (inferred by introspecting ghc-pkg package db)."-)+ "BootTidal.hs"))+ "*Full path to BootTidal.hs (inferred by introspecting ghc-pkg package db).") (defvar tidal-literate-p t@@ -90,7 +83,7 @@ (make-variable-buffer-local 'tidal-literate-p) (defun tidal-unlit (s)- "Remove bird literate marks in S."+ "Remove bird literate markup in S." (replace-regexp-in-string "^> " "" s)) (defun tidal-intersperse (e l)@@ -98,21 +91,30 @@ (when l (cons e (cons (car l) (tidal-intersperse e (cdr l)))))) +;;;###autoload (defun tidal-start-haskell () "Start haskell." (interactive)- (if (comint-check-proc tidal-buffer)- (error "A tidal process is already running")- (apply- 'make-comint- "tidal"- tidal-interpreter- nil- tidal-interpreter-arguments)- (tidal-see-output))- (tidal-send-string (concat ":script " tidal-boot-script-path))-)+ (save-window-excursion+ (if (comint-check-proc tidal-buffer)+ (when (yes-or-no-p+ "A tidal process is already running. Do you want to restart it? ")+ (tidal-restart-haskell))+ (apply+ 'make-comint-in-buffer+ "tidal"+ tidal-buffer+ tidal-interpreter+ nil+ tidal-interpreter-arguments)+ (tidal-see-output)+ (tidal-send-string (concat ":script " tidal-boot-script-path))))+ (switch-to-buffer-other-window tidal-buffer)) +;;;###autoload+(defalias 'run-tidal #'tidal-start-haskell+ "Start tidal in the haskell interpreter.")+ (defun tidal-see-output () "Show haskell output." (interactive)@@ -120,9 +122,9 @@ (delete-other-windows) (with-current-buffer tidal-buffer (let ((window (display-buffer (current-buffer))))- (goto-char (point-max))- (save-selected-window- (set-window-point window (point-max)))))))+ (goto-char (point-max))+ (save-selected-window+ (set-window-point window (point-max))))))) (defun tidal-quit-haskell () "Quit haskell."@@ -130,6 +132,13 @@ (kill-buffer tidal-buffer) (delete-other-windows)) +(defun tidal-restart-haskell ()+ "Restart haskell."+ (interactive)+ (let ((kill-buffer-query-functions nil))+ (tidal-quit-haskell))+ (tidal-start-haskell))+ (defun tidal-chunk-string (n s) "Split a string S into chunks of N characters." (let* ((l (length s))@@ -140,49 +149,47 @@ (cons c (tidal-chunk-string n (substring s n)))))) (defun tidal-send-string (s)+ "Send string S to tidal." (if (comint-check-proc tidal-buffer) (let ((cs (tidal-chunk-string 64 (concat s "\n")))) (mapcar (lambda (c) (comint-send-string tidal-buffer c)) cs))- (error "no tidal process running?")))+ (error "No tidal process running?"))) (defun tidal-transform-and-store (f s)- "Transform example text into compilable form."+ "Transform text into compilable form (Using file F and string S)." (with-temp-file f (mapc (lambda (module)- (insert (concat module "\n")))- tidal-modules)+ (insert (concat module "\n")))+ tidal-modules) (insert "main = do\n") (insert (if tidal-literate-p (tidal-unlit s) s)))) (defun tidal-get-now ()- "Store the current cycle position in a variable called 'now'."+ "Store the current cycle position in a tidal variable called `now'." (interactive) (tidal-send-string "now' <- getNow") (tidal-send-string "let now = nextSam now'") (tidal-send-string "let retrig = (now `rotR`)") (tidal-send-string "let fadeOut n = spread' (_degradeBy) (retrig $ slow n $ envL)")- (tidal-send-string "let fadeIn n = spread' (_degradeBy) (retrig $ slow n $ (1-) <$> envL)")-- )+ (tidal-send-string "let fadeIn n = spread' (_degradeBy) (retrig $ slow n $ (1-) <$> envL)")) (defun tidal-run-line () "Send the current line to the interpreter." (interactive)- ;(tidal-get-now)+ ;;(tidal-get-now) (let* ((s (buffer-substring (line-beginning-position)- (line-end-position)))- (s* (if tidal-literate-p- (tidal-unlit s)- s)))+ (line-end-position)))+ (s* (if tidal-literate-p+ (tidal-unlit s)+ s))) (tidal-send-string s*)) (pulse-momentary-highlight-one-line (point))- (forward-line)- )+ (forward-line)) (defun tidal-eval-multiple-lines () "Eval the current region in the interpreter as a single line."- ;(tidal-get-now)+ ;;(tidal-get-now) (mark-paragraph) (let* ((s (buffer-substring-no-properties (region-beginning) (region-end)))@@ -193,158 +200,49 @@ (tidal-send-string s*) (tidal-send-string ":}") (mark-paragraph)- (pulse-momentary-highlight-region (mark) (point))- )- )+ (pulse-momentary-highlight-region (mark) (point)))) (defun tidal-run-multiple-lines () "Send the current region to the interpreter as a single line." (interactive) (if (>= emacs-major-version 25) (save-mark-and-excursion- (tidal-eval-multiple-lines))+ (tidal-eval-multiple-lines)) (save-excursion- (tidal-eval-multiple-lines))- )- )--(defun tidal-run-d1 ()- "Send the first instance of d1 to the interpreter as a single line."- (interactive)- (goto-char 0)- (search-forward "d1" nil nil 1)- (tidal-run-multiple-lines)- )--(defun tidal-run-d2 ()- "Send the d2 to the interpreter as a single line."- (interactive)- (goto-char 0)- (search-forward "d2" nil nil 1)- (tidal-run-multiple-lines)- )--(defun tidal-run-d3 ()- "Send the d3 to the interpreter as a single line."- (interactive)- (goto-char 0)- (search-forward "d3" nil nil 1)- (tidal-run-multiple-lines)- )--(defun tidal-run-d4 ()- "Send the d4 to the interpreter as a single line."- (interactive)- (goto-char 0)- (search-forward "d4" nil nil 1)- (tidal-run-multiple-lines)- )-(defun tidal-run-d5 ()- "Send the d5 to the interpreter as a single line."- (interactive)- (goto-char 0)- (search-forward "d5" nil nil 1)- (tidal-run-multiple-lines)- )-(defun tidal-run-d6 ()- "Send the d6 to the interpreter as a single line."- (interactive)- (goto-char 0)- (search-forward "d6" nil nil 1)- (tidal-run-multiple-lines)- )-(defun tidal-run-d7 ()- "Send the d7 to the interpreter as a single line."- (interactive)- (goto-char 0)- (search-forward "d7" nil nil 1)- (tidal-run-multiple-lines)- )-(defun tidal-run-d8 ()- "Send the d9 to the interpreter as a single line."- (interactive)- (goto-char 0)- (search-forward "d8" nil nil 1)- (tidal-run-multiple-lines)- )-(defun tidal-run-d9 ()- "Send the d9 to the interpreter as a single line."- (interactive)- (goto-char 0)- (search-forward "d9" nil nil 1)- (tidal-run-multiple-lines)- )---(defun tidal-stop-d1 ()- "send d1 $ silence as a single line"- (interactive)- (tidal-send-string ":{")- (tidal-send-string " mapM_ ($ silence) [d1]")- (tidal-send-string ":}")- )--(defun tidal-stop-d2 ()- "send d1 $ silence as a single line"- (interactive)- (tidal-send-string ":{")- (tidal-send-string " mapM_ ($ silence) [d2]")- (tidal-send-string ":}")- )-(defun tidal-stop-d3 ()- "send d1 $ silence as a single line"- (interactive)- (tidal-send-string ":{")- (tidal-send-string " mapM_ ($ silence) [d3]")- (tidal-send-string ":}")- )+ (tidal-eval-multiple-lines)))) +(defmacro tidal-create-runner-run (name)+ "Macro to generate `d1' style pattern runners with NAME."+ (let ((run-fname (intern (concat "tidal-run-" name))))+ `(defun ,run-fname ()+ ,(format "Send the %s interpreter as a single line." name)+ (interactive)+ (goto-char 0)+ (search-forward ,name nil nil 1)+ (tidal-run-multiple-lines)))) -(defun tidal-stop-d4 ()- "send d1 $ silence as a single line"- (interactive)- (tidal-send-string ":{")- (tidal-send-string " mapM_ ($ silence) [d4]")- (tidal-send-string ":}")- )+(defmacro tidal-create-runner-stop (name)+ "Macro to generate `d1' style pattern runners with NAME."+ (let ((stop-fname (intern (concat "tidal-stop-" name))))+ `(defun ,stop-fname ()+ ,(format "Send %s $ silence as a single line." name)+ (interactive)+ (tidal-send-string ":{")+ (tidal-send-string " mapM_ ($ silence) [,name]")+ (tidal-send-string ":}")))) -(defun tidal-stop-d5 ()- "send d1 $ silence as a single line"- (interactive)- (tidal-send-string ":{")- (tidal-send-string " mapM_ ($ silence) [d5]")- (tidal-send-string ":}")- )-(defun tidal-stop-d6 ()- "send d1 $ silence as a single line"- (interactive)- (tidal-send-string ":{")- (tidal-send-string " mapM_ ($ silence) [d6]")- (tidal-send-string ":}")- )+(defun tidal-create-runner (name)+ "Generate `d1' style pattern runners with NAME.+Two functions will be created, `tidal-run-NAME' and `tidal-stop-NAME'"+ (eval `(tidal-create-runner-run ,name))+ (eval `(tidal-create-runner-stop ,name))) -(defun tidal-stop-d7 ()- "send d1 $ silence as a single line"- (interactive)- (tidal-send-string ":{")- (tidal-send-string " mapM_ ($ silence) [d7]")- (tidal-send-string ":}")- )+;; Generate the functions `tidal-run-d1' and `tidal-stop-d1'+(tidal-create-runner "d1") -(defun tidal-stop-d8 ()- "send d1 $ silence as a single line"- (interactive)- (tidal-send-string ":{")- (tidal-send-string " mapM_ ($ silence) [d8]")- (tidal-send-string ":}")- )-(defun tidal-stop-d9 ()- "send d1 $ silence as a single line"- (interactive)- (tidal-send-string ":{")- (tidal-send-string " mapM_ ($ silence) [d9]")- (tidal-send-string ":}")- )+;; This generates tidal-run-* and tidal-stop-* functions for d1 to d9.+(mapc #'tidal-create-runner+ '("d1" "d2" "d3" "d4" "d5" "d6" "d7" "d8" "d9")) (defun tidal-run-region () "Place the region in a do block and compile."@@ -367,17 +265,18 @@ (tidal-send-string "main")) (defun tidal-interrupt-haskell ()+ "Interrupt running process." (interactive) (if (comint-check-proc tidal-buffer) (with-current-buffer tidal-buffer- (interrupt-process (get-buffer-process (current-buffer))))- (error "no tidal process running?")))+ (interrupt-process (get-buffer-process (current-buffer))))+ (error "No tidal process running?"))) (defvar tidal-mode-map nil "Tidal keymap.") (defun tidal-mode-keybindings (map)- "Haskell Tidal keybindings."+ "Haskell Tidal keybindings MAP." (define-key map [?\C-c ?\C-s] 'tidal-start-haskell) (define-key map [?\C-c ?\C-v] 'tidal-see-output) (define-key map [?\C-c ?\C-q] 'tidal-quit-haskell)@@ -407,7 +306,7 @@ (define-key map [?\C-v ?\C-8] 'tidal-stop-d8) (define-key map [?\C-v ?\C-9] 'tidal-stop-d9)) -(defun turn-on-tidal-keybindings ()+(defun tidal-turn-on-keybindings () "Haskell Tidal keybindings in the local map." (local-set-key [?\C-c ?\C-s] 'tidal-start-haskell) (local-set-key [?\C-c ?\C-v] 'tidal-see-output)@@ -439,31 +338,31 @@ (local-set-key [?\C-v ?\C-9] 'tidal-stop-d9)) (defun tidal-mode-menu (map)- "Haskell Tidal menu."+ "Haskell Tidal menu MAP." (define-key map [menu-bar tidal]- (cons "Haskell-Tidal" (make-sparse-keymap "Haskell-Tidal")))+ (cons "Haskell-Tidal" (make-sparse-keymap "Haskell-Tidal"))) (define-key map [menu-bar tidal help]- (cons "Help" (make-sparse-keymap "Help")))+ (cons "Help" (make-sparse-keymap "Help"))) (define-key map [menu-bar tidal expression]- (cons "Expression" (make-sparse-keymap "Expression")))+ (cons "Expression" (make-sparse-keymap "Expression"))) (define-key map [menu-bar tidal expression load-buffer]- '("Load buffer" . tidal-load-buffer))+ '("Load buffer" . tidal-load-buffer)) (define-key map [menu-bar tidal expression run-main]- '("Run main" . tidal-run-main))+ '("Run main" . tidal-run-main)) (define-key map [menu-bar tidal expression run-region]- '("Run region" . tidal-run-region))+ '("Run region" . tidal-run-region)) (define-key map [menu-bar tidal expression run-multiple-lines]- '("Run multiple lines" . tidal-run-multiple-lines))+ '("Run multiple lines" . tidal-run-multiple-lines)) (define-key map [menu-bar tidal expression run-line]- '("Run line" . tidal-run-line))+ '("Run line" . tidal-run-line)) (define-key map [menu-bar tidal haskell]- (cons "Haskell" (make-sparse-keymap "Haskell")))+ (cons "Haskell" (make-sparse-keymap "Haskell"))) (define-key map [menu-bar tidal haskell quit-haskell]- '("Quit haskell" . tidal-quit-haskell))+ '("Quit haskell" . tidal-quit-haskell)) (define-key map [menu-bar tidal haskell see-output]- '("See output" . tidal-see-output))+ '("See output" . tidal-see-output)) (define-key map [menu-bar tidal haskell start-haskell]- '("Start haskell" . tidal-start-haskell)))+ '("Start haskell" . tidal-start-haskell))) (unless tidal-mode-map (let ((map (make-sparse-keymap "Haskell-Tidal")))@@ -484,9 +383,7 @@ (turn-on-font-lock)) ;;;###autoload-(add-to-list 'auto-mode-alist '("\\.ltidal$" . literate-tidal-mode))-;;(add-to-list 'load-path "/usr/share/emacs/site-lisp/haskell-mode/") ;required by olig1905 on linux-;;(require 'haskell-mode) ;required by olig1905 on linux+(add-to-list 'auto-mode-alist '("\\.ltidal\\'" . literate-tidal-mode)) ;;;###autoload (define-derived-mode@@ -500,7 +397,7 @@ (turn-on-font-lock)) ;;;###autoload-(add-to-list 'auto-mode-alist '("\\.tidal$" . tidal-mode))+(add-to-list 'auto-mode-alist '("\\.tidal\\'" . tidal-mode)) (provide 'tidal) ;;; tidal.el ends here