diff --git a/src/Sound/Tidal/Core.hs b/src/Sound/Tidal/Core.hs --- a/src/Sound/Tidal/Core.hs +++ b/src/Sound/Tidal/Core.hs @@ -124,6 +124,13 @@ ( %|) :: Real a => Pattern a -> Pattern a -> Pattern a a %| b = mod' <$> a *> b +(|**|) :: (Applicative a, Real b) => a b -> a b -> a b +a |**| b = mod' <$> a <*> b +(|** ) :: Real a => Pattern a -> Pattern a -> Pattern a +a |** b = mod' <$> a <* b +( **|) :: Real a => Pattern a -> Pattern a -> Pattern a +a **| b = mod' <$> a *> b + (|>|) :: (Applicative a, Unionable b) => a b -> a b -> a b a |>| b = flip union <$> a <*> b (|> ) :: Unionable a => Pattern a -> Pattern a -> Pattern a diff --git a/src/Sound/Tidal/Params.hs b/src/Sound/Tidal/Params.hs --- a/src/Sound/Tidal/Params.hs +++ b/src/Sound/Tidal/Params.hs @@ -5,6 +5,7 @@ import Sound.Tidal.Pattern import Sound.Tidal.Utils import Data.Maybe (fromMaybe) +import Data.Word (Word8) -- | group multiple params into one grp :: [String -> ControlMap] -> Pattern String -> ControlPattern @@ -47,6 +48,9 @@ pS :: String -> Pattern String -> ControlPattern pS name = fmap (Map.singleton name . VS) +pX :: String -> Pattern [Word8] -> ControlPattern +pX name = fmap (Map.singleton name . VX) + -- | patterns for internal sound routing toArg :: Pattern String -> ControlPattern toArg = pS "toArg" @@ -543,8 +547,8 @@ -- SuperDirt MIDI Params -array :: Pattern Double -> ControlPattern -array = pF "array" +array :: Pattern [Word8] -> ControlPattern +array = pX "array" midichan :: Pattern Double -> ControlPattern midichan = pF "midichan" control :: Pattern Double -> ControlPattern diff --git a/src/Sound/Tidal/ParseBP.hs b/src/Sound/Tidal/ParseBP.hs --- a/src/Sound/Tidal/ParseBP.hs +++ b/src/Sound/Tidal/ParseBP.hs @@ -52,6 +52,7 @@ | TPat_TimeCat [TPat a] | TPat_Overlay (TPat a) (TPat a) | TPat_Stack [TPat a] + | TPat_CycleChoose [TPat a] | TPat_ShiftL Time (TPat a) -- TPat_E Int Int (TPat a) | TPat_pE (TPat Int) (TPat Int) (TPat Int) (TPat a) @@ -69,6 +70,7 @@ TPat_TimeCat xs -> timeCat $ map (\(n, pat) -> (toRational n, toPat pat)) $ durations xs TPat_Overlay x0 x1 -> overlay (toPat x0) (toPat x1) TPat_Stack xs -> stack $ map toPat xs + TPat_CycleChoose xs -> unwrap $ cycleChoose $ map toPat xs TPat_ShiftL t x -> t `rotL` toPat x TPat_pE n k s thing -> doEuclid (toPat n) (toPat k) (toPat s) (toPat thing) @@ -297,9 +299,17 @@ return pts pPolyIn :: Parseable a => Parser (TPat a) -> Parser (TPat a) -pPolyIn f = do ps <- brackets (pSequence f `sepBy` symbol ",") - spaces - pMult $ TPat_Stack ps +pPolyIn f = do x <- brackets $ do p <- pSequence f "sequence" + stackTail p <|> chooseTail p <|> return p + pMult x + where stackTail p = do symbol "," + ps <- pSequence f `sepBy` symbol "," + spaces + return $ TPat_Stack (p:ps) + chooseTail p = do symbol "|" + ps <- pSequence f `sepBy` symbol "|" + spaces + return $ TPat_CycleChoose (p:ps) pPolyOut :: Parseable a => Parser (TPat a) -> Parser (TPat a) pPolyOut f = do ps <- braces (pSequenceN f `sepBy` symbol ",") diff --git a/src/Sound/Tidal/Pattern.hs b/src/Sound/Tidal/Pattern.hs --- a/src/Sound/Tidal/Pattern.hs +++ b/src/Sound/Tidal/Pattern.hs @@ -15,7 +15,7 @@ import Data.Ratio (numerator, denominator) import Data.Typeable (Typeable) import Control.DeepSeq (NFData(rnf)) - +import Data.Word (Word8) ------------------------------------------------------------------------ -- * Types @@ -251,6 +251,7 @@ | VR { rvalue :: Rational } | VI { ivalue :: Int } | VB { bvalue :: Bool } + | VX { xvalue :: [Word8] } -- Used for OSC 'blobs' deriving (Typeable,Data) class Valuable a where @@ -262,6 +263,7 @@ rnf (VR r) = rnf r rnf (VI i) = rnf i rnf (VB b) = rnf b + rnf (VX xs) = rnf xs instance Valuable String where toValue = VS @@ -273,14 +275,16 @@ toValue a = VI a instance Valuable Bool where toValue a = VB a +instance Valuable [Word8] where + toValue a = VX a instance Eq Value where (VS x) == (VS y) = x == y (VB x) == (VB y) = x == y - (VF x) == (VF y) = x == y (VI x) == (VI y) = x == y (VR x) == (VR y) = x == y + (VX x) == (VX y) = x == y (VF x) == (VI y) = x == (fromIntegral y) (VI y) == (VF x) = x == (fromIntegral y) @@ -290,7 +294,6 @@ (VI x) == (VR y) = (toRational x) == y (VR y) == (VI x) = (toRational x) == y - _ == _ = False instance Ord Value where @@ -299,10 +302,13 @@ compare (VF x) (VF y) = compare x y compare (VI x) (VI y) = compare x y compare (VR x) (VR y) = compare x y + compare (VX x) (VX y) = compare x y compare (VS _) _ = LT compare _ (VS _) = GT compare (VB _) _ = LT compare _ (VB _) = GT + compare (VX _) _ = LT + compare _ (VX _) = GT compare (VF x) (VI y) = compare x (fromIntegral y) compare (VI x) (VF y) = compare (fromIntegral x) y @@ -589,6 +595,7 @@ show (VF f) = show f ++ "f" show (VR r) = show r ++ "r" show (VB b) = show b + show (VX xs) = show xs instance {-# OVERLAPPING #-} Show ControlMap where show m = intercalate ", " $ map (\(name, v) -> name ++ ": " ++ show v) $ Map.toList m @@ -737,6 +744,10 @@ getR (VF x) = Just $ toRational x getR (VI x) = Just $ toRational x getR _ = Nothing + +getBlob :: Value -> Maybe [Word8] +getBlob (VX xs) = Just xs +getBlob _ = Nothing compressArc :: Arc -> Pattern a -> Pattern a compressArc (Arc s e) p | s > e = empty diff --git a/src/Sound/Tidal/Stream.hs b/src/Sound/Tidal/Stream.hs --- a/src/Sound/Tidal/Stream.hs +++ b/src/Sound/Tidal/Stream.hs @@ -24,6 +24,8 @@ import qualified Sound.Tidal.Tempo as T -- import qualified Sound.OSC.Datum as O import Data.List (sortOn) +import System.Random (getStdRandom, randomR) +import Data.Word (Word8) data TimeStamp = BundleStamp | MessageStamp | NoStamp deriving (Eq, Show) @@ -140,35 +142,50 @@ toDatum (VR x) = O.float $ ((fromRational x) :: Double) toDatum (VB True) = O.int32 (1 :: Int) toDatum (VB False) = O.int32 (0 :: Int) +toDatum (VX xs) = O.Blob $ O.blob_pack xs toData :: OSCTarget -> Event ControlMap -> Maybe [O.Datum] toData target e | isJust (oShape target) = fmap (fmap toDatum) $ sequence $ map (\(n,v) -> Map.lookup n (value e) <|> v) (fromJust $ oShape target) | otherwise = Just $ concatMap (\(n,v) -> [O.string n, toDatum v]) $ Map.toList $ value e +substitutePath :: String -> ControlMap -> String +substitutePath path cm = parse path + where parse [] = [] + parse ('{':xs) = parseWord xs + parse (x:xs) = x:(parse xs) + parseWord xs | b == [] = getString cm a + | otherwise = getString cm a ++ parse (tail b) + where (a,b) = break (== '}') xs + +getString :: ControlMap -> String -> String +getString cm s = fromMaybe "" $ do v <- Map.lookup s cm + return $ simpleShow v + where simpleShow :: Value -> String + simpleShow (VS str) = str + simpleShow (VI i) = show i + simpleShow (VF f) = show f + simpleShow (VR r) = show r + simpleShow (VB b) = show b + simpleShow (VX xs) = show xs + toMessage :: Config -> Double -> OSCTarget -> T.Tempo -> Event (Map.Map String Value) -> Maybe O.Message toMessage config t target tempo e = do vs <- toData target addExtra - return $ O.Message (oPath target) $ oPreamble target ++ vs + return $ O.Message (substitutePath (oPath target) (value e)) $ oPreamble target ++ vs where on = sched tempo $ start $ wholeOrPart e off = sched tempo $ stop $ wholeOrPart e + cm = value e identifier = ((if (start $ wholeOrPart e) == (start $ part e) then "X" else ">") ++ show (start $ wholeOrPart e) ++ "-" ++ show (stop $ wholeOrPart e) ++ "-" - ++ getString "n" + ++ getString cm "n" ++ "-" - ++ getString "note" + ++ getString cm "note" ++ "-" - ++ getString "s" + ++ getString cm "s" ) - getString s = fromMaybe "" $ do v <- Map.lookup s $ value e - return $ simpleShow v - simpleShow (VS s) = s - simpleShow (VI i) = show i - simpleShow (VF f) = show f - simpleShow (VR r) = show r - simpleShow (VB b) = show b delta = off - on messageStamp = oTimestamp target == MessageStamp -- If there is already cps in the event, the union will preserve that. @@ -201,22 +218,23 @@ do p <- readMVar pMV sMap <- readMVar sMapMV tempo <- takeMVar tempoMV - now <- O.time let frameEnd = snd $ T.nowTimespan st sMap' = Map.insert "_cps" (pure $ VF $ T.cps tempo) sMap es = sortOn (start . part) $ filterOns $ query p (State {arc = T.nowArc st, controls = sMap'}) filterOns | cSendParts config = id | otherwise = filter eventHasOnset -- there should always be a whole (due to the eventHasOnset filter) - on e tempo' = (sched tempo' $ start $ wholeOrPart e) + on e tempo'' = (sched tempo'' $ start $ wholeOrPart e) eventNudge e = fromJust $ getF $ fromMaybe (VF 0) $ Map.lookup "nudge" $ value e processCps :: T.Tempo -> [Event ControlMap] -> ([(T.Tempo, Event ControlMap)], T.Tempo) - processCps tempo [] = ([], tempo) - processCps tempo (e:es) = (((tempo', e):es'), 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' = do x <- Map.lookup "cps" $ value e getF x - tempo' = (maybe tempo (\newCps -> T.changeTempo' tempo newCps (eventPartStart e)) cps') - (es', tempo'') = processCps tempo' es + t' = (maybe t (\newCps -> T.changeTempo' t newCps (eventPartStart e)) cps') + (es', t'') = processCps t' evs latency target = oLatency target + cFrameTimespan config + T.nudged tempo (tes, tempo') = processCps tempo es mapM_ (\(Cx target udp) -> (do let ms = catMaybes $ map (\(t, e) -> do let nudge = eventNudge e @@ -311,7 +329,11 @@ streamUnsolo s k = withPatId s (show k) (\x -> x {solo = False}) streamOnce :: Stream -> ControlPattern -> IO () -streamOnce st p +streamOnce st p = do i <- getStdRandom $ randomR (0, 8192) + streamFirst st $ rotL (toRational (i :: Int)) p + +streamFirst :: Stream -> ControlPattern -> IO () +streamFirst st p = do sMap <- readMVar (sInput st) tempo <- readMVar (sTempoMV st) now <- O.time diff --git a/src/Sound/Tidal/Tempo.hs b/src/Sound/Tidal/Tempo.hs --- a/src/Sound/Tidal/Tempo.hs +++ b/src/Sound/Tidal/Tempo.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns -fno-warn-orphans #-} {-# LANGUAGE RecordWildCards #-} module Sound.Tidal.Tempo where @@ -12,13 +12,13 @@ import qualified Network.Socket as N import Control.Concurrent (forkIO, ThreadId, threadDelay) import Control.Monad (forever, when, foldM) -import Data.List (isPrefixOf, nub, intercalate) +import Data.List (isPrefixOf, nub) import qualified Control.Exception as E import Sound.Tidal.Config instance Show O.UDP where - show x = "-unshowable-" + show _ = "-unshowable-" data Tempo = Tempo {atTime :: O.Time, atCycle :: Rational, diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs --- a/src/Sound/Tidal/UI.hs +++ b/src/Sound/Tidal/UI.hs @@ -902,6 +902,9 @@ randcat :: [Pattern a] -> Pattern a 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 + -- @fromNote p@: converts a pattern of human-readable pitch names -- into pitch numbers. For example, @"cs2"@ will be parsed as C Sharp -- in the 2nd octave with the result of @11@, and @"b-3"@ as @@ -1420,9 +1423,9 @@ plyWith np f p = innerJoin $ (\n -> _plyWith n f p) <$> np _plyWith :: (Ord t, Num t) => t -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -_plyWith numPat f p = arpeggiate $ compound numPat f p - where compound n f p | n <= 1 = p - | otherwise = overlay p (f (compound (n-1) f p)) +_plyWith numPat f p = arpeggiate $ compound numPat + where compound n | n <= 1 = p + | otherwise = overlay p (f $ compound $ n-1) -- Uses the first (binary) pattern to switch between the following two -- patterns. diff --git a/src/Sound/Tidal/Version.hs b/src/Sound/Tidal/Version.hs --- a/src/Sound/Tidal/Version.hs +++ b/src/Sound/Tidal/Version.hs @@ -1,4 +1,4 @@ module Sound.Tidal.Version where tidal_version :: String -tidal_version = "1.4.3" +tidal_version = "1.4.4" diff --git a/tidal.cabal b/tidal.cabal --- a/tidal.cabal +++ b/tidal.cabal @@ -1,5 +1,5 @@ name: tidal -version: 1.4.3 +version: 1.4.4 synopsis: Pattern language for improvised music -- description: homepage: http://tidalcycles.org/ @@ -45,6 +45,7 @@ Sound.Tidal.Utils Sound.Tidal.Version Sound.Tidal.EspGrid + -- Sound.Tidal.Light -- Sound.Tidal.TH Build-depends: base >=4.8 && <5 @@ -62,6 +63,9 @@ , clock < 0.9 , deepseq >= 1.1.0.0 , primitive < 0.8 + , random < 1.2 + -- , serialport + -- , hashable if !impl(ghc >= 8.4.1) build-depends: semigroups >= 0.18 && < 0.20 diff --git a/tidal.el b/tidal.el --- a/tidal.el +++ b/tidal.el @@ -58,12 +58,22 @@ "*Arguments to the haskell interpreter (default=none).") (defvar tidal-boot-script-path - (concat (substring - (shell-command-to-string - "ghc-pkg describe $(ghc-pkg latest tidal) | grep data-dir | cut -f2 -d' '") 0 -1) - "/BootTidal.hs") - "*Full path to BootTidal.hs (inferred by introspecting ghc-pkg package db)." + (let ((filepath + (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" . "\\") + )) + ((or (string-equal system-type "darwin") (string-equal system-type "gnu/linux")) + '(("path" . "ghc-pkg describe $(ghc-pkg latest tidal) | grep data-dir | cut -f2 -d' '") + ("separator" . "/") + )) + ) + )) + (concat (substring (shell-command-to-string (cdr (assoc "path" filepath))) 0 -1) (cdr (assoc "separator" filepath)) "BootTidal.hs") ) + "*Full path to BootTidal.hs (inferred by introspecting ghc-pkg package db)." +) (defvar tidal-literate-p t