From cca648505eddf8d03bbaad457455d705f5e28ae5 Mon Sep 17 00:00:00 2001 From: alex Date: Tue, 9 Apr 2024 12:27:13 +0100 Subject: [PATCH 01/46] add tactus field to Pattern --- src/Sound/Tidal/Core.hs | 22 ++-- src/Sound/Tidal/Pattern.hs | 165 ++++++++++++------------ src/Sound/Tidal/Stream.hs | 200 +++++++++++++++-------------- src/Sound/Tidal/StreamTypes.hs | 14 +- src/Sound/Tidal/Tempo.hs | 75 +++++------ src/Sound/Tidal/UI.hs | 78 +++++------ test/Sound/Tidal/ExceptionsTest.hs | 19 +-- 7 files changed, 295 insertions(+), 278 deletions(-) diff --git a/src/Sound/Tidal/Core.hs b/src/Sound/Tidal/Core.hs index d4b4c8017..69633be44 100644 --- a/src/Sound/Tidal/Core.hs +++ b/src/Sound/Tidal/Core.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances, BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} {- Core.hs - For functions judged to be 'core' to tidal functionality. @@ -20,11 +20,11 @@ module Sound.Tidal.Core where -import Prelude hiding ((<*), (*>)) +import Prelude hiding ((*>), (<*)) -import Data.Fixed (mod') -import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe) +import Data.Fixed (mod') +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) import Sound.Tidal.Pattern -- ** Elemental patterns @@ -37,7 +37,7 @@ import Sound.Tidal.Pattern > saw = sig $ \t -> mod' (fromRational t) 1 -} sig :: (Time -> a) -> Pattern a -sig f = Pattern q +sig f = pattern q where q (State (Arc s e) _) | s > e = [] | otherwise = [Event (Context []) Nothing (Arc s e) (f (s+((e-s)/2)))] @@ -266,7 +266,7 @@ listToPat = fastFromList -- > d1 $ n "0 ~ 2" # s "superpiano" fromMaybes :: [Maybe a] -> Pattern a fromMaybes = fastcat . map f - where f Nothing = silence + where f Nothing = silence f (Just x) = pure x {-| A pattern of whole numbers from 0 to the given number, in a single cycle. @@ -312,7 +312,7 @@ append a b = cat [a,b] -} cat :: [Pattern a] -> Pattern a cat [] = silence -cat ps = Pattern q +cat ps = pattern q where n = length ps q st = concatMap (f st) $ arcCyclesZW (arc st) f st a = query (withResultTime (+offset) p) $ st {arc = Arc (subtract offset (start a)) (subtract offset (stop a))} @@ -374,7 +374,7 @@ timeCat :: [(Time, Pattern a)] -> Pattern a timeCat tps = stack $ map (\(s,e,p) -> compressArc (Arc (s/total) (e/total)) p) $ arrange 0 tps where total = sum $ map fst tps arrange :: Time -> [(Time, Pattern a)] -> [(Time, Time, Pattern a)] - arrange _ [] = [] + arrange _ [] = [] arrange t ((t',p):tps') = (t,t+t',p) : arrange (t+t') tps' -- | Alias for @timeCat@ @@ -634,10 +634,10 @@ _getP :: a -> (Value -> Maybe a) -> Pattern Value -> Pattern a _getP d f pat = fromMaybe d . f <$> pat _cX :: a -> (Value -> Maybe a) -> String -> Pattern a -_cX d f s = Pattern $ \(State a m) -> queryArc (maybe (pure d) (_getP d f . valueToPattern) $ Map.lookup s m) a +_cX d f s = pattern $ \(State a m) -> queryArc (maybe (pure d) (_getP d f . valueToPattern) $ Map.lookup s m) a _cX_ :: (Value -> Maybe a) -> String -> Pattern a -_cX_ f s = Pattern $ \(State a m) -> queryArc (maybe silence (_getP_ f . valueToPattern) $ Map.lookup s m) a +_cX_ f s = pattern $ \(State a m) -> queryArc (maybe silence (_getP_ f . valueToPattern) $ Map.lookup s m) a cF :: Double -> String -> Pattern Double cF d = _cX d getF diff --git a/src/Sound/Tidal/Pattern.hs b/src/Sound/Tidal/Pattern.hs index 8fc13c4fc..6809e5252 100644 --- a/src/Sound/Tidal/Pattern.hs +++ b/src/Sound/Tidal/Pattern.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -29,19 +29,19 @@ module Sound.Tidal.Pattern (module Sound.Tidal.Pattern, ) where -import Prelude hiding ((<*), (*>)) +import Prelude hiding ((*>), (<*)) import Control.Applicative (liftA2) +import Control.DeepSeq (NFData) +import Control.Monad ((>=>)) +import Data.Data (Data) +import Data.Fixed (mod') +import Data.List (delete, findIndex, (\\)) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes, fromJust, isJust, mapMaybe) +import Data.Typeable (Typeable) +import Data.Word (Word8) import GHC.Generics -import Control.DeepSeq (NFData) -import Control.Monad ((>=>)) -import qualified Data.Map.Strict as Map -import Data.Maybe (isJust, fromJust, catMaybes, mapMaybe) -import Data.List (delete, findIndex, (\\)) -import Data.Word (Word8) -import Data.Data (Data) -- toConstr -import Data.Typeable (Typeable) -import Data.Fixed (mod') import Sound.Tidal.Time @@ -49,16 +49,19 @@ import Sound.Tidal.Time -- * Types -- | an Arc and some named control values -data State = State {arc :: Arc, +data State = State {arc :: Arc, controls :: ValueMap } -- | A datatype representing events taking place over time -data Pattern a = Pattern {query :: State -> [Event a]} +data Pattern a = Pattern {query :: State -> [Event a], tactus :: Maybe Rational} deriving (Generic, Functor) instance NFData a => NFData (Pattern a) +pattern :: (State -> [Event a]) -> Pattern a +pattern f = Pattern f Nothing + -- type StateMap = Map.Map String (Pattern Value) type ControlPattern = Pattern ValueMap @@ -66,7 +69,7 @@ type ControlPattern = Pattern ValueMap instance Applicative Pattern where -- | Repeat the given value once per cycle, forever - pure v = Pattern $ \(State a _) -> + pure v = pattern $ \(State a _) -> map (\a' -> Event (Context []) (Just a') @@ -113,7 +116,7 @@ instance Applicative Pattern where infixl 4 <*, *>, <<* applyPatToPat :: (Maybe Arc -> Maybe Arc -> Maybe (Maybe Arc)) -> Pattern (a -> b) -> Pattern a -> Pattern b -applyPatToPat combineWholes pf px = Pattern q +applyPatToPat combineWholes pf px = pattern q where q st = catMaybes $ concatMap match $ query pf st where match ef@(Event (Context c) _ fPart f) = @@ -126,7 +129,7 @@ applyPatToPat combineWholes pf px = Pattern q (query px $ st {arc = wholeOrPart ef}) applyPatToPatBoth :: Pattern (a -> b) -> Pattern a -> Pattern b -applyPatToPatBoth pf px = Pattern q +applyPatToPatBoth pf px = pattern q where q st = catMaybes $ (concatMap match $ query pf st) ++ (concatMap matchX $ query (filterAnalog px) st) where -- match analog events from pf with all events from px @@ -141,7 +144,7 @@ applyPatToPatBoth pf px = Pattern q return (Event (combineContexts [context ef, context ex]) whole' part' (value ef $ value ex)) applyPatToPatLeft :: Pattern (a -> b) -> Pattern a -> Pattern b -applyPatToPatLeft pf px = Pattern q +applyPatToPatLeft pf px = pattern q where q st = catMaybes $ concatMap match $ query pf st where match ef = map (withFX ef) (query px $ st {arc = wholeOrPart ef}) @@ -150,7 +153,7 @@ applyPatToPatLeft pf px = Pattern q return (Event (combineContexts [context ef, context ex]) whole' part' (value ef $ value ex)) applyPatToPatRight :: Pattern (a -> b) -> Pattern a -> Pattern b -applyPatToPatRight pf px = Pattern q +applyPatToPatRight pf px = pattern q where q st = catMaybes $ concatMap match $ query px st where match ex = map (`withFX` ex) (query pf $ st {arc = wholeOrPart ex}) @@ -239,7 +242,7 @@ squeezeJoin pp = pp {query = q} _trigJoin :: Bool -> Pattern (Pattern a) -> Pattern a -_trigJoin cycleZero pat_of_pats = Pattern q +_trigJoin cycleZero pat_of_pats = pattern q where q st = catMaybes $ concatMap @@ -307,7 +310,7 @@ instance Monoid (Pattern a) where mempty = empty instance Semigroup (Pattern a) where - (<>) !p !p' = Pattern $ \st -> query p st ++ query p' st + (<>) !p !p' = pattern $ \st -> query p st ++ query p' st instance (Num a, Ord a) => Real (Pattern a) where toRational = noOv "toRational" @@ -490,7 +493,7 @@ extractR :: String -> ControlPattern -> Pattern Rational extractR = _extract getR -- | Extract a pattern of note values by from a control pattern, given the name of the control -extractN :: String -> ControlPattern -> Pattern Note +extractN :: String -> ControlPattern -> Pattern Note extractN = _extract getN compressArc :: Arc -> Pattern a -> Pattern a @@ -702,7 +705,7 @@ filterAnalog :: Pattern a -> Pattern a filterAnalog = filterEvents isAnalog playFor :: Time -> Time -> Pattern a -> Pattern a -playFor s e pat = Pattern $ \st -> maybe [] (\a -> query pat (st {arc = a})) $ subArc (Arc s e) (arc st) +playFor s e pat = pattern $ \st -> maybe [] (\a -> query pat (st {arc = a})) $ subArc (Arc s e) (arc st) -- ** Temporal parameter helpers @@ -745,10 +748,10 @@ deltaMini = outside 0 0 outside _ line ('\n':xs) = '\n':outside 0 (line+1) xs outside column line (x:xs) = x:outside (column+1) line xs inside :: Int -> Int -> String -> String - inside _ _ [] = [] + inside _ _ [] = [] inside column line ('"':xs) = '"':')':outside (column+1) line xs - inside _ line ('\n':xs) = '\n':inside 0 (line+1) xs - inside column line (x:xs) = x:inside (column+1) line xs + inside _ line ('\n':xs) = '\n':inside 0 (line+1) xs + inside column line (x:xs) = x:inside (column+1) line xs class Stringy a where deltaContext :: Int -> Int -> a -> a @@ -773,9 +776,9 @@ instance NFData Context -- is present, the part should be equal to or fit inside it. data EventF a b = Event { context :: Context - , whole :: Maybe a - , part :: a - , value :: b + , whole :: Maybe a + , part :: a + , value :: b } deriving (Eq, Ord, Functor, Generic) instance (NFData a, NFData b) => NFData (EventF a b) @@ -785,7 +788,7 @@ type Event a = EventF (ArcF Time) a isAnalog :: Event a -> Bool isAnalog (Event {whole = Nothing}) = True -isAnalog _ = False +isAnalog _ = False isDigital :: Event a -> Bool isDigital = not . isAnalog @@ -816,7 +819,7 @@ isAdjacent e e' = (whole e == whole e') wholeOrPart :: Event a -> Arc wholeOrPart (Event {whole = Just a}) = a -wholeOrPart e = part e +wholeOrPart e = part e -- | Get the onset of an event's 'whole' wholeStart :: Event a -> Time @@ -855,12 +858,12 @@ resolveState :: ValueMap -> [Event ValueMap] -> (ValueMap, [Event ValueMap]) resolveState sMap [] = (sMap, []) resolveState sMap (e:es) = (sMap'', (e {value = v'}):es') where f sm (VState v) = v sm - f sm v = (sm, v) + f sm v = (sm, v) (sMap', v') | eventHasOnset e = Map.mapAccum f sMap (value e) -- pass state through VState functions | otherwise = (sMap, Map.filter notVState $ value e) -- filter out VState values without onsets (sMap'', es') = resolveState sMap' es notVState (VState _) = False - notVState _ = True + notVState _ = True -- ** Values @@ -932,54 +935,54 @@ instance Eq Value where (VI x) == (VR y) = toRational x == y (VR y) == (VI x) = toRational x == y - _ == _ = False + _ == _ = False instance Ord Value where - compare (VS x) (VS y) = compare x y - compare (VB x) (VB y) = compare x y - compare (VF x) (VF y) = compare x y - compare (VN x) (VN y) = compare (unNote x) (unNote 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 x) (VS y) = compare x y + compare (VB x) (VB y) = compare x y + compare (VF x) (VF y) = compare x y + compare (VN x) (VN y) = compare (unNote x) (unNote 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 (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 + compare (VF x) (VI y) = compare x (fromIntegral y) + compare (VI x) (VF y) = compare (fromIntegral x) y - compare (VR x) (VI y) = compare x (fromIntegral y) - compare (VI x) (VR y) = compare (fromIntegral x) y + compare (VR x) (VI y) = compare x (fromIntegral y) + compare (VI x) (VR y) = compare (fromIntegral x) y - compare (VF x) (VR y) = compare x (fromRational y) - compare (VR x) (VF y) = compare (fromRational x) y + compare (VF x) (VR y) = compare x (fromRational y) + compare (VR x) (VF y) = compare (fromRational x) y - compare (VN x) (VI y) = compare x (fromIntegral y) - compare (VI x) (VN y) = compare (fromIntegral x) y + compare (VN x) (VI y) = compare x (fromIntegral y) + compare (VI x) (VN y) = compare (fromIntegral x) y - compare (VN x) (VR y) = compare (unNote x) (fromRational y) - compare (VR x) (VN y) = compare (fromRational x) (unNote y) + compare (VN x) (VR y) = compare (unNote x) (fromRational y) + compare (VR x) (VN y) = compare (fromRational x) (unNote y) - compare (VF x) (VN y) = compare x (unNote y) - compare (VN x) (VF y) = compare (unNote x) y + compare (VF x) (VN y) = compare x (unNote y) + compare (VN x) (VF y) = compare (unNote x) y -- you can't really compare patterns, state or lists.. compare (VPattern _) (VPattern _) = EQ - compare (VPattern _) _ = GT - compare _ (VPattern _) = LT + compare (VPattern _) _ = GT + compare _ (VPattern _) = LT - compare (VState _) (VState _) = EQ - compare (VState _) _ = GT - compare _ (VState _) = LT + compare (VState _) (VState _) = EQ + compare (VState _) _ = GT + compare _ (VState _) = LT - compare (VList _) (VList _) = EQ - compare (VList _) _ = GT - compare _ (VList _) = LT + compare (VList _) (VList _) = EQ + compare (VList _) _ = GT + compare _ (VList _) = LT -- | General utilities.. @@ -1010,46 +1013,46 @@ getI :: Value -> Maybe Int getI (VI i) = Just i getI (VR x) = Just $ floor x getI (VF x) = Just $ floor x -getI _ = Nothing +getI _ = Nothing getF :: Value -> Maybe Double getF (VF f) = Just f getF (VR x) = Just $ fromRational x getF (VI x) = Just $ fromIntegral x -getF _ = Nothing +getF _ = Nothing getN :: Value -> Maybe Note getN (VN n) = Just n getN (VF f) = Just $ Note f getN (VR x) = Just $ Note $ fromRational x getN (VI x) = Just $ Note $ fromIntegral x -getN _ = Nothing +getN _ = Nothing getS :: Value -> Maybe String getS (VS s) = Just s -getS _ = Nothing +getS _ = Nothing getB :: Value -> Maybe Bool getB (VB b) = Just b -getB _ = Nothing +getB _ = Nothing getR :: Value -> Maybe Rational getR (VR r) = Just r getR (VF x) = Just $ toRational x getR (VI x) = Just $ toRational x -getR _ = Nothing +getR _ = Nothing getBlob :: Value -> Maybe [Word8] getBlob (VX xs) = Just xs -getBlob _ = Nothing +getBlob _ = Nothing getList :: Value -> Maybe [Value] getList (VList vs) = Just vs -getList _ = Nothing +getList _ = Nothing valueToPattern :: Value -> Pattern Value valueToPattern (VPattern pat) = pat -valueToPattern v = pure v +valueToPattern v = pure v --- functions relating to chords/patterns of lists @@ -1075,8 +1078,8 @@ collectEvent l@(e:_) = Just $ e {context = con, value = vs} 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 [] = [] + remNo (Nothing:cs) = remNo cs remNo ((Just c):cs) = c : (remNo cs) -- | collects all events satisfying the same constraint into a list diff --git a/src/Sound/Tidal/Stream.hs b/src/Sound/Tidal/Stream.hs index b9d6c2990..725a51b68 100644 --- a/src/Sound/Tidal/Stream.hs +++ b/src/Sound/Tidal/Stream.hs @@ -1,6 +1,11 @@ -{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, FlexibleContexts, ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} -{-# language DeriveGeneric, StandaloneDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} module Sound.Tidal.Stream (module Sound.Tidal.Stream) where @@ -22,54 +27,55 @@ module Sound.Tidal.Stream (module Sound.Tidal.Stream) where along with this library. If not, see . -} -import Control.Applicative ((<|>)) -import Control.Concurrent.MVar +import Control.Applicative ((<|>)) 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 -import qualified Sound.Osc.Time.Timeout as O +import Control.Concurrent.MVar +import qualified Control.Exception as E +import Control.Monad (forM_, when) +import Data.Coerce (coerce) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes, fromJust, fromMaybe, + isJust) +import Foreign +import Foreign.C.Types +import System.IO (hPutStrLn, stderr) + import qualified Network.Socket as N +import qualified Sound.Osc.Fd as O +import qualified Sound.Osc.Time.Timeout as O +import Data.List (sortOn) import Sound.Tidal.Config -import Sound.Tidal.Core (stack, (#)) +import Sound.Tidal.Core (stack, (#)) import Sound.Tidal.ID -import qualified Sound.Tidal.Link as Link -import Sound.Tidal.Params (pS) +import qualified Sound.Tidal.Link as Link +import Sound.Tidal.Params (pS) import Sound.Tidal.Pattern -import qualified Sound.Tidal.Tempo as T -import Sound.Tidal.Utils ((!!!)) -import Data.List (sortOn) -import System.Random (getStdRandom, randomR) -import Sound.Tidal.Show () +import Sound.Tidal.Show () +import qualified Sound.Tidal.Tempo as T +import Sound.Tidal.Utils ((!!!)) +import System.Random (getStdRandom, randomR) import Sound.Tidal.Version -import Sound.Tidal.StreamTypes as Sound.Tidal.Stream +import Sound.Tidal.StreamTypes as Sound.Tidal.Stream -data Stream = Stream {sConfig :: Config, - sBusses :: MVar [Int], - sStateMV :: MVar ValueMap, +data Stream = Stream {sConfig :: Config, + sBusses :: MVar [Int], + sStateMV :: MVar ValueMap, -- sOutput :: MVar ControlPattern, - sLink :: Link.AbletonLink, - sListen :: Maybe O.Udp, - sPMapMV :: MVar PlayMap, + sLink :: Link.AbletonLink, + sListen :: Maybe O.Udp, + sPMapMV :: MVar PlayMap, sActionsMV :: MVar [T.TempoAction], sGlobalFMV :: MVar (ControlPattern -> ControlPattern), - sCxs :: [Cx] + sCxs :: [Cx] } -data Cx = Cx {cxTarget :: Target, - cxUDP :: O.Udp, - cxOSCs :: [OSC], - cxAddr :: N.AddrInfo, +data Cx = Cx {cxTarget :: Target, + cxUDP :: O.Udp, + cxOSCs :: [OSC], + cxAddr :: N.AddrInfo, cxBusAddr :: Maybe N.AddrInfo } deriving (Show) @@ -82,13 +88,13 @@ data Schedule = Pre StampStyle | Live deriving (Eq, Show) -data Target = Target {oName :: String, - oAddress :: String, - oPort :: Int, - oBusPort :: Maybe Int, - oLatency :: Double, - oWindow :: Maybe Arc, - oSchedule :: Schedule, +data Target = Target {oName :: String, + oAddress :: String, + oPort :: Int, + oBusPort :: Maybe Int, + oLatency :: Double, + oWindow :: Maybe Arc, + oSchedule :: Schedule, oHandshake :: Bool } deriving Show @@ -105,15 +111,15 @@ data OSC = OSC {path :: String, data ProcessedEvent = ProcessedEvent { - peHasOnset :: Bool, - peEvent :: Event ValueMap, - peCps :: Link.BPM, - peDelta :: Link.Micros, - peCycle :: Time, - peOnWholeOrPart :: Link.Micros, + 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 + peOnPart :: Link.Micros, + peOnPartOsc :: O.Time } sDefault :: String -> Maybe Value @@ -281,15 +287,15 @@ startMulti :: [Target] -> Config -> IO () startMulti _ _ = hPutStrLn stderr $ "startMulti has been removed, please check the latest documentation on tidalcycles.org" toDatum :: Value -> O.Datum -toDatum (VF x) = O.float x -toDatum (VN x) = O.float x -toDatum (VI x) = O.int32 x -toDatum (VS x) = O.string x -toDatum (VR x) = O.float $ ((fromRational x) :: Double) -toDatum (VB True) = O.int32 (1 :: Int) +toDatum (VF x) = O.float x +toDatum (VN x) = O.float x +toDatum (VI x) = O.int32 x +toDatum (VS x) = O.string x +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 -toDatum _ = error "toDatum: unhandled value" +toDatum (VX xs) = O.Blob $ O.blob_pack xs +toDatum _ = error "toDatum: unhandled value" toData :: OSC -> Event ValueMap -> Maybe [O.Datum] toData (OSC {args = ArgList as}) e = fmap (fmap (toDatum)) $ sequence $ map (\(n,v) -> Map.lookup n (value e) <|> v) as @@ -317,25 +323,25 @@ getString :: ValueMap -> String -> Maybe String getString cm s = (simpleShow <$> Map.lookup param cm) <|> defaultValue dflt where (param, dflt) = break (== '=') s simpleShow :: Value -> String - simpleShow (VS str) = str - simpleShow (VI i) = show i - simpleShow (VF f) = show f - simpleShow (VN n) = show n - simpleShow (VR r) = show r - simpleShow (VB b) = show b - simpleShow (VX xs) = show xs - simpleShow (VState _) = show "" + simpleShow (VS str) = str + simpleShow (VI i) = show i + simpleShow (VF f) = show f + simpleShow (VN n) = show n + simpleShow (VR r) = show r + simpleShow (VB b) = show b + simpleShow (VX xs) = show xs + simpleShow (VState _) = show "" simpleShow (VPattern _) = show "" - simpleShow (VList _) = show "" + simpleShow (VList _) = show "" defaultValue :: String -> Maybe String defaultValue ('=':dfltVal) = Just dfltVal - defaultValue _ = Nothing + defaultValue _ = Nothing playStack :: PlayMap -> ControlPattern -playStack pMap = stack . (map pattern) . (filter active) . Map.elems $ pMap +playStack pMap = stack . (map psPattern) . (filter active) . Map.elems $ pMap where active pState = if hasSolo pMap - then solo pState - else not (mute pState) + then psSolo pState + else not (psMute pState) toOSC :: [Int] -> ProcessedEvent -> OSC -> [(Double, Bool, O.Message)] toOSC busses pe osc@(OSC _ _) @@ -407,7 +413,7 @@ updatePattern stream k !t pat = do 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)} + where updatePS (Just playState) = do playState {psPattern = pat', psHistory = pat:(psHistory playState)} updatePS Nothing = PlayState pat' False False [pat'] patControls = Map.singleton patternTimeID (VR t) pat' = withQueryControls (Map.union patControls) @@ -470,11 +476,11 @@ onTick stream st ops s 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 = [] - } + (PlayState {psPattern = pat, + psMute = False, + psSolo = False, + psHistory = [] + } ) -- The nowArc is a full cycle @@ -535,9 +541,9 @@ doTick stream st ops sMap = setPreviousPatternOrSilence :: Stream -> IO () setPreviousPatternOrSilence stream = modifyMVar_ (sPMapMV stream) $ return - . Map.map ( \ pMap -> case history pMap of - _:p:ps -> pMap { pattern = p, history = p:ps } - _ -> pMap { pattern = silence, history = [silence] } + . Map.map ( \ pMap -> case psHistory pMap of + _:p:ps -> pMap { psPattern = p, psHistory = p:ps } + _ -> pMap { psPattern = silence, psHistory = [silence] } ) -- send has three modes: @@ -573,17 +579,17 @@ streamSetCycle :: Stream -> Time -> IO () streamSetCycle s cyc = T.setCycle cyc (sActionsMV s) hasSolo :: Map.Map k PlayState -> Bool -hasSolo = (>= 1) . length . filter solo . Map.elems +hasSolo = (>= 1) . length . filter psSolo . Map.elems streamList :: Stream -> IO () streamList s = do pMap <- readMVar (sPMapMV s) let hs = hasSolo pMap putStrLn $ concatMap (showKV hs) $ Map.toList pMap where showKV :: Bool -> (PatId, PlayState) -> String - showKV True (k, (PlayState {solo = True})) = k ++ " - solo\n" - showKV True (k, _) = "(" ++ k ++ ")\n" - showKV False (k, (PlayState {solo = False})) = k ++ "\n" - showKV False (k, _) = "(" ++ k ++ ") - muted\n" + showKV True (k, (PlayState {psSolo = True})) = k ++ " - solo\n" + showKV True (k, _) = "(" ++ k ++ ")\n" + showKV False (k, (PlayState {psSolo = False})) = k ++ "\n" + showKV False (k, _) = "(" ++ k ++ ") - muted\n" -- Evaluation of pat is forced so exceptions are picked up here, before replacing the existing pattern. @@ -592,19 +598,19 @@ streamReplace s k !pat = modifyMVar_ (sActionsMV s) (\actions -> return $ (T.StreamReplace k pat) : actions) streamMute :: Stream -> ID -> IO () -streamMute s k = withPatIds s [k] (\x -> x {mute = True}) +streamMute s k = withPatIds s [k] (\x -> x {psMute = True}) streamMutes :: Stream -> [ID] -> IO () -streamMutes s ks = withPatIds s ks (\x -> x {mute = True}) +streamMutes s ks = withPatIds s ks (\x -> x {psMute = True}) streamUnmute :: Stream -> ID -> IO () -streamUnmute s k = withPatIds s [k] (\x -> x {mute = False}) +streamUnmute s k = withPatIds s [k] (\x -> x {psMute = False}) streamSolo :: Stream -> ID -> IO () -streamSolo s k = withPatIds s [k] (\x -> x {solo = True}) +streamSolo s k = withPatIds s [k] (\x -> x {psSolo = True}) streamUnsolo :: Stream -> ID -> IO () -streamUnsolo s k = withPatIds s [k] (\x -> x {solo = False}) +streamUnsolo s k = withPatIds s [k] (\x -> x {psSolo = False}) withPatIds :: Stream -> [ID] -> (PlayState -> PlayState) -> IO () withPatIds s ks f @@ -615,19 +621,19 @@ withPatIds s ks f -- TODO - is there a race condition here? streamMuteAll :: Stream -> IO () -streamMuteAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {mute = True}) +streamMuteAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {psMute = True}) streamHush :: Stream -> IO () -streamHush s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {pattern = silence, history = silence:history x}) +streamHush s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {psPattern = silence, psHistory = silence:psHistory x}) streamUnmuteAll :: Stream -> IO () -streamUnmuteAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {mute = False}) +streamUnmuteAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {psMute = False}) streamUnsoloAll :: Stream -> IO () -streamUnsoloAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {solo = False}) +streamUnsoloAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {psSolo = False}) streamSilence :: Stream -> ID -> IO () -streamSilence s k = withPatIds s [k] (\x -> x {pattern = silence, history = silence:history x}) +streamSilence s k = withPatIds s [k] (\x -> x {psPattern = silence, psHistory = silence:psHistory x}) streamAll :: Stream -> (ControlPattern -> ControlPattern) -> IO () streamAll s f = do _ <- swapMVar (sGlobalFMV s) f @@ -728,8 +734,8 @@ ctrlResponder waits c (stream@(Stream {sListen = Just sock})) return () withID :: O.Datum -> (ID -> IO ()) -> IO () withID (O.AsciiString k) func = func $ (ID . O.ascii_to_string) k - withID (O.Int32 k) func = func $ (ID . show) k - withID _ _ = return () + withID (O.Int32 k) func = func $ (ID . show) k + withID _ _ = return () ctrlResponder _ _ _ = return () verbose :: Config -> String -> IO () diff --git a/src/Sound/Tidal/StreamTypes.hs b/src/Sound/Tidal/StreamTypes.hs index 6b4fa76ea..b37e6bf40 100644 --- a/src/Sound/Tidal/StreamTypes.hs +++ b/src/Sound/Tidal/StreamTypes.hs @@ -1,13 +1,13 @@ module Sound.Tidal.StreamTypes where -import qualified Data.Map.Strict as Map -import Sound.Tidal.Pattern -import Sound.Tidal.Show () +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] +data PlayState = PlayState {psPattern :: ControlPattern, + psMute :: Bool, + psSolo :: Bool, + psHistory :: [ControlPattern] } deriving Show diff --git a/src/Sound/Tidal/Tempo.hs b/src/Sound/Tidal/Tempo.hs index c69c5ff44..6365c603a 100644 --- a/src/Sound/Tidal/Tempo.hs +++ b/src/Sound/Tidal/Tempo.hs @@ -1,25 +1,28 @@ -{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, FlexibleContexts, ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns -fno-warn-orphans #-} module Sound.Tidal.Tempo where -import Control.Concurrent.MVar -import qualified Sound.Tidal.Pattern as P -import qualified Sound.Osc.Fd as O -import Control.Concurrent (forkIO, ThreadId, threadDelay) -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 Control.Concurrent (ThreadId, forkIO, threadDelay) +import Control.Concurrent.MVar +import qualified Control.Exception as E +import Control.Monad (when) +import Data.Int (Int64) +import qualified Data.Map.Strict as Map +import Foreign.C.Types (CDouble (..)) +import qualified Sound.Osc.Fd as O +import Sound.Tidal.Config +import Sound.Tidal.ID +import qualified Sound.Tidal.Link as Link +import qualified Sound.Tidal.Pattern as P +import Sound.Tidal.Utils (writeError) +import System.IO (hPutStrLn, stderr) -import Sound.Tidal.StreamTypes +import Sound.Tidal.StreamTypes {- Tempo.hs - Tidal's scheduler @@ -51,10 +54,10 @@ data TempoAction = | StreamReplace ID P.ControlPattern | Transition Bool TransitionMapper ID P.ControlPattern -data State = State {ticks :: Int64, - start :: Link.Micros, - nowArc :: P.Arc, - nudged :: Double +data State = State {ticks :: Int64, + start :: Link.Micros, + nowArc :: P.Arc, + nudged :: Double } deriving Show @@ -67,13 +70,13 @@ data ActionHandler = 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 (), + 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 + beatToCycles :: CDouble -> CDouble, + cyclesToBeat :: CDouble -> CDouble } {-| @@ -164,7 +167,7 @@ clocked config stateMV mapMV actionsMV ac abletonLink processAhead = round $ (cProcessAhead config) * 1000000 checkArc :: State -> IO a checkArc st = do - actions <- swapMVar actionsMV [] + actions <- swapMVar actionsMV [] st' <- processActions st actions let logicalEnd = logicalTime (start st') $ ticks st' + 1 nextArcStartCycle = P.stop $ nowArc st' @@ -174,7 +177,7 @@ clocked config stateMV mapMV actionsMV ac abletonLink if (arcStartTime < logicalEnd) then processArc st' else tick st' - processArc :: State -> IO a + processArc :: State -> IO a processArc st = do streamState <- takeMVar stateMV @@ -226,7 +229,7 @@ clocked config stateMV mapMV actionsMV ac abletonLink Link.requestBeatAtTime sessionState beat startAt quantum Link.commitAndDestroyAppSessionState abletonLink sessionState - + let st'' = st' { ticks = 0, start = now, @@ -288,11 +291,11 @@ clocked config stateMV mapMV actionsMV ac abletonLink (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 = P.silence, - mute = False, - solo = False, - history = (appendPat historyFlag) (P.silence:[]) + updatePS (Just playState) = playState {psHistory = (appendPat historyFlag) (psHistory playState)} + updatePS Nothing = PlayState {psPattern = P.silence, + psMute = False, + psSolo = False, + psHistory = (appendPat historyFlag) (P.silence:[]) } transition' pat' = do now <- Link.clock abletonLink ss <- Link.createAndCaptureAppSessionState abletonLink @@ -300,7 +303,7 @@ clocked config stateMV mapMV actionsMV ac abletonLink 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 + pat' <- transition' $ appendPat (not historyFlag) (psHistory playState) + let pMap' = Map.insert (fromID patId) (playState {psPattern = pat'}) pMap _ <- swapMVar mapMV pMap' return (st', streamState') diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs index d0c28c952..f7b3890c3 100644 --- a/src/Sound/Tidal/UI.hs +++ b/src/Sound/Tidal/UI.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} {- UI.hs - Tidal's main 'user interface' functions, for transforming @@ -33,22 +35,24 @@ module Sound.Tidal.UI where -import Prelude hiding ((<*), (*>)) +import Prelude hiding ((*>), (<*)) -import Data.Char (digitToInt, isDigit, ord) -import Data.Bits (testBit, Bits, xor, shiftL, shiftR) +import Data.Bits (Bits, shiftL, shiftR, testBit, xor) +import Data.Char (digitToInt, isDigit, ord) -import Data.Ratio ((%), Ratio) -import Data.Fixed (mod') -import Data.List (sort, sortOn, findIndices, elemIndex, groupBy, transpose, intercalate, findIndex) -import Data.Maybe (isJust, fromJust, fromMaybe, mapMaybe) -import qualified Data.Text as T -import qualified Data.Map.Strict as Map -import Data.Bool (bool) +import Data.Bool (bool) +import Data.Fixed (mod') +import Data.List (elemIndex, findIndex, findIndices, + groupBy, intercalate, sort, sortOn, + transpose) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust, fromMaybe, isJust, mapMaybe) +import Data.Ratio (Ratio, (%)) +import qualified Data.Text as T import Sound.Tidal.Bjorklund (bjorklund) import Sound.Tidal.Core -import qualified Sound.Tidal.Params as P +import qualified Sound.Tidal.Params as P import Sound.Tidal.Pattern import Sound.Tidal.Utils @@ -124,7 +128,7 @@ and with the juxed version shifted backwards for 1024 cycles: > jux (# ((1024 <~) $ gain rand)) $ sound "sn sn ~ sn" # gain rand -} rand :: Fractional a => Pattern a -rand = Pattern (\(State a@(Arc s e) _) -> [Event (Context []) Nothing a (realToFrac $ (timeToRand ((e + s)/2) :: Double))]) +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 @@ -689,7 +693,7 @@ wedge pt pa pb = innerJoin $ (\t -> _wedge t pa pb) <$> pt _wedge :: Time -> Pattern a -> Pattern a -> Pattern a _wedge 0 _ p' = p' -_wedge 1 p _ = p +_wedge 1 p _ = p _wedge t p p' = overlay (_fastGap (1/t) p) (t `rotR` _fastGap (1/(1-t)) p') @@ -976,10 +980,10 @@ _distrib :: [Int] -> Pattern a -> Pattern a _distrib xs p = boolsToPat (foldr distrib' (replicate (last xs) True) (reverse $ layers xs)) p where distrib' :: [Bool] -> [Bool] -> [Bool] - distrib' [] _ = [] - distrib' (_:a) [] = False : distrib' a [] + distrib' [] _ = [] + distrib' (_:a) [] = False : distrib' a [] distrib' (True:a) (x:b) = x : distrib' a b - distrib' (False:a) b = False : distrib' a b + distrib' (False:a) b = False : distrib' a b layers = map bjorklund . (zip<*>tail) boolsToPat a b' = flip const <$> filterValues (== True) (fastFromList a) <* b' @@ -1296,9 +1300,9 @@ randArcs n = return pairs where pairUp [] = [] pairUp xs = Arc 0 (head xs) : pairUp' xs - pairUp' [] = [] - pairUp' [_] = [] - pairUp' [a, _] = [Arc a 1] + pairUp' [] = [] + pairUp' [_] = [] + pairUp' [a, _] = [Arc a 1] pairUp' (a:b:xs) = Arc a b: pairUp' (b:xs) @@ -1431,7 +1435,7 @@ markovPat :: Pattern Int -> Pattern Int -> [[Double]] -> Pattern Int markovPat = tParam2 _markovPat _markovPat :: Int -> Int -> [[Double]] -> Pattern Int -_markovPat n xi tp = splitQueries $ Pattern (\(State a@(Arc s _) _) -> +_markovPat n xi tp = splitQueries $ pattern (\(State a@(Arc s _) _) -> queryArc (listToPat $ runMarkov n tp xi (sam s)) a) {-| @@ -1755,7 +1759,7 @@ d1 $ s "superhammond!12" # n (fromIntegral <$> randrun 13) randrun :: Int -> Pattern Int randrun 0 = silence randrun n' = - splitQueries $ Pattern (\(State a@(Arc s _) _) -> events a $ sam s) + splitQueries $ pattern (\(State a@(Arc s _) _) -> events a $ sam s) where events a seed = mapMaybe toEv $ zip arcs shuffled where shuffled = map snd $ sortOn fst $ zip rs [0 .. (n'-1)] rs = timeToRands seed n' :: [Double] @@ -1850,12 +1854,12 @@ ur t outer_p ps fs = _slow t $ unwrap $ adjust <$> timedValues (getPat . split < where split = wordsBy (==':') getPat (s:xs) = (match s, transform xs) -- TODO - check this really can't happen.. - getPat _ = error "can't happen?" + getPat _ = error "can't happen?" match s = fromMaybe silence $ lookup s ps' ps' = map (fmap (_fast t)) ps adjust (a, (p, f)) = f a p transform (x:_) a = transform' x a - transform _ _ = id + transform _ _ = id transform' str (Arc s e) p = s `rotR` inside (pure $ 1/(e-s)) (matchF str) p matchF str = fromMaybe id $ lookup str fs timedValues = withEvent (\(Event c (Just a) a' v) -> Event c (Just a) a' (a,v)) . filterDigital @@ -1886,7 +1890,7 @@ inhabit ps p = squeezeJoin $ (\s -> fromMaybe silence $ lookup s ps) <$> p spaceOut :: [Time] -> Pattern a -> Pattern a spaceOut xs p = _slow (toRational $ sum xs) $ stack $ map (`compressArc` p) spaceArcs where markOut :: Time -> [Time] -> [Arc] - markOut _ [] = [] + markOut _ [] = [] markOut offset (x:xs') = Arc offset (offset+x):markOut (offset+x) xs' spaceArcs = map (\(Arc a b) -> Arc (a/s) (b/s)) $ markOut 0 xs s = sum xs @@ -1979,7 +1983,7 @@ _arp name p = arpWith f p ("thumbup", thumbup), ("thumbupdown", \x -> init (thumbup x) ++ init (reverse $ thumbup x)) ] - converge [] = [] + converge [] = [] converge (x:xs) = x : converge' xs converge' [] = [] converge' xs = last xs : converge (init xs) @@ -2020,7 +2024,7 @@ 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 steppityIn xs = mapMaybe (\(n, ev) -> (timeguard n xs ev t)) $ enumerate xs - timeguard _ _ ev 0 = return ev + timeguard _ _ ev 0 = return ev timeguard n xs ev _ = (shiftIt n (length xs) ev) shiftIt n d (Event c (Just (Arc s e)) a' v) = do a'' <- subArc (Arc newS e) a' @@ -2325,7 +2329,7 @@ samples' p p' = flip pick <$> p' <*> p {- scrumple :: Time -> Pattern a -> Pattern a -> Pattern a scrumple o p p' = p'' -- overlay p (o `rotR` p'') - where p'' = Pattern $ \a -> concatMap + where p'' = pattern $ \a -> concatMap (\((s,d), vs) -> map (\x -> ((s,d), snd x ) @@ -2348,7 +2352,7 @@ stackwith p ps | null ps = silence where l = fromIntegral $ length ps {- -cross f p p' = Pattern $ \t -> concat [filter flt $ arc p t, +cross f p p' = pattern $ \t -> concat [filter flt $ arc p t, filter (not . flt) $ arc p' t ] ] where flt = f . cyclePos . fst . fst @@ -2595,7 +2599,7 @@ contrastRange = contrastBy f f (VF s, VF e) (VF v) = v >= s && v <= e f (VN s, VN e) (VN v) = v >= s && v <= e f (VS s, VS e) (VS v) = v == s && v == e - f _ _ = False + f _ _ = False {- | The @fix@ function applies another function to matching events in a pattern of @@ -2691,10 +2695,10 @@ inv = (not <$>) -- | Serialises a pattern so there's only one event playing at any one -- time, making it /monophonic/. Events which start/end earlier are given priority. mono :: Pattern a -> Pattern a -mono p = Pattern $ \(State a cm) -> flatten $ query p (State a cm) where +mono p = pattern $ \(State a cm) -> flatten $ query p (State a cm) where flatten :: [Event a] -> [Event a] flatten = mapMaybe constrainPart . truncateOverlaps . sortOn whole - truncateOverlaps [] = [] + truncateOverlaps [] = [] truncateOverlaps (e:es) = e : truncateOverlaps (mapMaybe (snip e) es) -- TODO - decide what to do about analog events.. snip a b | start (wholeOrPart b) >= stop (wholeOrPart a) = Just b @@ -2722,7 +2726,7 @@ This sound will pan gradually from left to right, then to the center, then to th -- TODO - test this with analog events smooth :: Fractional a => Pattern a -> Pattern a -smooth p = Pattern $ \st@(State a cm) -> tween st a $ query monoP (State (midArc a) cm) +smooth p = pattern $ \st@(State a cm) -> tween st a $ query monoP (State (midArc a) cm) where midArc a = Arc (mid (start a, stop a)) (mid (start a, stop a)) tween _ _ [] = [] @@ -2782,9 +2786,9 @@ deconstruct :: Int -> Pattern String -> String deconstruct n p = intercalate " " $ map showStep $ toList p where showStep :: [String] -> String - showStep [] = "~" + showStep [] = "~" showStep [x] = x - showStep xs = "[" ++ (intercalate ", " xs) ++ "]" + showStep xs = "[" ++ (intercalate ", " xs) ++ "]" toList :: Pattern a -> [[a]] toList pat = map (\(s,e) -> map value $ queryArc (_segment n' pat) (Arc s e)) arcs where breaks = [0, (1/n') ..] @@ -2820,7 +2824,7 @@ _bite n ipat pat = squeezeJoin $ zoompat <$> ipat -- | Chooses from a list of patterns, using a pattern of integers. squeeze :: Pattern Int -> [Pattern a] -> Pattern a -squeeze _ [] = silence +squeeze _ [] = silence squeeze ipat pats = squeezeJoin $ (pats !!!) <$> ipat squeezeJoinUp :: Pattern (ControlPattern) -> ControlPattern @@ -2896,5 +2900,5 @@ grain s w = P.begin b # P.end e necklace :: Rational -> [Int] -> Pattern Bool necklace perCycle xs = _slow ((toRational $ sum xs) / perCycle) $ listToPat $ list xs where list :: [Int] -> [Bool] - list [] = [] + list [] = [] list (x:xs') = (True:(replicate (x-1) False)) ++ list xs' diff --git a/test/Sound/Tidal/ExceptionsTest.hs b/test/Sound/Tidal/ExceptionsTest.hs index 2a4d30999..3a61ba17a 100644 --- a/test/Sound/Tidal/ExceptionsTest.hs +++ b/test/Sound/Tidal/ExceptionsTest.hs @@ -1,21 +1,22 @@ -{-# LANGUAGE OverloadedStrings, CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Sound.Tidal.ExceptionsTest where -import Test.Microspec -import Control.Exception -import Control.DeepSeq -import Data.Typeable () -import Prelude hiding ((<*), (*>)) +import Control.DeepSeq +import Control.Exception +import Data.Typeable () +import Prelude hiding ((*>), (<*)) +import Test.Microspec -import Sound.Tidal.Pattern +import Sound.Tidal.Pattern run :: Microspec () run = describe "NFData, forcing and catching exceptions" $ do describe "instance NFData (Pattern a)" $ do it "rnf forces argument" $ do - evaluate (rnf (Pattern undefined :: Pattern ())) + evaluate (rnf (Pattern undefined Nothing :: Pattern ())) `shouldThrow` anyException @@ -56,7 +57,7 @@ errorCall :: String -> Selector ErrorCall #if MIN_VERSION_base(4,9,0) errorCall s (ErrorCallWithLocation msg _) = s == msg #else -errorCall s (ErrorCall msg) = s == msg +errorCall s (ErrorCall msg) = s == msg #endif anyIOException :: Selector IOException From df27212322dda7aba74c12feb48e8d72e2b5a6c1 Mon Sep 17 00:00:00 2001 From: alex Date: Tue, 9 Apr 2024 12:36:42 +0100 Subject: [PATCH 02/46] 1.10-dev -> dev --- CONTRIBUTING.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index edc34eaf5..71d277104 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -20,7 +20,7 @@ compiler/interpreter. Some resources for learning Haskell can be found here: The main repository is maintained on github: https://github.com/tidalcycles/tidal -**At the time of writing, current work should target the '1.10-dev' branch. The 2.0-dev branch is for experiments towards version 2.0.** +**At the time of writing, current work should target the 'dev' branch.** The SuperDirt repository is here: https://github.com/musikinformatik/SuperDirt @@ -124,4 +124,4 @@ Push any final changes to the code, updating the following files: * [The Hackage upload page](https://hackage.haskell.org/upload) contains instructions and links for uploading a release archive. **Start by uploading a package candidate because a package release can't be changed!** * To distribute a package candidate for testing, find the download link for the `.tar.gz` bundle on the Hackage page for the package candidate. This candidate version can be installed with the following command: `cabal v1-install [url]` (note that at this time, [the v1 install command is necessary for installing a library from a URL](https://github.com/haskell/cabal/issues/8335)). -* Once everyone is happy with the new version, go ahead and upload the archive as a package release and publish the release on GitHub! \ No newline at end of file +* Once everyone is happy with the new version, go ahead and upload the archive as a package release and publish the release on GitHub! From 198263ab06ffa76deacb791fc25c5c337badecd5 Mon Sep 17 00:00:00 2001 From: alex Date: Tue, 9 Apr 2024 13:13:09 +0100 Subject: [PATCH 03/46] add pattern metadata for pure values --- src/Sound/Tidal/ParseBP.hs | 63 ++++++++++++++++-------------- src/Sound/Tidal/Pattern.hs | 42 +++++++++++--------- src/Sound/Tidal/Show.hs | 34 ++++++++-------- src/Sound/Tidal/Stream.hs | 2 +- src/Sound/Tidal/UI.hs | 14 +++---- test/Sound/Tidal/ExceptionsTest.hs | 2 +- 6 files changed, 84 insertions(+), 73 deletions(-) diff --git a/src/Sound/Tidal/ParseBP.hs b/src/Sound/Tidal/ParseBP.hs index 5881e13f0..9dd8785ce 100644 --- a/src/Sound/Tidal/ParseBP.hs +++ b/src/Sound/Tidal/ParseBP.hs @@ -1,5 +1,10 @@ -{-# LANGUAGE OverloadedStrings, FlexibleInstances, CPP, DeriveFunctor, GADTs, StandaloneDeriving #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans -fno-warn-unused-do-bind #-} module Sound.Tidal.ParseBP where @@ -23,30 +28,30 @@ module Sound.Tidal.ParseBP where along with this library. If not, see . -} -import Control.Applicative () -import qualified Control.Exception as E -import Data.Bifunctor (first) +import Control.Applicative () +import qualified Control.Exception as E +import Data.Bifunctor (first) import Data.Colour import Data.Colour.Names -import Data.Functor.Identity (Identity) -import Data.List (intercalate) +import Data.Functor.Identity (Identity) +import Data.List (intercalate) import Data.Maybe import Data.Ratio -import Data.Typeable (Typeable) -import GHC.Exts ( IsString(..) ) -import Text.Parsec.Error -import Text.ParserCombinators.Parsec -import Text.ParserCombinators.Parsec.Language ( haskellDef ) -import qualified Text.ParserCombinators.Parsec.Token as P -import qualified Text.Parsec.Prim +import Data.Typeable (Typeable) +import GHC.Exts (IsString (..)) +import Sound.Tidal.Chords +import Sound.Tidal.Core import Sound.Tidal.Pattern import Sound.Tidal.UI -import Sound.Tidal.Core -import Sound.Tidal.Chords -import Sound.Tidal.Utils (fromRight) +import Sound.Tidal.Utils (fromRight) +import Text.Parsec.Error +import qualified Text.Parsec.Prim +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Language (haskellDef) +import qualified Text.ParserCombinators.Parsec.Token as P data TidalParseError = TidalParseError {parsecError :: ParseError, - code :: String + code :: String } deriving (Eq, Typeable) @@ -175,7 +180,7 @@ toPat = \case resolve_tpat :: (Enumerable a, Parseable a) => TPat a -> (Rational, Pattern a) resolve_tpat (TPat_Seq xs) = resolve_seq xs -resolve_tpat a = (1, toPat a) +resolve_tpat a = (1, toPat a) resolve_seq :: (Enumerable a, Parseable a) => [TPat a] -> (Rational, Pattern a) resolve_seq xs = (total_size, timeCat sized_pats) @@ -183,15 +188,15 @@ resolve_seq xs = (total_size, timeCat sized_pats) total_size = sum $ map fst sized_pats resolve_size :: [TPat a] -> [(Rational, TPat a)] -resolve_size [] = [] +resolve_size [] = [] resolve_size ((TPat_Elongate r p):ps) = (r, p):resolve_size ps -resolve_size ((TPat_Repeat n p):ps) = replicate n (1,p) ++ resolve_size ps -resolve_size (p:ps) = (1,p):resolve_size ps +resolve_size ((TPat_Repeat n p):ps) = replicate n (1,p) ++ resolve_size ps +resolve_size (p:ps) = (1,p):resolve_size ps steps_tpat :: (Show a) => TPat a -> (Rational, String) steps_tpat (TPat_Seq xs) = steps_seq xs -steps_tpat a = (1, tShow a) +steps_tpat a = (1, tShow a) steps_seq :: (Show a) => [TPat a] -> (Rational, String) steps_seq xs = (total_size, "timeCat [" ++ intercalate "," (map (\(r,s) -> "(" ++ show r ++ ", " ++ s ++ ")") sized_pats) ++ "]") @@ -199,10 +204,10 @@ steps_seq xs = (total_size, "timeCat [" ++ intercalate "," (map (\(r,s) -> "(" + total_size = sum $ map fst sized_pats steps_size :: Show a => [TPat a] -> [(Rational, String)] -steps_size [] = [] +steps_size [] = [] steps_size ((TPat_Elongate r p):ps) = (r, tShow p):steps_size ps -steps_size ((TPat_Repeat n p):ps) = replicate n (1, tShow p) ++ steps_size ps -steps_size (p:ps) = (1,tShow p):steps_size ps +steps_size ((TPat_Repeat n p):ps) = replicate n (1, tShow p) ++ steps_size ps +steps_size (p:ps) = (1,tShow p):steps_size ps parseBP :: (Enumerable a, Parseable a) => String -> Either ParseError (Pattern a) parseBP s = toPat <$> parseTPat s @@ -212,7 +217,7 @@ parseBP_E s = toE parsed where parsed = parseTPat s -- TODO - custom error - toE (Left e) = E.throw $ TidalParseError {parsecError = e, code = s} + toE (Left e) = E.throw $ TidalParseError {parsecError = e, code = s} toE (Right tp) = toPat tp parseTPat :: Parseable a => String -> Either ParseError (TPat a) @@ -389,9 +394,9 @@ pSequence f = do splitFeet [] = [] splitFeet pats = foot : splitFeet pats' where (foot, pats') = takeFoot pats - takeFoot [] = ([], []) + takeFoot [] = ([], []) takeFoot (TPat_Foot:pats'') = ([], pats'') - takeFoot (pat:pats'') = first (pat:) $ takeFoot pats'' + takeFoot (pat:pats'') = first (pat:) $ takeFoot pats'' pRepeat :: TPat a -> MyParser (TPat a) pRepeat a = do es <- many1 $ do char '!' diff --git a/src/Sound/Tidal/Pattern.hs b/src/Sound/Tidal/Pattern.hs index 6809e5252..6f7da9e7c 100644 --- a/src/Sound/Tidal/Pattern.hs +++ b/src/Sound/Tidal/Pattern.hs @@ -54,13 +54,16 @@ data State = State {arc :: Arc, } -- | A datatype representing events taking place over time -data Pattern a = Pattern {query :: State -> [Event a], tactus :: Maybe Rational} +data Pattern a = Pattern {query :: State -> [Event a], tactus :: Maybe Rational, pureValue :: Maybe a} deriving (Generic, Functor) instance NFData a => NFData (Pattern a) pattern :: (State -> [Event a]) -> Pattern a -pattern f = Pattern f Nothing +pattern f = Pattern f Nothing Nothing + +setTactus :: Rational -> Pattern a -> Pattern a +setTactus r p = p {tactus = Just r} -- type StateMap = Map.Map String (Pattern Value) type ControlPattern = Pattern ValueMap @@ -69,13 +72,14 @@ type ControlPattern = Pattern ValueMap instance Applicative Pattern where -- | Repeat the given value once per cycle, forever - pure v = pattern $ \(State a _) -> - map (\a' -> Event - (Context []) - (Just a') - (sect a a') - v) - $ cycleArcsInArc a + pure v = Pattern q (Just 1) (Just v) + where q (State a _) = + map (\a' -> Event + (Context []) + (Just a') + (sect a a') + v) + $ cycleArcsInArc a -- | In each of @a <*> b@, @a <* b@ and @a *> b@ -- (using the definitions from this module, not the Prelude), @@ -186,7 +190,7 @@ instance Monad Pattern where -- -- TODO - what if a continuous pattern contains a discrete one, or vice-versa? unwrap :: Pattern (Pattern a) -> Pattern a -unwrap pp = pp {query = q} +unwrap pp = pp {query = q, pureValue = Nothing} where q st = concatMap (\(Event c w p v) -> mapMaybe (munge c w p) $ query v st {arc = p}) @@ -200,7 +204,7 @@ unwrap pp = pp {query = q} -- | Turns a pattern of patterns into a single pattern. Like @unwrap@, -- but structure only comes from the inner pattern. innerJoin :: Pattern (Pattern a) -> Pattern a -innerJoin pp = pp {query = q} +innerJoin pp = pp {query = q, pureValue = Nothing} where q st = concatMap (\(Event oc _ op v) -> mapMaybe (munge oc) $ query v st {arc = op} ) @@ -214,7 +218,7 @@ innerJoin pp = pp {query = q} -- | Turns a pattern of patterns into a single pattern. Like @unwrap@, -- but structure only comes from the outer pattern. outerJoin :: Pattern (Pattern a) -> Pattern a -outerJoin pp = pp {query = q} +outerJoin pp = pp {query = q, pureValue = Nothing} where q st = concatMap (\e -> mapMaybe (munge (context e) (whole e) (part e)) $ query (value e) st {arc = pure (start $ wholeOrPart e)} @@ -229,7 +233,7 @@ outerJoin pp = pp {query = q} -- timespan of the outer whole (or the original query if it's a continuous pattern?) -- TODO - what if a continuous pattern contains a discrete one, or vice-versa? squeezeJoin :: Pattern (Pattern a) -> Pattern a -squeezeJoin pp = pp {query = q} +squeezeJoin pp = pp {query = q, pureValue = Nothing} where q st = concatMap (\e@(Event c w p v) -> mapMaybe (munge c w p) $ query (focusArc (wholeOrPart e) v) st {arc = p} @@ -246,8 +250,8 @@ _trigJoin cycleZero pat_of_pats = pattern q where q st = catMaybes $ concatMap - (\oe@(Event oc (Just jow) op ov) -> - map (\oe@(Event ic (iw) ip iv) -> + (\(Event oc (Just jow) op ov) -> + map (\(Event ic (iw) ip iv) -> do w <- subMaybeArc (Just jow) iw p <- subArc op ip return $ Event (combineContexts [ic, oc]) w p iv @@ -412,7 +416,7 @@ instance Floating ValueMap -- * Internal/fundamental functions empty :: Pattern a -empty = Pattern {query = const []} +empty = Pattern {query = const [], tactus = Just 1, pureValue = Nothing} silence :: Pattern a silence = empty @@ -452,7 +456,7 @@ withQueryControls f pat = pat { query = query pat . (\(State a m) -> State a (f -- | @withEvent f p@ returns a new @Pattern@ with each event mapped over -- function @f@. withEvent :: (Event a -> Event b) -> Pattern a -> Pattern b -withEvent f p = p {query = map f . query p} +withEvent f p = p {query = map f . query p, pureValue = Nothing} -- | @withEvent f p@ returns a new @Pattern@ with each value mapped over -- function @f@. @@ -462,7 +466,7 @@ withValue f pat = withEvent (fmap f) pat -- | @withEvent f p@ returns a new @Pattern@ with f applied to the resulting list of events for each query -- function @f@. withEvents :: ([Event a] -> [Event b]) -> Pattern a -> Pattern b -withEvents f p = p {query = f . query p} +withEvents f p = p {query = f . query p, pureValue = Nothing} -- | @withPart f p@ returns a new @Pattern@ with function @f@ applied -- to the part. @@ -669,7 +673,7 @@ rev p = -- | Mark values in the first pattern which match with at least one -- value in the second pattern. matchManyToOne :: (b -> a -> Bool) -> Pattern a -> Pattern b -> Pattern (Bool, b) -matchManyToOne f pa pb = pa {query = q} +matchManyToOne f pa pb = pa {query = q, pureValue = Nothing} where q st = map match $ query pb st where match ex@(Event xContext xWhole xPart x) = diff --git a/src/Sound/Tidal/Show.hs b/src/Sound/Tidal/Show.hs index a69e70a05..0ad3024e0 100644 --- a/src/Sound/Tidal/Show.hs +++ b/src/Sound/Tidal/Show.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE FlexibleInstances, RecordWildCards #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Sound.Tidal.Show (show, showAll, draw, drawLine, drawLineSz, stepcount, showStateful) where @@ -22,13 +23,13 @@ module Sound.Tidal.Show (show, showAll, draw, drawLine, drawLineSz, stepcount, s along with this library. If not, see . -} -import Sound.Tidal.Pattern +import Sound.Tidal.Pattern -import Data.List (intercalate, sortOn) -import Data.Ratio (numerator, denominator) -import Data.Maybe (fromMaybe, isJust) +import Data.List (intercalate, sortOn) +import Data.Maybe (fromMaybe, isJust) +import Data.Ratio (denominator, numerator) -import qualified Data.Map.Strict as Map +import qualified Data.Map.Strict as Map instance (Show a) => Show (Pattern a) where show = showPattern (Arc 0 1) @@ -47,6 +48,7 @@ showStateful p = intercalate "\n" evStrings evStrings = map evString evs' showPattern :: Show a => Arc -> Pattern a -> String +showPattern _ (Pattern _ _ (Just v)) = "(pure " ++ show v ++ ")" showPattern a p = intercalate "\n" evStrings where evs = map showEvent $ sortOn part $ queryArc p a maxPartLength :: Int @@ -79,16 +81,16 @@ instance Show Context where show (Context cs) = show cs instance Show Value where - show (VS s) = ('"':s) ++ "\"" - show (VI i) = show i - show (VF f) = show f ++ "f" - show (VN n) = show n - show (VR r) = prettyRat r ++ "r" - show (VB b) = show b - show (VX xs) = show xs + show (VS s) = ('"':s) ++ "\"" + show (VI i) = show i + show (VF f) = show f ++ "f" + show (VN n) = show n + show (VR r) = prettyRat r ++ "r" + show (VB b) = show b + show (VX xs) = show xs show (VPattern pat) = "(" ++ show pat ++ ")" - show (VState f) = show $ f Map.empty - show (VList vs) = show $ map show vs + show (VState f) = show $ f Map.empty + show (VList vs) = show $ map show vs instance {-# OVERLAPPING #-} Show ValueMap where show m = intercalate ", " $ map (\(name, v) -> name ++ ": " ++ show v) $ Map.toList m @@ -195,7 +197,7 @@ draw pat = Render 1 s (intercalate "\n" $ map (('|' :) .drawLevel) ls) drawLevel [] = replicate s '.' drawLevel (e:es) = map f $ take s $ zip (drawLevel es ++ repeat '.') (drawEvent e ++ repeat '.') f ('.', x) = x - f (x, _) = x + f (x, _) = x drawEvent :: Event Char -> String drawEvent ev = replicate (floor $ rs * evStart) '.' ++ (value ev:replicate (floor (rs * (evStop - evStart)) - 1) '-') diff --git a/src/Sound/Tidal/Stream.hs b/src/Sound/Tidal/Stream.hs index 725a51b68..bba195c5c 100644 --- a/src/Sound/Tidal/Stream.hs +++ b/src/Sound/Tidal/Stream.hs @@ -29,7 +29,7 @@ module Sound.Tidal.Stream (module Sound.Tidal.Stream) where import Control.Applicative ((<|>)) import Control.Concurrent -import Control.Concurrent.MVar +import Control.Concurrent.MVar () import qualified Control.Exception as E import Control.Monad (forM_, when) import Data.Coerce (coerce) diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs index f7b3890c3..4ea4e08f3 100644 --- a/src/Sound/Tidal/UI.hs +++ b/src/Sound/Tidal/UI.hs @@ -680,7 +680,7 @@ signifies: @(Int -> Bool)@, a function that takes a whole number and returns either @True@ or @False@. -} ifp :: (Int -> Bool) -> (Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -ifp test f1 f2 p = splitQueries $ p {query = q} +ifp test f1 f2 p = splitQueries $ p {query = q, pureValue = Nothing} where q a | test (floor $ start $ arc a) = query (f1 p) a | otherwise = query (f2 p) a @@ -1492,7 +1492,7 @@ enclosingArc as = Arc (minimum (map start as)) (maximum (map stop as)) -} stretch :: Pattern a -> Pattern a -- TODO - should that be whole or part? -stretch p = splitQueries $ p {query = q} +stretch p = splitQueries $ p {query = q, pureValue = Nothing} where q st = query (zoomArc (cycleArc $ enclosingArc $ map wholeOrPart $ query p (st {arc = Arc (sam s) (nextSam s)})) p) st where s = start $ arc st @@ -1906,7 +1906,7 @@ spaceOut xs p = _slow (toRational $ sum xs) $ stack $ map (`compressArc` p) spac > d1 $ n ("[0,4,7] [-12,-8,-5]") # s "superpiano" # sustain 2 -} flatpat :: Pattern [a] -> Pattern a -flatpat p = p {query = concatMap (\(Event c b b' xs) -> map (Event c b b') xs) . query p} +flatpat p = p {query = concatMap (\(Event c b b' xs) -> map (Event c b b') xs) . query p, pureValue = Nothing} {- | @layer@ takes a list of 'Pattern'-returning functions and a seed element, stacking the result of applying the seed element to each function in the list. @@ -2037,7 +2037,7 @@ rolledWith t = withEvents aux -- | @fill@ 'fills in' gaps in one pattern with events from another. For example @fill "bd" "cp ~ cp"@ would result in the equivalent of `"~ bd ~"`. This only finds gaps in a resulting pattern, in other words @"[bd ~, sn]"@ doesn't contain any gaps (because @sn@ covers it all), and @"bd ~ ~ sn"@ only contains a single gap that bridges two steps. fill :: Pattern a -> Pattern a -> Pattern a -fill p' p = struct (splitQueries $ p {query = q}) p' +fill p' p = struct (splitQueries $ p {query = q, pureValue = Nothing}) p' where q st = removeTolerance (s,e) $ invert (s-tolerance, e+tolerance) $ query p (st {arc = (s-tolerance, e+tolerance)}) where (s,e) = arc st @@ -2764,7 +2764,7 @@ swap things p = filterJust $ (`lookup` things) <$> p > # s "gtr" -} snowball :: Int -> (Pattern a -> Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -snowball depth combinationFunction f pattern = cat $ take depth $ scanl combinationFunction pattern $ drop 1 $ iterate f pattern +snowball depth combinationFunction f pat = cat $ take depth $ scanl combinationFunction pat $ drop 1 $ iterate f pat {- | Applies a function to a pattern and cats the resulting pattern, then continues @@ -2778,7 +2778,7 @@ snowball depth combinationFunction f pattern = cat $ take depth $ scanl combinat > # s "gtr" -} soak :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -soak depth f pattern = cat $ take depth $ iterate f pattern +soak depth f pat = cat $ take depth $ iterate f pat -- | @construct n p@ breaks @p@ into pieces and then reassembles them -- so that it fits into @n@ steps. @@ -2828,7 +2828,7 @@ squeeze _ [] = silence squeeze ipat pats = squeezeJoin $ (pats !!!) <$> ipat squeezeJoinUp :: Pattern (ControlPattern) -> ControlPattern -squeezeJoinUp pp = pp {query = q} +squeezeJoinUp pp = pp {query = q, pureValue = Nothing} where q st = concatMap (f st) (query (filterDigital pp) st) f st (Event c (Just w) p v) = mapMaybe (munge c w p) $ query (compressArc (cycleArc w) (v |* P.speed (pure $ fromRational $ 1/(stop w - start w)))) st {arc = p} diff --git a/test/Sound/Tidal/ExceptionsTest.hs b/test/Sound/Tidal/ExceptionsTest.hs index 3a61ba17a..0934111b4 100644 --- a/test/Sound/Tidal/ExceptionsTest.hs +++ b/test/Sound/Tidal/ExceptionsTest.hs @@ -16,7 +16,7 @@ run = describe "NFData, forcing and catching exceptions" $ do describe "instance NFData (Pattern a)" $ do it "rnf forces argument" $ do - evaluate (rnf (Pattern undefined Nothing :: Pattern ())) + evaluate (rnf (Pattern undefined Nothing Nothing :: Pattern ())) `shouldThrow` anyException From 5c28e1a7dae4d3a4e2037567f46ec5d36ff6daf8 Mon Sep 17 00:00:00 2001 From: Alex McLean Date: Tue, 9 Apr 2024 15:16:49 +0100 Subject: [PATCH 04/46] preserve tactus from toplevel mininotation sequence --- src/Sound/Tidal/Core.hs | 7 +++++-- src/Sound/Tidal/Pattern.hs | 7 +++++-- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/src/Sound/Tidal/Core.hs b/src/Sound/Tidal/Core.hs index 69633be44..6ac6b242e 100644 --- a/src/Sound/Tidal/Core.hs +++ b/src/Sound/Tidal/Core.hs @@ -312,6 +312,7 @@ append a b = cat [a,b] -} cat :: [Pattern a] -> Pattern a cat [] = silence +cat (p:[]) = p cat ps = pattern q where n = length ps q st = concatMap (f st) $ arcCyclesZW (arc st) @@ -349,7 +350,8 @@ fastappend = fastAppend > d1 $ fastcat [sound "bd*2 sn", sound "jvbass*3", sound "drum*2", sound "ht mt"] -} fastCat :: [Pattern a] -> Pattern a -fastCat ps = _fast (toTime $ length ps) $ cat ps +fastCat (p:[]) = p +fastCat ps = _fast (toTime $ length ps) $ cat ps -- | Alias for @fastCat@ fastcat :: [Pattern a] -> Pattern a @@ -371,7 +373,8 @@ fastcat = fastCat -} timeCat :: [(Time, Pattern a)] -> Pattern a -timeCat tps = stack $ map (\(s,e,p) -> compressArc (Arc (s/total) (e/total)) p) $ arrange 0 tps +timeCat ((_,p):[]) = p +timeCat tps = setTactus total $ stack $ map (\(s,e,p) -> compressArc (Arc (s/total) (e/total)) p) $ arrange 0 tps where total = sum $ map fst tps arrange :: Time -> [(Time, Pattern a)] -> [(Time, Time, Pattern a)] arrange _ [] = [] diff --git a/src/Sound/Tidal/Pattern.hs b/src/Sound/Tidal/Pattern.hs index 6f7da9e7c..e7b822498 100644 --- a/src/Sound/Tidal/Pattern.hs +++ b/src/Sound/Tidal/Pattern.hs @@ -65,6 +65,9 @@ pattern f = Pattern f Nothing Nothing setTactus :: Rational -> Pattern a -> Pattern a setTactus r p = p {tactus = Just r} +keepMeta :: Pattern a -> Pattern a -> Pattern a +keepMeta from to = to {tactus = tactus from, pureValue = pureValue from} + -- type StateMap = Map.Map String (Pattern Value) type ControlPattern = Pattern ValueMap @@ -731,10 +734,10 @@ combineContexts :: [Context] -> Context combineContexts = Context . concatMap contextPosition setContext :: Context -> Pattern a -> Pattern a -setContext c pat = withEvents (map (\e -> e {context = c})) pat +setContext c pat = keepMeta pat $ withEvents (map (\e -> e {context = c})) pat withContext :: (Context -> Context) -> Pattern a -> Pattern a -withContext f pat = withEvents (map (\e -> e {context = f $ context e})) pat +withContext f pat = keepMeta pat $ withEvents (map (\e -> e {context = f $ context e})) pat -- A hack to add to manipulate source code to add calls to -- 'deltaContext' around strings, so events from mininotation know From 037fbb08df3d65ac74b85a27cd20a6534fc7c61d Mon Sep 17 00:00:00 2001 From: Alex McLean Date: Tue, 9 Apr 2024 15:22:42 +0100 Subject: [PATCH 05/46] stepcat --- src/Sound/Tidal/Core.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Sound/Tidal/Core.hs b/src/Sound/Tidal/Core.hs index 6ac6b242e..9705bb7d4 100644 --- a/src/Sound/Tidal/Core.hs +++ b/src/Sound/Tidal/Core.hs @@ -423,6 +423,11 @@ pattern to multiple patterns at once: stack :: [Pattern a] -> Pattern a stack = foldr overlay silence +-- ** stepwise things + +stepcat :: [Pattern a] -> Pattern a +stepcat pats = timecat $ map (\pat -> (fromMaybe 1 $ tactus pat, pat)) pats + -- ** Manipulating time -- | Shifts a pattern back in time by the given amount, expressed in cycles From d696aa1786c135b220106402888ed442bf1d2ac2 Mon Sep 17 00:00:00 2001 From: alex Date: Wed, 10 Apr 2024 10:49:54 +0100 Subject: [PATCH 06/46] add stepadd/stepsub, and use pure values in patternification where possible --- src/Sound/Tidal/Core.hs | 23 ++++++++++++++++++++++- src/Sound/Tidal/Pattern.hs | 11 ++++++++++- 2 files changed, 32 insertions(+), 2 deletions(-) diff --git a/src/Sound/Tidal/Core.hs b/src/Sound/Tidal/Core.hs index 9705bb7d4..420266b2c 100644 --- a/src/Sound/Tidal/Core.hs +++ b/src/Sound/Tidal/Core.hs @@ -428,6 +428,27 @@ stack = foldr overlay silence stepcat :: [Pattern a] -> Pattern a stepcat pats = timecat $ map (\pat -> (fromMaybe 1 $ tactus pat, pat)) pats +_stepadd :: Rational -> Pattern a -> Pattern a +-- raise error? +_stepadd _ pat@(Pattern _ Nothing _) = pat +_stepadd r pat@(Pattern _ (Just t) _) + | r == 0 = nothing + | (abs r) >= t = pat + | r < 0 = zoom (1-((abs r)/t),1) pat + | otherwise = zoom (0, (r/t)) pat + +stepadd :: Pattern Rational -> Pattern a -> Pattern a +stepadd = tParam _stepadd + +_stepsub :: Rational -> Pattern a -> Pattern a +_stepsub _ pat@(Pattern _ Nothing _) = pat +_stepsub r pat@(Pattern _ (Just t) _) | r >= t = nothing + | r < 0 = _stepadd (0- (t+r)) pat + | otherwise = _stepadd (t-r) pat + +stepsub :: Pattern Rational -> Pattern a -> Pattern a +stepsub = tParam _stepsub + -- ** Manipulating time -- | Shifts a pattern back in time by the given amount, expressed in cycles @@ -485,7 +506,7 @@ zoom :: (Time, Time) -> Pattern a -> Pattern a zoom (s,e) = zoomArc (Arc s e) zoomArc :: Arc -> Pattern a -> Pattern a -zoomArc (Arc s e) p = splitQueries $ +zoomArc (Arc s e) p = withTactus (*d) $ splitQueries $ withResultArc (mapCycle ((/d) . subtract s)) $ withQueryArc (mapCycle ((+s) . (*d))) p where d = e-s diff --git a/src/Sound/Tidal/Pattern.hs b/src/Sound/Tidal/Pattern.hs index e7b822498..81723c3a4 100644 --- a/src/Sound/Tidal/Pattern.hs +++ b/src/Sound/Tidal/Pattern.hs @@ -65,6 +65,9 @@ pattern f = Pattern f Nothing Nothing setTactus :: Rational -> Pattern a -> Pattern a setTactus r p = p {tactus = Just r} +withTactus :: (Rational -> Rational) -> Pattern a -> Pattern a +withTactus f p = p {tactus = f <$> tactus p} + keepMeta :: Pattern a -> Pattern a -> Pattern a keepMeta from to = to {tactus = tactus from, pureValue = pureValue from} @@ -424,6 +427,9 @@ empty = Pattern {query = const [], tactus = Just 1, pureValue = Nothing} silence :: Pattern a silence = empty +nothing :: Pattern a +nothing = empty {tactus = Just 0} + queryArc :: Pattern a -> Arc -> [Event a] queryArc p a = query p $ State a Map.empty @@ -717,12 +723,15 @@ playFor s e pat = pattern $ \st -> maybe [] (\a -> query pat (st {arc = a})) $ s -- ** Temporal parameter helpers tParam :: (t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a -tParam f tv p = innerJoin $ (`f` p) <$> tv +tParam f (Pattern _ _ (Just a)) b = f a b +tParam f pa p = innerJoin $ (`f` p) <$> pa tParam2 :: (a -> b -> c -> Pattern d) -> Pattern a -> Pattern b -> c -> Pattern d +tParam2 f (Pattern _ _ (Just a)) (Pattern _ _ (Just b)) c = f a b c tParam2 f a b p = innerJoin $ (\x y -> f x y p) <$> a <*> b tParam3 :: (a -> b -> c -> Pattern d -> Pattern e) -> (Pattern a -> Pattern b -> Pattern c -> Pattern d -> Pattern e) +tParam3 f (Pattern _ _ (Just a)) (Pattern _ _ (Just b)) (Pattern _ _ (Just c)) d = f a b c d tParam3 f a b c p = innerJoin $ (\x y z -> f x y z p) <$> a <*> b <*> c tParamSqueeze :: (a -> Pattern b -> Pattern c) -> (Pattern a -> Pattern b -> Pattern c) From aeebac3f15971648a2ad3979f705db48e0a342f2 Mon Sep 17 00:00:00 2001 From: alex Date: Wed, 10 Apr 2024 12:04:14 +0100 Subject: [PATCH 07/46] rename step to steppify and steps to steppifies. Add new 'steps' that adjusts pattern to fit the given tactus --- src/Sound/Tidal/Core.hs | 8 ++++++++ src/Sound/Tidal/Pattern.hs | 17 ++++++++++++++--- src/Sound/Tidal/UI.hs | 22 +++++++++++----------- 3 files changed, 33 insertions(+), 14 deletions(-) diff --git a/src/Sound/Tidal/Core.hs b/src/Sound/Tidal/Core.hs index 420266b2c..95195fe7c 100644 --- a/src/Sound/Tidal/Core.hs +++ b/src/Sound/Tidal/Core.hs @@ -449,6 +449,14 @@ _stepsub r pat@(Pattern _ (Just t) _) | r >= t = nothing stepsub :: Pattern Rational -> Pattern a -> Pattern a stepsub = tParam _stepsub +_steplastof :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +_steplastof i f pat | i <= 1 = pat + | otherwise = stepcat $ (take (i-1) $ repeat pat) ++ [f pat] + +steplastof :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +steplastof (Pattern _ _ (Just i)) f pat = _steplastof i f pat +steplastof tp f p = innerJoin $ (\t -> _steplastof t f p) <$> tp + -- ** Manipulating time -- | Shifts a pattern back in time by the given amount, expressed in cycles diff --git a/src/Sound/Tidal/Pattern.hs b/src/Sound/Tidal/Pattern.hs index 81723c3a4..968151068 100644 --- a/src/Sound/Tidal/Pattern.hs +++ b/src/Sound/Tidal/Pattern.hs @@ -68,9 +68,20 @@ setTactus r p = p {tactus = Just r} withTactus :: (Rational -> Rational) -> Pattern a -> Pattern a withTactus f p = p {tactus = f <$> tactus p} +_steps :: Rational -> Pattern a -> Pattern a +_steps target p@(Pattern _ (Just t) _) = setTactus target $ _fast (target / t) p +-- raise error? +_steps _ p = p + +steps :: Pattern Rational -> Pattern a -> Pattern a +steps = tParam _steps + keepMeta :: Pattern a -> Pattern a -> Pattern a keepMeta from to = to {tactus = tactus from, pureValue = pureValue from} +keepTactus :: Pattern a -> Pattern a -> Pattern a +keepTactus from to = to {tactus = tactus from} + -- type StateMap = Map.Map String (Pattern Value) type ControlPattern = Pattern ValueMap @@ -538,7 +549,7 @@ second half: > d1 $ fast "2 4" $ sound "bd sn kurt cp" -} fast :: Pattern Time -> Pattern a -> Pattern a -fast = tParam _fast +fast t pat = keepTactus pat $ tParam _fast t pat {-| @fastSqueeze@ speeds up a pattern by a time pattern given as input, squeezing the resulting pattern inside one cycle and playing the original @@ -582,7 +593,7 @@ density = fast _fast :: Time -> Pattern a -> Pattern a _fast rate pat | rate == 0 = silence | rate < 0 = rev $ _fast (negate rate) pat - | otherwise = withResultTime (/ rate) $ withQueryTime (* rate) pat + | otherwise = keepTactus pat $ withResultTime (/ rate) $ withQueryTime (* rate) pat {-| Slow down a pattern by the given time pattern. @@ -655,7 +666,7 @@ rotR t = rotL (negate t) -} rev :: Pattern a -> Pattern a rev p = - splitQueries $ p { + keepMeta p $ splitQueries $ p { query = \st -> map makeWholeAbsolute $ mapParts (mirrorArc (midCycle $ arc st)) $ map makeWholeRelative diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs index 4ea4e08f3..3661d83f4 100644 --- a/src/Sound/Tidal/UI.hs +++ b/src/Sound/Tidal/UI.hs @@ -2414,29 +2414,29 @@ offadd :: Num a => Pattern Time -> Pattern a -> Pattern a -> Pattern a offadd tp pn p = off tp (+pn) p {- | - @step@ acts as a kind of simple step-sequencer using strings. For example, - @step "sn" "x x 12"@ is equivalent to the pattern of strings given by @"sn ~ - sn ~ sn:1 sn:2 ~"@. @step@ substitutes the given string for each @x@, for each number + @steppify@ acts as a kind of simple step-sequencer using strings. For example, + @steppify "sn" "x x 12"@ is equivalent to the pattern of strings given by @"sn ~ + sn ~ sn:1 sn:2 ~"@. @steppify@ substitutes the given string for each @x@, for each number it substitutes the string followed by a colon and the number, and for everything else it puts in a rest. - In other words, @step@ generates a pattern of strings in exactly the syntax you’d want for selecting samples and that can be fed directly into the 's' function. + In other words, @steppify@ generates a pattern of strings in exactly the syntax you’d want for selecting samples and that can be fed directly into the 's' function. - > d1 $ s (step "sn" "x x 12 ") + > d1 $ s (steppify "sn" "x x 12 ") -} -step :: String -> String -> Pattern String -step s cs = fastcat $ map f cs +steppify :: String -> String -> Pattern String +steppify s cs = fastcat $ map f cs where f c | c == 'x' = pure s | isDigit c = pure $ s ++ ":" ++ [c] | otherwise = silence -{- | @steps@ is like @step@ but it takes a list of pairs, like step would, and +{- | @stepifies@ is like @steppify@ but it takes a list of pairs, like steppify would, and it plays them all simultaneously. - > d1 $ s (steps [("cp","x x x x x x"),("bd", "xxxx")]) + > d1 $ s (stepifies [("cp","x x x x x x"),("bd", "xxxx")]) -} -steps :: [(String, String)] -> Pattern String -steps = stack . map (uncurry step) +stepifies :: [(String, String)] -> Pattern String +stepifies = stack . map (uncurry steppify) {- | like `step`, but allows you to specify an array of strings to use for @0,1,2...@ For example, From 410e4a5d0d84138d2834dd7566d472fad93b7c03 Mon Sep 17 00:00:00 2001 From: alex Date: Wed, 10 Apr 2024 17:37:04 +0100 Subject: [PATCH 08/46] preserve/calculate tactus correctly across applicatives --- src/Sound/Tidal/Pattern.hs | 10 +++++----- src/Sound/Tidal/Time.hs | 15 ++++++++++----- src/Sound/Tidal/UI.hs | 2 +- 3 files changed, 16 insertions(+), 11 deletions(-) diff --git a/src/Sound/Tidal/Pattern.hs b/src/Sound/Tidal/Pattern.hs index 968151068..e13a95559 100644 --- a/src/Sound/Tidal/Pattern.hs +++ b/src/Sound/Tidal/Pattern.hs @@ -79,7 +79,7 @@ steps = tParam _steps keepMeta :: Pattern a -> Pattern a -> Pattern a keepMeta from to = to {tactus = tactus from, pureValue = pureValue from} -keepTactus :: Pattern a -> Pattern a -> Pattern a +keepTactus :: Pattern a -> Pattern b -> Pattern b keepTactus from to = to {tactus = tactus from} -- type StateMap = Map.Map String (Pattern Value) @@ -121,19 +121,19 @@ instance Applicative Pattern where -- > (⅓>½)-⅔|11 -- > ⅓-(½>⅔)|12 -- > (⅔>1)|102 - (<*>) = applyPatToPatBoth + (<*>) a b = (applyPatToPatBoth a b) {tactus = lcmr <$> tactus a <*> tactus b } -- | Like @<*>@, but the "wholes" come from the left (<*) :: Pattern (a -> b) -> Pattern a -> Pattern b -(<*) = applyPatToPatLeft +(<*) a b = keepTactus a $ applyPatToPatLeft a b -- | Like @<*>@, but the "wholes" come from the right (*>) :: Pattern (a -> b) -> Pattern a -> Pattern b -(*>) = applyPatToPatRight +(*>) a b = keepTactus b $ applyPatToPatRight a b -- | Like @<*>@, but the "wholes" come from the left (<<*) :: Pattern (a -> b) -> Pattern a -> Pattern b -(<<*) = applyPatToPatSqueeze +(<<*) a b = (applyPatToPatSqueeze a b) {tactus = (*) <$> tactus a <*> tactus b } infixl 4 <*, *>, <<* applyPatToPat :: (Maybe Arc -> Maybe Arc -> Maybe (Maybe Arc)) -> Pattern (a -> b) -> Pattern a -> Pattern b diff --git a/src/Sound/Tidal/Time.hs b/src/Sound/Tidal/Time.hs index 8f0aa9e01..da3dfd605 100644 --- a/src/Sound/Tidal/Time.hs +++ b/src/Sound/Tidal/Time.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} module Sound.Tidal.Time where -import Control.Applicative -import GHC.Generics -import Control.DeepSeq (NFData) +import Control.Applicative +import Control.DeepSeq (NFData) +import Data.Ratio +import GHC.Generics -- | Time is rational type Time = Rational @@ -13,7 +14,7 @@ type Time = Rational -- | An arc of time, with a start time (or onset) and a stop time (or offset) data ArcF a = Arc { start :: a - , stop :: a + , stop :: a } deriving (Eq, Ord, Functor, Show, Generic) type Arc = ArcF Time @@ -152,3 +153,7 @@ mapCycle f (Arc s e) = Arc (sam' + f (s - sam')) (sam' + f (e - sam')) -- the arc represented by @a@. isIn :: Arc -> Time -> Bool isIn (Arc s e) t = t >= s && t < e + +-- | Returns the lowest common multiple of two rational numbers +lcmr :: Rational -> Rational -> Rational +lcmr a b = lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b) diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs index 3661d83f4..c232cf1a7 100644 --- a/src/Sound/Tidal/UI.hs +++ b/src/Sound/Tidal/UI.hs @@ -521,7 +521,7 @@ There is also `iter'`, which shifts the pattern in the opposite direction. -} iter :: Pattern Int -> Pattern c -> Pattern c -iter = tParam _iter +iter a pat = keepTactus pat $ tParam _iter a pat _iter :: Int -> Pattern a -> Pattern a _iter n p = slowcat $ map (\i -> (fromIntegral i % fromIntegral n) `rotL` p) [0 .. (n-1)] From 17d72dc3647bdc4b526523a4720e6d6cc6b40d4d Mon Sep 17 00:00:00 2001 From: alex Date: Wed, 10 Apr 2024 23:09:39 +0100 Subject: [PATCH 09/46] fix tidal-parse --- tidal-parse/src/Sound/Tidal/Parse.hs | 25 +++++++++++++++---------- 1 file changed, 15 insertions(+), 10 deletions(-) diff --git a/tidal-parse/src/Sound/Tidal/Parse.hs b/tidal-parse/src/Sound/Tidal/Parse.hs index f4976e7f6..d67630680 100644 --- a/tidal-parse/src/Sound/Tidal/Parse.hs +++ b/tidal-parse/src/Sound/Tidal/Parse.hs @@ -1,18 +1,23 @@ -{-# LANGUAGE TemplateHaskell, FlexibleInstances, FlexibleContexts, ScopedTypeVariables, OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Sound.Tidal.Parse (parseTidal) where -import Language.Haskellish as Haskellish import Control.Applicative -import Data.Bifunctor import Control.Monad.Except +import Data.Bifunctor import Data.Char -import Data.List (dropWhileEnd) +import Data.List (dropWhileEnd) import qualified Data.Text +import Language.Haskellish as Haskellish -import Sound.Tidal.Context (Pattern,ValueMap,ControlPattern,Enumerable,Time) -import qualified Sound.Tidal.Context as T -import qualified Sound.Tidal.Chords as T +import qualified Sound.Tidal.Chords as T +import Sound.Tidal.Context (ControlPattern, Enumerable, Pattern, + Time, ValueMap) +import qualified Sound.Tidal.Context as T import Sound.Tidal.Parse.TH type H = Haskellish () @@ -443,7 +448,7 @@ instance Parse (String -> Pattern String) where (parser :: H ([String] -> String -> Pattern String )) <*> parser instance Parse ([(String, String)] -> Pattern String) where - parser = $(fromTidal "steps") + parser = $(fromTidal "stepifies") instance Parse (String -> String) where parser = (parser :: H (String -> String -> String)) <*!> parser @@ -828,10 +833,10 @@ pDouble_tupleADouble_p :: Parse a => H (Pattern Double -> [(a,Double)] -> Patter pDouble_tupleADouble_p = $(fromTidal "wchooseBy") instance Parse (String -> String -> Pattern String) where - parser = $(fromTidal "step") + parser = $(fromTidal "stepify") instance Parse ([String] -> String -> Pattern String) where - parser = $(fromTidal "step'") + parser = $(fromTidal "stepify'") instance Parse (String -> String -> String) where parser = (parser :: H (Int -> String -> String -> String)) <*!> parser From ade3be36dabf139613a5d9e676c53d017a288081 Mon Sep 17 00:00:00 2001 From: alex Date: Wed, 10 Apr 2024 23:09:44 +0100 Subject: [PATCH 10/46] fix tidal-parse --- src/Sound/Tidal/UI.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs index c232cf1a7..dd5259809 100644 --- a/src/Sound/Tidal/UI.hs +++ b/src/Sound/Tidal/UI.hs @@ -2438,10 +2438,10 @@ steppify s cs = fastcat $ map f cs stepifies :: [(String, String)] -> Pattern String stepifies = stack . map (uncurry steppify) -{- | like `step`, but allows you to specify an array of strings to use for @0,1,2...@ +{- | like `stepify`, but allows you to specify an array of strings to use for @0,1,2...@ For example, - > d1 $ s (step' ["superpiano","supermandolin"] "0 1 000 1") + > d1 $ s (stepify' ["superpiano","supermandolin"] "0 1 000 1") > # sustain 4 # n 0 is equivalent to @@ -2449,8 +2449,8 @@ stepifies = stack . map (uncurry steppify) > d1 $ s "superpiano ~ supermandolin ~ superpiano!3 ~ supermandolin" > # sustain 4 # n 0 -} -step' :: [String] -> String -> Pattern String -step' ss cs = fastcat $ map f cs +stepify' :: [String] -> String -> Pattern String +stepify' ss cs = fastcat $ map f cs where f c | c == 'x' = pure $ head ss | isDigit c = pure $ ss !! digitToInt c | otherwise = silence From 08518ba754d407f2f85a2c5a22960cec00d8a9a7 Mon Sep 17 00:00:00 2001 From: alex Date: Wed, 10 Apr 2024 23:34:15 +0100 Subject: [PATCH 11/46] fix warns --- src/Sound/Tidal/Pattern.hs | 8 ++++---- src/Sound/Tidal/Stream.hs | 14 ++++++++------ src/Sound/Tidal/UI.hs | 5 +++-- 3 files changed, 15 insertions(+), 12 deletions(-) diff --git a/src/Sound/Tidal/Pattern.hs b/src/Sound/Tidal/Pattern.hs index e13a95559..49229d9fc 100644 --- a/src/Sound/Tidal/Pattern.hs +++ b/src/Sound/Tidal/Pattern.hs @@ -41,7 +41,7 @@ import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromJust, isJust, mapMaybe) import Data.Typeable (Typeable) import Data.Word (Word8) -import GHC.Generics +import GHC.Generics (Generic) import Sound.Tidal.Time @@ -267,13 +267,13 @@ _trigJoin cycleZero pat_of_pats = pattern q where q st = catMaybes $ concatMap - (\(Event oc (Just jow) op ov) -> + (\(Event oc jow op ov) -> map (\(Event ic (iw) ip iv) -> - do w <- subMaybeArc (Just jow) iw + do w <- subMaybeArc jow iw p <- subArc op ip return $ Event (combineContexts [ic, oc]) w p iv ) - $ query (((if cycleZero then id else cyclePos) $ start jow) `rotR` ov) st + $ query (((if cycleZero then id else cyclePos) $ start (fromJust jow)) `rotR` ov) st ) (query (filterDigital pat_of_pats) st) diff --git a/src/Sound/Tidal/Stream.hs b/src/Sound/Tidal/Stream.hs index bba195c5c..ff30c0ff3 100644 --- a/src/Sound/Tidal/Stream.hs +++ b/src/Sound/Tidal/Stream.hs @@ -361,7 +361,7 @@ toOSC busses pe osc@(OSC _ _) -- (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 + playmap' = Map.union (Map.mapKeys tail $ Map.map (\v -> VS ('c':(show $ toBus $ fromMaybe 0 $ getI v))) busmap) playmap val = value . peEvent -- Only events that start within the current nowArc are included playmsg | peHasOnset pe = do @@ -382,11 +382,13 @@ toOSC busses pe osc@(OSC _ _) 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] - ) + (\(k, b) -> do k' <- if (not $ null k) && head k == '^' then Just (tail k) else Nothing + v <- Map.lookup k' playmap + bi <- getI b + return $ (tsPart, + True, -- bus message ? + O.Message "/c_set" [O.int32 bi, toDatum v] + ) ) (Map.toList busmap) where diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs index dd5259809..2a0eb611c 100644 --- a/src/Sound/Tidal/UI.hs +++ b/src/Sound/Tidal/UI.hs @@ -1308,7 +1308,7 @@ randArcs n = -- TODO - what does this do? Something for @stripe@ .. randStruct :: Int -> Pattern Int -randStruct n = splitQueries $ Pattern {query = f} +randStruct n = splitQueries $ Pattern f Nothing Nothing where f st = map (\(a,b,c) -> Event (Context []) (Just a) (fromJust b) c) $ filter (\(_,x,_) -> isJust x) as where as = map (\(i, Arc s' e') -> (Arc (s' + sam s) (e' + sam s), @@ -1862,7 +1862,8 @@ ur t outer_p ps fs = _slow t $ unwrap $ adjust <$> timedValues (getPat . split < transform _ _ = id transform' str (Arc s e) p = s `rotR` inside (pure $ 1/(e-s)) (matchF str) p matchF str = fromMaybe id $ lookup str fs - timedValues = withEvent (\(Event c (Just a) a' v) -> Event c (Just a) a' (a,v)) . filterDigital + timedValues = filterJust . withEvent (\(Event c ma a' v) -> Event c ma a' (ma >>= \a -> Just (a,v)) + ) . filterDigital {- | A simpler version of 'ur' that just provides name-value bindings that are reflected in the provided pattern. From 71ecdad62ca82fbeec167fe7e2bf579725f93f47 Mon Sep 17 00:00:00 2001 From: alex Date: Wed, 10 Apr 2024 23:46:41 +0100 Subject: [PATCH 12/46] steppify -> stepify --- src/Sound/Tidal/UI.hs | 18 +++++++++--------- tidal-listener/tidal-listener.cabal | 2 +- tidal-parse/tidal-parse.cabal | 2 +- tidal.cabal | 2 +- 4 files changed, 12 insertions(+), 12 deletions(-) diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs index 2a0eb611c..4454c1426 100644 --- a/src/Sound/Tidal/UI.hs +++ b/src/Sound/Tidal/UI.hs @@ -2415,29 +2415,29 @@ offadd :: Num a => Pattern Time -> Pattern a -> Pattern a -> Pattern a offadd tp pn p = off tp (+pn) p {- | - @steppify@ acts as a kind of simple step-sequencer using strings. For example, - @steppify "sn" "x x 12"@ is equivalent to the pattern of strings given by @"sn ~ - sn ~ sn:1 sn:2 ~"@. @steppify@ substitutes the given string for each @x@, for each number + @stepify@ acts as a kind of simple step-sequencer using strings. For example, + @stepify "sn" "x x 12"@ is equivalent to the pattern of strings given by @"sn ~ + sn ~ sn:1 sn:2 ~"@. @stepify@ substitutes the given string for each @x@, for each number it substitutes the string followed by a colon and the number, and for everything else it puts in a rest. - In other words, @steppify@ generates a pattern of strings in exactly the syntax you’d want for selecting samples and that can be fed directly into the 's' function. + In other words, @stepify@ generates a pattern of strings in exactly the syntax you’d want for selecting samples and that can be fed directly into the 's' function. - > d1 $ s (steppify "sn" "x x 12 ") + > d1 $ s (stepify "sn" "x x 12 ") -} -steppify :: String -> String -> Pattern String -steppify s cs = fastcat $ map f cs +stepify :: String -> String -> Pattern String +stepify s cs = fastcat $ map f cs where f c | c == 'x' = pure s | isDigit c = pure $ s ++ ":" ++ [c] | otherwise = silence -{- | @stepifies@ is like @steppify@ but it takes a list of pairs, like steppify would, and +{- | @stepifies@ is like @stepify@ but it takes a list of pairs, like stepify would, and it plays them all simultaneously. > d1 $ s (stepifies [("cp","x x x x x x"),("bd", "xxxx")]) -} stepifies :: [(String, String)] -> Pattern String -stepifies = stack . map (uncurry steppify) +stepifies = stack . map (uncurry stepify) {- | like `stepify`, but allows you to specify an array of strings to use for @0,1,2...@ For example, diff --git a/tidal-listener/tidal-listener.cabal b/tidal-listener/tidal-listener.cabal index 464d8caa8..c97a3f71e 100644 --- a/tidal-listener/tidal-listener.cabal +++ b/tidal-listener/tidal-listener.cabal @@ -26,7 +26,7 @@ library exceptions, deepseq, optparse-applicative, - tidal >= 1.9.3 && < 1.10, + tidal >= 1.10 && < 1.11, hosc >= 0.20 && < 0.21, hint, network diff --git a/tidal-parse/tidal-parse.cabal b/tidal-parse/tidal-parse.cabal index 2c7cfa8b1..3d61fbf27 100644 --- a/tidal-parse/tidal-parse.cabal +++ b/tidal-parse/tidal-parse.cabal @@ -30,7 +30,7 @@ library Build-depends: base >=4.8 && <5 - , tidal >= 1.8 && <1.10 + , tidal >= 1.10 && <1.11 , transformers >= 0.5 && < 0.7 , template-haskell , haskellish >= 0.3.2 && < 0.4 diff --git a/tidal.cabal b/tidal.cabal index 3283dcb1d..5118d1519 100644 --- a/tidal.cabal +++ b/tidal.cabal @@ -1,7 +1,7 @@ cabal-version: 2.0 name: tidal -version: 1.9.5 +version: 1.10.0 synopsis: Pattern language for improvised music description: Tidal is a domain specific language for live coding patterns. homepage: http://tidalcycles.org/ From cb0d99439ddfe95325eb4837ee0b290d22e60a99 Mon Sep 17 00:00:00 2001 From: alex Date: Thu, 11 Apr 2024 09:20:02 +0100 Subject: [PATCH 13/46] stepify -> sseq, add ps prefix to PlayState fields --- src/Sound/Tidal/Stream/Process.hs | 119 +++++++++--------- src/Sound/Tidal/Stream/Types.hs | 58 ++++----- src/Sound/Tidal/Stream/UI.hs | 47 +++---- src/Sound/Tidal/Transition.hs | 50 ++++---- src/Sound/Tidal/UI.hs | 30 ++--- tidal-parse/src/Sound/Tidal/Parse.hs | 6 +- .../test/Sound/Tidal/TidalParseTest.hs | 30 ++--- 7 files changed, 173 insertions(+), 167 deletions(-) diff --git a/src/Sound/Tidal/Stream/Process.hs b/src/Sound/Tidal/Stream/Process.hs index cb661c3bb..150651a31 100644 --- a/src/Sound/Tidal/Stream/Process.hs +++ b/src/Sound/Tidal/Stream/Process.hs @@ -1,6 +1,11 @@ -{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving, FlexibleContexts, ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} -{-# language DeriveGeneric, StandaloneDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} module Sound.Tidal.Stream.Process where @@ -22,43 +27,43 @@ module Sound.Tidal.Stream.Process where along with this library. If not, see . -} -import Control.Applicative ((<|>)) +import Control.Applicative ((<|>)) import Control.Concurrent.MVar -import Control.Monad (forM_, when) -import Data.Coerce (coerce) -import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust, fromMaybe, catMaybes) -import qualified Control.Exception as E +import qualified Control.Exception as E +import Control.Monad (forM_, when) +import Data.Coerce (coerce) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes, fromJust, fromMaybe) import Foreign.C.Types -import System.IO (hPutStrLn, stderr) +import System.IO (hPutStrLn, stderr) -import qualified Sound.Osc.Fd as O +import qualified Sound.Osc.Fd as O -import Sound.Tidal.Stream.Config -import Sound.Tidal.Core (stack, (#)) +import Data.List (sortOn) +import qualified Sound.Tidal.Clock as Clock +import Sound.Tidal.Core (stack, (#)) import Sound.Tidal.ID -import qualified Sound.Tidal.Link as Link -import qualified Sound.Tidal.Clock as Clock -import Sound.Tidal.Params (pS) +import qualified Sound.Tidal.Link as Link +import Sound.Tidal.Params (pS) import Sound.Tidal.Pattern -import Sound.Tidal.Utils ((!!!)) -import Data.List (sortOn) -import Sound.Tidal.Show () +import Sound.Tidal.Show () +import Sound.Tidal.Stream.Config +import Sound.Tidal.Utils ((!!!)) -import Sound.Tidal.Stream.Types import Sound.Tidal.Stream.Target +import Sound.Tidal.Stream.Types data ProcessedEvent = ProcessedEvent { - peHasOnset :: Bool, - peEvent :: Event ValueMap, - peCps :: Link.BPM, - peDelta :: Link.Micros, - peCycle :: Time, - peOnWholeOrPart :: Link.Micros, + 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 + peOnPart :: Link.Micros, + peOnPartOsc :: O.Time } -- | Query the current pattern (contained in argument @stream :: Stream@) @@ -227,15 +232,15 @@ toData (OSC {args = Named rqrd}) e toData _ _ = Nothing toDatum :: Value -> O.Datum -toDatum (VF x) = O.float x -toDatum (VN x) = O.float x -toDatum (VI x) = O.int32 x -toDatum (VS x) = O.string x -toDatum (VR x) = O.float $ ((fromRational x) :: Double) -toDatum (VB True) = O.int32 (1 :: Int) +toDatum (VF x) = O.float x +toDatum (VN x) = O.float x +toDatum (VI x) = O.int32 x +toDatum (VS x) = O.string x +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 -toDatum _ = error "toDatum: unhandled value" +toDatum (VX xs) = O.Blob $ O.blob_pack xs +toDatum _ = error "toDatum: unhandled value" substitutePath :: String -> ValueMap -> Maybe String substitutePath str cm = parse str @@ -253,28 +258,28 @@ getString :: ValueMap -> String -> Maybe String getString cm s = (simpleShow <$> Map.lookup param cm) <|> defaultValue dflt where (param, dflt) = break (== '=') s simpleShow :: Value -> String - simpleShow (VS str) = str - simpleShow (VI i) = show i - simpleShow (VF f) = show f - simpleShow (VN n) = show n - simpleShow (VR r) = show r - simpleShow (VB b) = show b - simpleShow (VX xs) = show xs - simpleShow (VState _) = show "" + simpleShow (VS str) = str + simpleShow (VI i) = show i + simpleShow (VF f) = show f + simpleShow (VN n) = show n + simpleShow (VR r) = show r + simpleShow (VB b) = show b + simpleShow (VX xs) = show xs + simpleShow (VState _) = show "" simpleShow (VPattern _) = show "" - simpleShow (VList _) = show "" + simpleShow (VList _) = show "" defaultValue :: String -> Maybe String defaultValue ('=':dfltVal) = Just dfltVal - defaultValue _ = Nothing + defaultValue _ = Nothing playStack :: PlayMap -> ControlPattern -playStack pMap = stack . (map pattern) . (filter active) . Map.elems $ pMap +playStack pMap = stack . (map psPattern) . (filter active) . Map.elems $ pMap where active pState = if hasSolo pMap - then solo pState - else not (mute pState) + then psSolo pState + else not (psMute pState) hasSolo :: Map.Map k PlayState -> Bool -hasSolo = (>= 1) . length . filter solo . Map.elems +hasSolo = (>= 1) . length . filter psSolo . Map.elems -- Used for Tempo callback @@ -286,10 +291,10 @@ onSingleTick :: Config -> Clock.ClockRef -> MVar ValueMap -> MVar [Int] -> MVar onSingleTick config clockRef stateMV busMV _ globalFMV cxs listen pat = do ops <- Clock.getZeroedLinkOperations (cClockConfig config) clockRef pMapMV <- newMVar $ Map.singleton "fake" - (PlayState {pattern = pat, - mute = False, - solo = False, - history = [] + (PlayState {psPattern = pat, + psMute = False, + psSolo = False, + psHistory = [] } ) -- The nowArc is a full cycle @@ -304,7 +309,7 @@ updatePattern stream k !t pat = do 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)} + where updatePS (Just playState) = do playState {psPattern = pat', psHistory = pat:(psHistory playState)} updatePS Nothing = PlayState pat' False False [pat'] patControls = Map.singleton patternTimeID (VR t) pat' = withQueryControls (Map.union patControls) @@ -313,7 +318,7 @@ updatePattern stream k !t pat = do setPreviousPatternOrSilence :: MVar PlayMap -> IO () setPreviousPatternOrSilence playMV = modifyMVar_ playMV $ return - . Map.map ( \ pMap -> case history pMap of - _:p:ps -> pMap { pattern = p, history = p:ps } - _ -> pMap { pattern = silence, history = [silence] } + . Map.map ( \ pMap -> case psHistory pMap of + _:p:ps -> pMap { psPattern = p, psHistory = p:ps } + _ -> pMap { psPattern = silence, psHistory = [silence] } ) diff --git a/src/Sound/Tidal/Stream/Types.hs b/src/Sound/Tidal/Stream/Types.hs index f5589f353..31c36d425 100644 --- a/src/Sound/Tidal/Stream/Types.hs +++ b/src/Sound/Tidal/Stream/Types.hs @@ -1,32 +1,32 @@ module Sound.Tidal.Stream.Types where import Control.Concurrent.MVar -import qualified Data.Map.Strict as Map -import Sound.Tidal.Pattern -import Sound.Tidal.Show () +import qualified Data.Map.Strict as Map +import Sound.Tidal.Pattern +import Sound.Tidal.Show () -import qualified Sound.Osc.Fd as O -import qualified Network.Socket as N +import qualified Network.Socket as N +import qualified Sound.Osc.Fd as O -import qualified Sound.Tidal.Clock as Clock +import qualified Sound.Tidal.Clock as Clock -import Sound.Tidal.Stream.Config +import Sound.Tidal.Stream.Config -data Stream = Stream {sConfig :: Config, - sBusses :: MVar [Int], - sStateMV :: MVar ValueMap, +data Stream = Stream {sConfig :: Config, + sBusses :: MVar [Int], + sStateMV :: MVar ValueMap, -- sOutput :: MVar ControlPattern, - sClockRef :: Clock.ClockRef, - sListen :: Maybe O.Udp, - sPMapMV :: MVar PlayMap, + sClockRef :: Clock.ClockRef, + sListen :: Maybe O.Udp, + sPMapMV :: MVar PlayMap, sGlobalFMV :: MVar (ControlPattern -> ControlPattern), - sCxs :: [Cx] + sCxs :: [Cx] } -data Cx = Cx {cxTarget :: Target, - cxUDP :: O.Udp, - cxOSCs :: [OSC], - cxAddr :: N.AddrInfo, +data Cx = Cx {cxTarget :: Target, + cxUDP :: O.Udp, + cxOSCs :: [OSC], + cxAddr :: N.AddrInfo, cxBusAddr :: Maybe N.AddrInfo } @@ -38,13 +38,13 @@ data Schedule = Pre StampStyle | Live deriving (Eq, Show) -data Target = Target {oName :: String, - oAddress :: String, - oPort :: Int, - oBusPort :: Maybe Int, - oLatency :: Double, - oWindow :: Maybe Arc, - oSchedule :: Schedule, +data Target = Target {oName :: String, + oAddress :: String, + oPort :: Int, + oBusPort :: Maybe Int, + oLatency :: Double, + oWindow :: Maybe Arc, + oSchedule :: Schedule, oHandshake :: Bool } deriving Show @@ -59,10 +59,10 @@ data OSC = OSC {path :: String, | OSCContext {path :: String} deriving Show -data PlayState = PlayState {pattern :: ControlPattern, - mute :: Bool, - solo :: Bool, - history :: [ControlPattern] +data PlayState = PlayState {psPattern :: ControlPattern, + psMute :: Bool, + psSolo :: Bool, + psHistory :: [ControlPattern] } deriving Show diff --git a/src/Sound/Tidal/Stream/UI.hs b/src/Sound/Tidal/Stream/UI.hs index 1ebeb4553..41098889e 100644 --- a/src/Sound/Tidal/Stream/UI.hs +++ b/src/Sound/Tidal/Stream/UI.hs @@ -1,22 +1,23 @@ -{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} module Sound.Tidal.Stream.UI where -import Data.Maybe (isJust) -import qualified Data.Map as Map -import qualified Control.Exception as E import Control.Concurrent.MVar -import System.IO (hPutStrLn, stderr) -import System.Random (getStdRandom, randomR) -import qualified Sound.Osc.Fd as O - -import qualified Sound.Tidal.Clock as Clock -import Sound.Tidal.Stream.Types +import qualified Control.Exception as E +import qualified Data.Map as Map +import Data.Maybe (isJust) +import qualified Sound.Osc.Fd as O +import System.IO (hPutStrLn, stderr) +import System.Random (getStdRandom, randomR) + +import qualified Sound.Tidal.Clock as Clock import Sound.Tidal.Stream.Config import Sound.Tidal.Stream.Process import Sound.Tidal.Stream.Target +import Sound.Tidal.Stream.Types -import Sound.Tidal.Pattern import Sound.Tidal.ID +import Sound.Tidal.Pattern streamNudgeAll :: Stream -> Double -> IO () streamNudgeAll s = Clock.setNudge (sClockRef s) @@ -53,9 +54,9 @@ streamList s = do pMap <- readMVar (sPMapMV s) let hs = hasSolo pMap putStrLn $ concatMap (showKV hs) $ Map.toList pMap where showKV :: Bool -> (PatId, PlayState) -> String - showKV True (k, (PlayState {solo = True})) = k ++ " - solo\n" + showKV True (k, (PlayState {psSolo = True})) = k ++ " - solo\n" showKV True (k, _) = "(" ++ k ++ ")\n" - showKV False (k, (PlayState {solo = False})) = k ++ "\n" + showKV False (k, (PlayState {psSolo = False})) = k ++ "\n" showKV False (k, _) = "(" ++ k ++ ") - muted\n" streamReplace :: Stream -> ID -> ControlPattern -> IO () @@ -77,19 +78,19 @@ streamFirst :: Stream -> ControlPattern -> IO () streamFirst stream pat = onSingleTick (sConfig stream) (sClockRef stream) (sStateMV stream) (sBusses stream) (sPMapMV stream) (sGlobalFMV stream) (sCxs stream) (sListen stream) pat streamMute :: Stream -> ID -> IO () -streamMute s k = withPatIds s [k] (\x -> x {mute = True}) +streamMute s k = withPatIds s [k] (\x -> x {psMute = True}) streamMutes :: Stream -> [ID] -> IO () -streamMutes s ks = withPatIds s ks (\x -> x {mute = True}) +streamMutes s ks = withPatIds s ks (\x -> x {psMute = True}) streamUnmute :: Stream -> ID -> IO () -streamUnmute s k = withPatIds s [k] (\x -> x {mute = False}) +streamUnmute s k = withPatIds s [k] (\x -> x {psMute = False}) streamSolo :: Stream -> ID -> IO () -streamSolo s k = withPatIds s [k] (\x -> x {solo = True}) +streamSolo s k = withPatIds s [k] (\x -> x {psSolo = True}) streamUnsolo :: Stream -> ID -> IO () -streamUnsolo s k = withPatIds s [k] (\x -> x {solo = False}) +streamUnsolo s k = withPatIds s [k] (\x -> x {psSolo = False}) withPatIds :: Stream -> [ID] -> (PlayState -> PlayState) -> IO () withPatIds s ks f @@ -100,19 +101,19 @@ withPatIds s ks f -- TODO - is there a race condition here? streamMuteAll :: Stream -> IO () -streamMuteAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {mute = True}) +streamMuteAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {psMute = True}) streamHush :: Stream -> IO () -streamHush s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {pattern = silence, history = silence:history x}) +streamHush s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {psPattern = silence, psHistory = silence:psHistory x}) streamUnmuteAll :: Stream -> IO () -streamUnmuteAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {mute = False}) +streamUnmuteAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {psMute = False}) streamUnsoloAll :: Stream -> IO () -streamUnsoloAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {solo = False}) +streamUnsoloAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {psSolo = False}) streamSilence :: Stream -> ID -> IO () -streamSilence s k = withPatIds s [k] (\x -> x {pattern = silence, history = silence:history x}) +streamSilence s k = withPatIds s [k] (\x -> x {psPattern = silence, psHistory = silence:psHistory x}) streamAll :: Stream -> (ControlPattern -> ControlPattern) -> IO () streamAll s f = do _ <- swapMVar (sGlobalFMV s) f diff --git a/src/Sound/Tidal/Transition.hs b/src/Sound/Tidal/Transition.hs index b976c72b2..baf075864 100644 --- a/src/Sound/Tidal/Transition.hs +++ b/src/Sound/Tidal/Transition.hs @@ -2,24 +2,24 @@ module Sound.Tidal.Transition where -import Prelude hiding ((<*), (*>)) +import Prelude hiding ((*>), (<*)) -import Control.Concurrent.MVar (readMVar, swapMVar) +import Control.Concurrent.MVar (readMVar, swapMVar) -import qualified Data.Map.Strict as Map +import qualified Data.Map.Strict as Map -- import Data.Maybe (fromJust) -import Sound.Tidal.Control -import Sound.Tidal.Core -import Sound.Tidal.Stream.Config -import Sound.Tidal.ID -import Sound.Tidal.Params (gain, pan) -import Sound.Tidal.Pattern -import Sound.Tidal.Stream.Types -import qualified Sound.Tidal.Clock as Clock +import qualified Sound.Tidal.Clock as Clock +import Sound.Tidal.Control +import Sound.Tidal.Core +import Sound.Tidal.ID +import Sound.Tidal.Params (gain, pan) +import Sound.Tidal.Pattern +import Sound.Tidal.Stream.Config +import Sound.Tidal.Stream.Types -- import Sound.Tidal.Tempo as T -import Sound.Tidal.UI (fadeOutFrom, fadeInFrom) -import Sound.Tidal.Utils (enumerate) +import Sound.Tidal.UI (fadeInFrom, fadeOutFrom) +import Sound.Tidal.Utils (enumerate) {- Transition.hs - A library for handling transitions between patterns @@ -47,19 +47,19 @@ transition :: Stream -> Bool -> TransitionMapper -> ID -> ControlPattern -> IO ( transition stream historyFlag mapper patId !pat = do 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:[]) + updatePS (Just playState) = playState {psHistory = (appendPat historyFlag) (psHistory playState)} + updatePS Nothing = PlayState {psPattern = silence, + psMute = False, + psSolo = False, + psHistory = (appendPat historyFlag) (silence:[]) } transition' pat' = do t <- Clock.getCycleTime (cClockConfig $ sConfig stream) (sClockRef stream) return $! mapper t pat' 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 + pat' <- transition' $ appendPat (not historyFlag) (psHistory playState) + let pMap' = Map.insert (fromID patId) (playState {psPattern = pat'}) pMap _ <- swapMVar (sPMapMV stream) pMap' return () @@ -67,7 +67,7 @@ transition stream historyFlag mapper patId !pat = do mortalOverlay :: Time -> Time -> [Pattern a] -> Pattern a mortalOverlay _ _ [] = silence mortalOverlay t now (pat:ps) = overlay (pop ps) (playFor s (s+t) pat) where - pop [] = silence + pop [] = silence pop (x:_) = x s = sam (now - fromIntegral (floor now `mod` floor t :: Int)) + sam t @@ -105,7 +105,7 @@ histpan n _ ps = stack $ map (\(i,pat) -> pat # pan (pure $ (fromIntegral i) / ( -- | Just stop for a bit before playing new pattern wait :: Time -> Time -> [ControlPattern] -> ControlPattern -wait _ _ [] = silence +wait _ _ [] = silence wait t now (pat:_) = filterWhen (>= (nextSam (now+t-1))) pat {- | Just as `wait`, `waitT` stops for a bit and then applies the given transition to the playing pattern @@ -117,7 +117,7 @@ t1 (waitT (xfadeIn 8) 4) $ sound "hh*8" @ -} waitT :: (Time -> [ControlPattern] -> ControlPattern) -> Time -> Time -> [ControlPattern] -> ControlPattern -waitT _ _ _ [] = silence +waitT _ _ _ [] = silence waitT f t now pats = filterWhen (>= (nextSam (now+t-1))) (f (now + t) pats) {- | @@ -199,8 +199,8 @@ t1 (clutchIn 8) $ sound "[hh*4, odx(3,8)]" will take 8 cycles for the transition. -} clutchIn :: Time -> Time -> [Pattern a] -> Pattern a -clutchIn _ _ [] = silence -clutchIn _ _ (p:[]) = p +clutchIn _ _ [] = silence +clutchIn _ _ (p:[]) = p clutchIn t now (p:p':_) = overlay (fadeOutFrom now t p') (fadeInFrom now t p) {-| same as `anticipate` though it allows you to specify the number of cycles until dropping to the new pattern, e.g.: diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs index 4454c1426..299c4b61e 100644 --- a/src/Sound/Tidal/UI.hs +++ b/src/Sound/Tidal/UI.hs @@ -2415,34 +2415,34 @@ offadd :: Num a => Pattern Time -> Pattern a -> Pattern a -> Pattern a offadd tp pn p = off tp (+pn) p {- | - @stepify@ acts as a kind of simple step-sequencer using strings. For example, - @stepify "sn" "x x 12"@ is equivalent to the pattern of strings given by @"sn ~ - sn ~ sn:1 sn:2 ~"@. @stepify@ substitutes the given string for each @x@, for each number + @sseq@ acts as a kind of simple step-sequencer using strings. For example, + @sseq "sn" "x x 12"@ is equivalent to the pattern of strings given by @"sn ~ + sn ~ sn:1 sn:2 ~"@. @sseq@ substitutes the given string for each @x@, for each number it substitutes the string followed by a colon and the number, and for everything else it puts in a rest. - In other words, @stepify@ generates a pattern of strings in exactly the syntax you’d want for selecting samples and that can be fed directly into the 's' function. + In other words, @sseq@ generates a pattern of strings in exactly the syntax you’d want for selecting samples and that can be fed directly into the 's' function. - > d1 $ s (stepify "sn" "x x 12 ") + > d1 $ s (sseq "sn" "x x 12 ") -} -stepify :: String -> String -> Pattern String -stepify s cs = fastcat $ map f cs +sseq :: String -> String -> Pattern String +sseq s cs = fastcat $ map f cs where f c | c == 'x' = pure s | isDigit c = pure $ s ++ ":" ++ [c] | otherwise = silence -{- | @stepifies@ is like @stepify@ but it takes a list of pairs, like stepify would, and +{- | @sseqs@ is like @sseq@ but it takes a list of pairs, like sseq would, and it plays them all simultaneously. - > d1 $ s (stepifies [("cp","x x x x x x"),("bd", "xxxx")]) + > d1 $ s (sseqs [("cp","x x x x x x"),("bd", "xxxx")]) -} -stepifies :: [(String, String)] -> Pattern String -stepifies = stack . map (uncurry stepify) +sseqs :: [(String, String)] -> Pattern String +sseqs = stack . map (uncurry sseq) -{- | like `stepify`, but allows you to specify an array of strings to use for @0,1,2...@ +{- | like `sseq`, but allows you to specify an array of strings to use for @0,1,2...@ For example, - > d1 $ s (stepify' ["superpiano","supermandolin"] "0 1 000 1") + > d1 $ s (sseq' ["superpiano","supermandolin"] "0 1 000 1") > # sustain 4 # n 0 is equivalent to @@ -2450,8 +2450,8 @@ stepifies = stack . map (uncurry stepify) > d1 $ s "superpiano ~ supermandolin ~ superpiano!3 ~ supermandolin" > # sustain 4 # n 0 -} -stepify' :: [String] -> String -> Pattern String -stepify' ss cs = fastcat $ map f cs +sseq' :: [String] -> String -> Pattern String +sseq' ss cs = fastcat $ map f cs where f c | c == 'x' = pure $ head ss | isDigit c = pure $ ss !! digitToInt c | otherwise = silence diff --git a/tidal-parse/src/Sound/Tidal/Parse.hs b/tidal-parse/src/Sound/Tidal/Parse.hs index d67630680..72468687c 100644 --- a/tidal-parse/src/Sound/Tidal/Parse.hs +++ b/tidal-parse/src/Sound/Tidal/Parse.hs @@ -448,7 +448,7 @@ instance Parse (String -> Pattern String) where (parser :: H ([String] -> String -> Pattern String )) <*> parser instance Parse ([(String, String)] -> Pattern String) where - parser = $(fromTidal "stepifies") + parser = $(fromTidal "sseqs") instance Parse (String -> String) where parser = (parser :: H (String -> String -> String)) <*!> parser @@ -833,10 +833,10 @@ pDouble_tupleADouble_p :: Parse a => H (Pattern Double -> [(a,Double)] -> Patter pDouble_tupleADouble_p = $(fromTidal "wchooseBy") instance Parse (String -> String -> Pattern String) where - parser = $(fromTidal "stepify") + parser = $(fromTidal "sseq") instance Parse ([String] -> String -> Pattern String) where - parser = $(fromTidal "stepify'") + parser = $(fromTidal "sseq'") instance Parse (String -> String -> String) where parser = (parser :: H (Int -> String -> String -> String)) <*!> parser diff --git a/tidal-parse/test/Sound/Tidal/TidalParseTest.hs b/tidal-parse/test/Sound/Tidal/TidalParseTest.hs index 6da8852d3..4d071313d 100644 --- a/tidal-parse/test/Sound/Tidal/TidalParseTest.hs +++ b/tidal-parse/test/Sound/Tidal/TidalParseTest.hs @@ -2,12 +2,12 @@ module Sound.Tidal.TidalParseTest where -import Test.Microspec hiding (run) -import Sound.Tidal.Parse -import Sound.Tidal.Context as Tidal -import Sound.Tidal.Chords as Tidal -import Data.Either -import qualified Data.Map.Strict as Map +import Data.Either +import qualified Data.Map.Strict as Map +import Sound.Tidal.Chords as Tidal +import Sound.Tidal.Context as Tidal +import Sound.Tidal.Parse +import Test.Microspec hiding (run) stripContext :: Pattern a -> Pattern a stripContext = setContext $ Context [] @@ -284,14 +284,14 @@ run = "s \"bd*4\" <> s \"cp*5\"" `parsesTo` (s "bd*4" <> s "cp*5") - it "parses an example with step" $ - "s (step \"tink\" \"xx x\")" `parsesTo` - (s (step "tink" "xx x")) + it "parses an example with sseq" $ + "s (sseq \"tink\" \"xx x\")" `parsesTo` + (s (sseq "tink" "xx x")) - it "parses an example with step'" $ - "s (step' [\"tink\",\"feel\"] \"01 0\")" `parsesTo` - (s (step' ["tink","feel"] "01 0")) + it "parses an example with sseq'" $ + "s (sseq' [\"tink\",\"feel\"] \"01 0\")" `parsesTo` + (s (sseq' ["tink","feel"] "01 0")) - it "parses an example with steps" $ - "s (steps [(\"tink\",\" x x\"),(\"feel\", \"x x \")])" `parsesTo` - (s (steps [("tink"," x x"),("feel", "x x ")])) + it "parses an example with sseqs" $ + "s (sseqs [(\"tink\",\" x x\"),(\"feel\", \"x x \")])" `parsesTo` + (s (sseqs [("tink"," x x"),("feel", "x x ")])) From 75176c337c75422aeeb3abab1385896241654b8c Mon Sep 17 00:00:00 2001 From: alex Date: Thu, 11 Apr 2024 09:27:46 +0100 Subject: [PATCH 14/46] remove cFrameTimespan --- BootTidal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/BootTidal.hs b/BootTidal.hs index c2548d2d3..4990714c3 100644 --- a/BootTidal.hs +++ b/BootTidal.hs @@ -6,7 +6,7 @@ import Sound.Tidal.Context import System.IO (hSetEncoding, stdout, utf8) hSetEncoding stdout utf8 -tidal <- startTidal (superdirtTarget {oLatency = 0.05, 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}) :{ let only = (hush >>) From b0ed36f90b7bddbd828fb518b69b33fabd1d7d73 Mon Sep 17 00:00:00 2001 From: alex Date: Thu, 11 Apr 2024 09:32:09 +0100 Subject: [PATCH 15/46] suppress name shadow warns --- BootTidal.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/BootTidal.hs b/BootTidal.hs index 4990714c3..af44fd5c3 100644 --- a/BootTidal.hs +++ b/BootTidal.hs @@ -8,6 +8,8 @@ hSetEncoding stdout utf8 tidal <- startTidal (superdirtTarget {oLatency = 0.05, oAddress = "127.0.0.1", oPort = 57120}) (defaultConfig {cVerbose = True}) +:set -Wno-name-shadowing + :{ let only = (hush >>) p = streamReplace tidal @@ -67,6 +69,8 @@ let only = (hush >>) d16 = p 16 :} +:set -Wname-shadowing + :{ let getState = streamGet tidal setI = streamSetI tidal From 323dfb7f576299e4084c62476a4d5b7e85bc1760 Mon Sep 17 00:00:00 2001 From: alex Date: Thu, 11 Apr 2024 09:32:26 +0100 Subject: [PATCH 16/46] fix warns --- src/Sound/Tidal/Stream/Process.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/Sound/Tidal/Stream/Process.hs b/src/Sound/Tidal/Stream/Process.hs index 150651a31..6d02e8a94 100644 --- a/src/Sound/Tidal/Stream/Process.hs +++ b/src/Sound/Tidal/Stream/Process.hs @@ -177,7 +177,7 @@ toOSC busses pe osc@(OSC _ _) -- (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 + playmap' = Map.union (Map.mapKeys tail $ Map.map (\v -> VS ('c':(show $ toBus $ fromMaybe 0 $ getI v))) busmap) playmap val = value . peEvent -- Only events that start within the current nowArc are included playmsg | peHasOnset pe = do @@ -198,11 +198,13 @@ toOSC busses pe osc@(OSC _ _) 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] - ) + (\(k, b) -> do k' <- if (not $ null k) && head k == '^' then Just (tail k) else Nothing + v <- Map.lookup k' playmap + bi <- getI b + return $ (tsPart, + True, -- bus message ? + O.Message "/c_set" [O.int32 bi, toDatum v] + ) ) (Map.toList busmap) where From b5ac6f7f8b02a6da1b7d2ff3d2077aabb78be49b Mon Sep 17 00:00:00 2001 From: alex Date: Thu, 11 Apr 2024 10:27:15 +0100 Subject: [PATCH 17/46] add stepalt, steptaper, steptaperlist, stepfirstof/steplastof/stepevery --- src/Sound/Tidal/Core.hs | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/src/Sound/Tidal/Core.hs b/src/Sound/Tidal/Core.hs index 95195fe7c..d0e2b0a24 100644 --- a/src/Sound/Tidal/Core.hs +++ b/src/Sound/Tidal/Core.hs @@ -23,6 +23,7 @@ module Sound.Tidal.Core where import Prelude hiding ((*>), (<*)) import Data.Fixed (mod') +import Data.List (transpose) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import Sound.Tidal.Pattern @@ -457,6 +458,33 @@ steplastof :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a steplastof (Pattern _ _ (Just i)) f pat = _steplastof i f pat steplastof tp f p = innerJoin $ (\t -> _steplastof t f p) <$> tp +_stepfirstof :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +_stepfirstof i f pat | i <= 1 = pat + | otherwise = stepcat $ f pat : (take (i-1) $ repeat pat) + +stepfirstof :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +stepfirstof (Pattern _ _ (Just i)) f pat = _stepfirstof i f pat +stepfirstof tp f p = innerJoin $ (\t -> _steplastof t f p) <$> tp + +stepevery :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +stepevery = stepfirstof + +-- | Like @steptaper@, but returns a list of repetitions +steptaperlist :: Pattern a -> [Pattern a] +steptaperlist pat@(Pattern _ (Just t) _) = pat : map (\r -> _stepsub r pat) [1 .. t] +-- TODO exception? +steptaperlist pat = [pat] + +-- | Plays one fewer step from the pattern each repetition, down to nothing +steptaper :: Pattern a -> Pattern a +steptaper = stepcat . steptaperlist + +-- | Successively plays a pattern from each group in turn +stepalt :: [[Pattern a]] -> Pattern a +stepalt groups = stepcat $ concat $ take (c * length groups) $ transpose $ map cycle groups + where c = foldl1 lcm $ map length groups + + -- ** Manipulating time -- | Shifts a pattern back in time by the given amount, expressed in cycles From 31ac61620071bf4ec027bd41b009b5375c522711 Mon Sep 17 00:00:00 2001 From: alex Date: Thu, 11 Apr 2024 10:55:58 +0100 Subject: [PATCH 18/46] fix steptaper --- src/Sound/Tidal/Core.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Sound/Tidal/Core.hs b/src/Sound/Tidal/Core.hs index d0e2b0a24..0011d9bc8 100644 --- a/src/Sound/Tidal/Core.hs +++ b/src/Sound/Tidal/Core.hs @@ -375,7 +375,7 @@ fastcat = fastCat -} timeCat :: [(Time, Pattern a)] -> Pattern a timeCat ((_,p):[]) = p -timeCat tps = setTactus total $ stack $ map (\(s,e,p) -> compressArc (Arc (s/total) (e/total)) p) $ arrange 0 tps +timeCat tps = setTactus total $ stack $ map (\(s,e,p) -> compressArc (Arc (s/total) (e/total)) p) $ arrange 0 $ filter (\(t, _) -> t > 0) $ tps where total = sum $ map fst tps arrange :: Time -> [(Time, Pattern a)] -> [(Time, Time, Pattern a)] arrange _ [] = [] From 7f69539151b59c26fcd3cbacd7bb11f8ae1bd08e Mon Sep 17 00:00:00 2001 From: alex Date: Thu, 11 Apr 2024 11:31:52 +0100 Subject: [PATCH 19/46] make firstof/lastof/every more interesting --- src/Sound/Tidal/Core.hs | 65 ++------------------------------------- src/Sound/Tidal/UI.hs | 67 ++++++++++++++++++++++++++++++++++++++++- 2 files changed, 68 insertions(+), 64 deletions(-) diff --git a/src/Sound/Tidal/Core.hs b/src/Sound/Tidal/Core.hs index 0011d9bc8..e5af1fbfb 100644 --- a/src/Sound/Tidal/Core.hs +++ b/src/Sound/Tidal/Core.hs @@ -23,7 +23,6 @@ module Sound.Tidal.Core where import Prelude hiding ((*>), (<*)) import Data.Fixed (mod') -import Data.List (transpose) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import Sound.Tidal.Pattern @@ -352,7 +351,8 @@ fastappend = fastAppend -} fastCat :: [Pattern a] -> Pattern a fastCat (p:[]) = p -fastCat ps = _fast (toTime $ length ps) $ cat ps +fastCat ps = setTactus t $ _fast (toTime $ length ps) $ cat ps + where t = fromMaybe (toRational $ length ps) $ ((* (toRational $ length ps)) . foldl1 lcmr) <$> (sequence $ map tactus ps) -- | Alias for @fastCat@ fastcat :: [Pattern a] -> Pattern a @@ -424,67 +424,6 @@ pattern to multiple patterns at once: stack :: [Pattern a] -> Pattern a stack = foldr overlay silence --- ** stepwise things - -stepcat :: [Pattern a] -> Pattern a -stepcat pats = timecat $ map (\pat -> (fromMaybe 1 $ tactus pat, pat)) pats - -_stepadd :: Rational -> Pattern a -> Pattern a --- raise error? -_stepadd _ pat@(Pattern _ Nothing _) = pat -_stepadd r pat@(Pattern _ (Just t) _) - | r == 0 = nothing - | (abs r) >= t = pat - | r < 0 = zoom (1-((abs r)/t),1) pat - | otherwise = zoom (0, (r/t)) pat - -stepadd :: Pattern Rational -> Pattern a -> Pattern a -stepadd = tParam _stepadd - -_stepsub :: Rational -> Pattern a -> Pattern a -_stepsub _ pat@(Pattern _ Nothing _) = pat -_stepsub r pat@(Pattern _ (Just t) _) | r >= t = nothing - | r < 0 = _stepadd (0- (t+r)) pat - | otherwise = _stepadd (t-r) pat - -stepsub :: Pattern Rational -> Pattern a -> Pattern a -stepsub = tParam _stepsub - -_steplastof :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -_steplastof i f pat | i <= 1 = pat - | otherwise = stepcat $ (take (i-1) $ repeat pat) ++ [f pat] - -steplastof :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -steplastof (Pattern _ _ (Just i)) f pat = _steplastof i f pat -steplastof tp f p = innerJoin $ (\t -> _steplastof t f p) <$> tp - -_stepfirstof :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -_stepfirstof i f pat | i <= 1 = pat - | otherwise = stepcat $ f pat : (take (i-1) $ repeat pat) - -stepfirstof :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -stepfirstof (Pattern _ _ (Just i)) f pat = _stepfirstof i f pat -stepfirstof tp f p = innerJoin $ (\t -> _steplastof t f p) <$> tp - -stepevery :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -stepevery = stepfirstof - --- | Like @steptaper@, but returns a list of repetitions -steptaperlist :: Pattern a -> [Pattern a] -steptaperlist pat@(Pattern _ (Just t) _) = pat : map (\r -> _stepsub r pat) [1 .. t] --- TODO exception? -steptaperlist pat = [pat] - --- | Plays one fewer step from the pattern each repetition, down to nothing -steptaper :: Pattern a -> Pattern a -steptaper = stepcat . steptaperlist - --- | Successively plays a pattern from each group in turn -stepalt :: [[Pattern a]] -> Pattern a -stepalt groups = stepcat $ concat $ take (c * length groups) $ transpose $ map cycle groups - where c = foldl1 lcm $ map length groups - - -- ** Manipulating time -- | Shifts a pattern back in time by the given amount, expressed in cycles diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs index 299c4b61e..f4cf91b73 100644 --- a/src/Sound/Tidal/UI.hs +++ b/src/Sound/Tidal/UI.hs @@ -2195,7 +2195,7 @@ stitch pb a b = overlay (struct pb a) (struct (inv pb) b) -- value is active. No events are let through where no binary values -- are active. while :: Pattern Bool -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -while b f pat = sew b (f pat) pat +while b f pat = keepTactus pat $ sew b (f pat) pat {-| @stutter n t pat@ repeats each event in @pat@ @n@ times, separated by @t@ time (in fractions of a cycle). @@ -2903,3 +2903,68 @@ necklace perCycle xs = _slow ((toRational $ sum xs) / perCycle) $ listToPat $ li where list :: [Int] -> [Bool] list [] = [] list (x:xs') = (True:(replicate (x-1) False)) ++ list xs' + +-- ** stepwise things + +stepcat :: [Pattern a] -> Pattern a +stepcat pats = timecat $ map (\pat -> (fromMaybe 1 $ tactus pat, pat)) pats + +_stepadd :: Rational -> Pattern a -> Pattern a +-- raise error? +_stepadd _ pat@(Pattern _ Nothing _) = pat +_stepadd r pat@(Pattern _ (Just t) _) + | r == 0 = nothing + | (abs r) >= t = pat + | r < 0 = zoom (1-((abs r)/t),1) pat + | otherwise = zoom (0, (r/t)) pat + +stepadd :: Pattern Rational -> Pattern a -> Pattern a +stepadd = tParam _stepadd + +_stepsub :: Rational -> Pattern a -> Pattern a +_stepsub _ pat@(Pattern _ Nothing _) = pat +_stepsub r pat@(Pattern _ (Just t) _) | r >= t = nothing + | r < 0 = _stepadd (0- (t+r)) pat + | otherwise = _stepadd (t-r) pat + +stepsub :: Pattern Rational -> Pattern a -> Pattern a +stepsub = tParam _stepsub + +stepwhen :: Pattern Bool -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +stepwhen patb f pat@(Pattern _ (Just t) _) = while (_steps t patb) f pat +-- TODO raise exception? +stepwhen _ _ pat = pat + +_steplastof :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +_steplastof i f pat | i <= 1 = pat + | otherwise = stepwhen (fastcat $ map pure $ (replicate (i-1) False) ++ [True]) f pat + +steplastof :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +steplastof (Pattern _ _ (Just i)) f pat = _steplastof i f pat +steplastof tp f p = innerJoin $ (\t -> _steplastof t f p) <$> tp + +_stepfirstof :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +_stepfirstof i f pat | i <= 1 = pat + | otherwise = stepwhen (fastcat $ map pure $ True:replicate (i-1) False) f pat + +stepfirstof :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +stepfirstof (Pattern _ _ (Just i)) f pat = _stepfirstof i f pat +stepfirstof tp f p = innerJoin $ (\t -> _stepfirstof t f p) <$> tp + +stepevery :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +stepevery = stepfirstof + +-- | Like @steptaper@, but returns a list of repetitions +steptaperlist :: Pattern a -> [Pattern a] +steptaperlist pat@(Pattern _ (Just t) _) = pat : map (\r -> _stepsub r pat) [1 .. t] +-- TODO exception? +steptaperlist pat = [pat] + +-- | Plays one fewer step from the pattern each repetition, down to nothing +steptaper :: Pattern a -> Pattern a +steptaper = stepcat . steptaperlist + +-- | Successively plays a pattern from each group in turn +stepalt :: [[Pattern a]] -> Pattern a +stepalt groups = stepcat $ concat $ take (c * length groups) $ transpose $ map cycle groups + where c = foldl1 lcm $ map length groups From 86533cee292920736880516924d49add41be4dab Mon Sep 17 00:00:00 2001 From: alex Date: Fri, 12 Apr 2024 15:50:03 +0100 Subject: [PATCH 20/46] rejig stepfirstof etc to count steps not cycles --- src/Sound/Tidal/Pattern.hs | 6 ++++++ src/Sound/Tidal/UI.hs | 23 +++++++++++++++++++---- 2 files changed, 25 insertions(+), 4 deletions(-) diff --git a/src/Sound/Tidal/Pattern.hs b/src/Sound/Tidal/Pattern.hs index 49229d9fc..e0d24e194 100644 --- a/src/Sound/Tidal/Pattern.hs +++ b/src/Sound/Tidal/Pattern.hs @@ -461,6 +461,9 @@ withResultArc f pat = pat withResultTime :: (Time -> Time) -> Pattern a -> Pattern a withResultTime f = withResultArc (\(Arc s e) -> Arc (f s) (f e)) +withResultStart :: (Time -> Time) -> Pattern a -> Pattern a +withResultStart f pat = withResultArc (\(Arc s e) -> Arc (f s) (f s + (e-s))) pat + -- | Apply a function to the timespan of the query withQueryArc :: (Arc -> Arc) -> Pattern a -> Pattern a withQueryArc f pat = pat {query = query pat . (\(State a m) -> State (f a) m)} @@ -469,6 +472,9 @@ withQueryArc f pat = pat {query = query pat . (\(State a m) -> State (f a) m)} withQueryTime :: (Time -> Time) -> Pattern a -> Pattern a withQueryTime f pat = withQueryArc (\(Arc s e) -> Arc (f s) (f e)) pat +withQueryStart :: (Time -> Time) -> Pattern a -> Pattern a +withQueryStart f pat = withQueryArc (\(Arc s e) -> Arc (f s) (f s + (e-s))) pat + -- | Apply a function to the control values of the query withQueryControls :: (ValueMap -> ValueMap) -> Pattern a -> Pattern a withQueryControls f pat = pat { query = query pat . (\(State a m) -> State a (f m))} diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs index f4cf91b73..83491e1c7 100644 --- a/src/Sound/Tidal/UI.hs +++ b/src/Sound/Tidal/UI.hs @@ -2935,17 +2935,32 @@ stepwhen patb f pat@(Pattern _ (Just t) _) = while (_steps t patb) f pat -- TODO raise exception? stepwhen _ _ pat = pat +separateCycles :: Int -> Pattern a -> [Pattern a] +separateCycles n pat = map (\i -> skip $ rotL (toRational i) pat) [0 .. n-1] + + where n' = toRational n + skip pat' = splitQueries $ withResultStart (\t -> ((sam t) / n') + cyclePos t) $ withQueryStart (\t -> (sam t * n') + cyclePos t) $ pat' + + +-- _steplastof :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +-- _steplastof i f pat | i <= 1 = pat +-- | otherwise = stepwhen (fastcat $ map pure $ (replicate (i-1) False) ++ [True]) f pat + _steplastof :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -_steplastof i f pat | i <= 1 = pat - | otherwise = stepwhen (fastcat $ map pure $ (replicate (i-1) False) ++ [True]) f pat +_steplastof n f pat | n <= 1 = pat + | otherwise = _fast t $ stepcat $ reverse $ (f $ head cycles):tail cycles + where cycles = reverse $ separateCycles n $ _slow t pat + t = fromMaybe 1 $ tactus pat steplastof :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a steplastof (Pattern _ _ (Just i)) f pat = _steplastof i f pat steplastof tp f p = innerJoin $ (\t -> _steplastof t f p) <$> tp _stepfirstof :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -_stepfirstof i f pat | i <= 1 = pat - | otherwise = stepwhen (fastcat $ map pure $ True:replicate (i-1) False) f pat +_stepfirstof n f pat | n <= 1 = pat + | otherwise = _fast t $ stepcat $ (f $ head cycles):tail cycles + where cycles = separateCycles n $ _slow t pat + t = fromMaybe 1 $ tactus pat stepfirstof :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a stepfirstof (Pattern _ _ (Just i)) f pat = _stepfirstof i f pat From 27ae58fde8e23b7f693b0fd8b3a80b6b05e86240 Mon Sep 17 00:00:00 2001 From: Alex McLean Date: Fri, 12 Apr 2024 17:13:57 +0100 Subject: [PATCH 21/46] put stepwise in its own module, experiment with using S. prefix --- BootTidal.hs | 1 + src/Sound/Tidal/Context.hs | 28 ++++++------- src/Sound/Tidal/Pattern.hs | 8 ++++ src/Sound/Tidal/UI.hs | 80 -------------------------------------- 4 files changed, 23 insertions(+), 94 deletions(-) diff --git a/BootTidal.hs b/BootTidal.hs index af44fd5c3..99f68c98f 100644 --- a/BootTidal.hs +++ b/BootTidal.hs @@ -2,6 +2,7 @@ :set prompt "" import Sound.Tidal.Context +import qualified Sound.Tidal.Stepwise as S import System.IO (hSetEncoding, stdout, utf8) hSetEncoding stdout utf8 diff --git a/src/Sound/Tidal/Context.hs b/src/Sound/Tidal/Context.hs index 057f76061..34ba52076 100644 --- a/src/Sound/Tidal/Context.hs +++ b/src/Sound/Tidal/Context.hs @@ -18,19 +18,19 @@ module Sound.Tidal.Context (module C) where along with this library. If not, see . -} -import Prelude hiding ((<*), (*>)) +import Prelude hiding ((*>), (<*)) -import Data.Ratio as C +import Data.Ratio as C -import Sound.Tidal.Stream as C -import Sound.Tidal.Control as C -import Sound.Tidal.Core as C -import Sound.Tidal.Params as C -import Sound.Tidal.ParseBP as C -import Sound.Tidal.Pattern as C -import Sound.Tidal.Scales as C -import Sound.Tidal.Show as C -import Sound.Tidal.Simple as C -import Sound.Tidal.Transition as C -import Sound.Tidal.UI as C -import Sound.Tidal.Version as C +import Sound.Tidal.Control as C +import Sound.Tidal.Core as C +import Sound.Tidal.Params as C +import Sound.Tidal.ParseBP as C +import Sound.Tidal.Pattern as C +import Sound.Tidal.Scales as C +import Sound.Tidal.Show as C +import Sound.Tidal.Simple as C +import Sound.Tidal.Stream as C +import Sound.Tidal.Transition as C +import Sound.Tidal.UI as C +import Sound.Tidal.Version as C diff --git a/src/Sound/Tidal/Pattern.hs b/src/Sound/Tidal/Pattern.hs index e0d24e194..122010d0b 100644 --- a/src/Sound/Tidal/Pattern.hs +++ b/src/Sound/Tidal/Pattern.hs @@ -737,6 +737,14 @@ filterAnalog = filterEvents isAnalog playFor :: Time -> Time -> Pattern a -> Pattern a playFor s e pat = pattern $ \st -> maybe [] (\a -> query pat (st {arc = a})) $ subArc (Arc s e) (arc st) +-- | Splits a pattern into a list containing the given 'n' number of +-- patterns. Each one plays every 'n'th cycle, successfully offset by +-- a cycle. +separateCycles :: Int -> Pattern a -> [Pattern a] +separateCycles n pat = map (\i -> skip $ rotL (toRational i) pat) [0 .. n-1] + where n' = toRational n + skip pat' = splitQueries $ withResultStart (\t -> ((sam t) / n') + cyclePos t) $ withQueryStart (\t -> (sam t * n') + cyclePos t) $ pat' + -- ** Temporal parameter helpers tParam :: (t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs index 83491e1c7..9bcd40e09 100644 --- a/src/Sound/Tidal/UI.hs +++ b/src/Sound/Tidal/UI.hs @@ -2903,83 +2903,3 @@ necklace perCycle xs = _slow ((toRational $ sum xs) / perCycle) $ listToPat $ li where list :: [Int] -> [Bool] list [] = [] list (x:xs') = (True:(replicate (x-1) False)) ++ list xs' - --- ** stepwise things - -stepcat :: [Pattern a] -> Pattern a -stepcat pats = timecat $ map (\pat -> (fromMaybe 1 $ tactus pat, pat)) pats - -_stepadd :: Rational -> Pattern a -> Pattern a --- raise error? -_stepadd _ pat@(Pattern _ Nothing _) = pat -_stepadd r pat@(Pattern _ (Just t) _) - | r == 0 = nothing - | (abs r) >= t = pat - | r < 0 = zoom (1-((abs r)/t),1) pat - | otherwise = zoom (0, (r/t)) pat - -stepadd :: Pattern Rational -> Pattern a -> Pattern a -stepadd = tParam _stepadd - -_stepsub :: Rational -> Pattern a -> Pattern a -_stepsub _ pat@(Pattern _ Nothing _) = pat -_stepsub r pat@(Pattern _ (Just t) _) | r >= t = nothing - | r < 0 = _stepadd (0- (t+r)) pat - | otherwise = _stepadd (t-r) pat - -stepsub :: Pattern Rational -> Pattern a -> Pattern a -stepsub = tParam _stepsub - -stepwhen :: Pattern Bool -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -stepwhen patb f pat@(Pattern _ (Just t) _) = while (_steps t patb) f pat --- TODO raise exception? -stepwhen _ _ pat = pat - -separateCycles :: Int -> Pattern a -> [Pattern a] -separateCycles n pat = map (\i -> skip $ rotL (toRational i) pat) [0 .. n-1] - - where n' = toRational n - skip pat' = splitQueries $ withResultStart (\t -> ((sam t) / n') + cyclePos t) $ withQueryStart (\t -> (sam t * n') + cyclePos t) $ pat' - - --- _steplastof :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a --- _steplastof i f pat | i <= 1 = pat --- | otherwise = stepwhen (fastcat $ map pure $ (replicate (i-1) False) ++ [True]) f pat - -_steplastof :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -_steplastof n f pat | n <= 1 = pat - | otherwise = _fast t $ stepcat $ reverse $ (f $ head cycles):tail cycles - where cycles = reverse $ separateCycles n $ _slow t pat - t = fromMaybe 1 $ tactus pat - -steplastof :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -steplastof (Pattern _ _ (Just i)) f pat = _steplastof i f pat -steplastof tp f p = innerJoin $ (\t -> _steplastof t f p) <$> tp - -_stepfirstof :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -_stepfirstof n f pat | n <= 1 = pat - | otherwise = _fast t $ stepcat $ (f $ head cycles):tail cycles - where cycles = separateCycles n $ _slow t pat - t = fromMaybe 1 $ tactus pat - -stepfirstof :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -stepfirstof (Pattern _ _ (Just i)) f pat = _stepfirstof i f pat -stepfirstof tp f p = innerJoin $ (\t -> _stepfirstof t f p) <$> tp - -stepevery :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -stepevery = stepfirstof - --- | Like @steptaper@, but returns a list of repetitions -steptaperlist :: Pattern a -> [Pattern a] -steptaperlist pat@(Pattern _ (Just t) _) = pat : map (\r -> _stepsub r pat) [1 .. t] --- TODO exception? -steptaperlist pat = [pat] - --- | Plays one fewer step from the pattern each repetition, down to nothing -steptaper :: Pattern a -> Pattern a -steptaper = stepcat . steptaperlist - --- | Successively plays a pattern from each group in turn -stepalt :: [[Pattern a]] -> Pattern a -stepalt groups = stepcat $ concat $ take (c * length groups) $ transpose $ map cycle groups - where c = foldl1 lcm $ map length groups From 25850a526cd599e7bebd8c8e8ece4ddb7ddc24d9 Mon Sep 17 00:00:00 2001 From: Alex McLean Date: Fri, 12 Apr 2024 17:14:05 +0100 Subject: [PATCH 22/46] put stepwise in its own module, experiment with using S. prefix --- src/Sound/Tidal/Stepwise.hs | 98 +++++++++++++++++++++++++++++++++++++ 1 file changed, 98 insertions(+) create mode 100644 src/Sound/Tidal/Stepwise.hs diff --git a/src/Sound/Tidal/Stepwise.hs b/src/Sound/Tidal/Stepwise.hs new file mode 100644 index 000000000..60cb8d90e --- /dev/null +++ b/src/Sound/Tidal/Stepwise.hs @@ -0,0 +1,98 @@ +{- + Tactus.hs - Functions that deal with stepwise manipulation of pattern + Copyright (C) 2024, 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 . +-} + + +module Sound.Tidal.Stepwise where + +import Data.List (transpose) +import Data.Maybe (fromMaybe) + +import qualified Sound.Tidal.Core as T +import qualified Sound.Tidal.Pattern as T +import qualified Sound.Tidal.UI as T + +cat :: [T.Pattern a] -> T.Pattern a +cat pats = T.timecat $ map (\pat -> (fromMaybe 1 $ T.tactus pat, pat)) pats + +_add :: Rational -> T.Pattern a -> T.Pattern a +-- raise error? +_add _ pat@(T.Pattern _ Nothing _) = pat +_add r pat@(T.Pattern _ (Just t) _) + | r == 0 = T.nothing + | (abs r) >= t = pat + | r < 0 = T.zoom (1-((abs r)/t),1) pat + | otherwise = T.zoom (0, (r/t)) pat + +add :: T.Pattern Rational -> T.Pattern a -> T.Pattern a +add = T.tParam _add + +_sub :: Rational -> T.Pattern a -> T.Pattern a +_sub _ pat@(T.Pattern _ Nothing _) = pat +_sub r pat@(T.Pattern _ (Just t) _) | r >= t = T.nothing + | r < 0 = _add (0- (t+r)) pat + | otherwise = _add (t-r) pat + +sub :: T.Pattern Rational -> T.Pattern a -> T.Pattern a +sub = T.tParam _sub + +when :: T.Pattern Bool -> (T.Pattern a -> T.Pattern a) -> T.Pattern a -> T.Pattern a +when patb f pat@(T.Pattern _ (Just t) _) = T.while (T._steps t patb) f pat +-- TODO raise exception? +when _ _ pat = pat + +-- _lastof :: Int -> (T.Pattern a -> T.Pattern a) -> T.Pattern a -> T.Pattern a +-- _lastof i f pat | i <= 1 = pat +-- | otherwise = when (fastcat $ map pure $ (replicate (i-1) False) ++ [True]) f pat + +_lastof :: Int -> (T.Pattern a -> T.Pattern a) -> T.Pattern a -> T.Pattern a +_lastof n f pat | n <= 1 = pat + | otherwise = T._fast t $ cat $ reverse $ (f $ head cycles):tail cycles + where cycles = reverse $ T.separateCycles n $ T._slow t pat + t = fromMaybe 1 $ T.tactus pat + +lastof :: T.Pattern Int -> (T.Pattern a -> T.Pattern a) -> T.Pattern a -> T.Pattern a +lastof (T.Pattern _ _ (Just i)) f pat = _lastof i f pat +lastof tp f p = T.innerJoin $ (\t -> _lastof t f p) <$> tp + +_firstof :: Int -> (T.Pattern a -> T.Pattern a) -> T.Pattern a -> T.Pattern a +_firstof n f pat | n <= 1 = pat + | otherwise = T._fast t $ cat $ (f $ head cycles):tail cycles + where cycles = T.separateCycles n $ T._slow t pat + t = fromMaybe 1 $ T.tactus pat + +firstof :: T.Pattern Int -> (T.Pattern a -> T.Pattern a) -> T.Pattern a -> T.Pattern a +firstof (T.Pattern _ _ (Just i)) f pat = _firstof i f pat +firstof tp f p = T.innerJoin $ (\t -> _firstof t f p) <$> tp + +every :: T.Pattern Int -> (T.Pattern a -> T.Pattern a) -> T.Pattern a -> T.Pattern a +every = firstof + +-- | Like @taper@, but returns a list of repetitions +taperlist :: T.Pattern a -> [T.Pattern a] +taperlist pat@(T.Pattern _ (Just t) _) = pat : map (\r -> _sub r pat) [1 .. t] +-- TODO exception? +taperlist pat = [pat] + +-- | Plays one fewer from the pattern each repetition, down to nothing +taper :: T.Pattern a -> T.Pattern a +taper = cat . taperlist + +-- | Successively plays a pattern from each group in turn +alt :: [[T.Pattern a]] -> T.Pattern a +alt groups = cat $ concat $ take (c * length groups) $ transpose $ map cycle groups + where c = foldl1 lcm $ map length groups From 5effc5c0c64e0060d046e42d0fbe4fdc7f1e957a Mon Sep 17 00:00:00 2001 From: Alex McLean Date: Fri, 12 Apr 2024 17:14:12 +0100 Subject: [PATCH 23/46] put stepwise in its own module, experiment with using S. prefix --- tidal.cabal | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/tidal.cabal b/tidal.cabal index 2d020869a..a9b566fc2 100644 --- a/tidal.cabal +++ b/tidal.cabal @@ -41,13 +41,14 @@ library Sound.Tidal.Safe.Boot Sound.Tidal.Show Sound.Tidal.Simple + Sound.Tidal.Stepwise Sound.Tidal.Stream Sound.Tidal.Stream.Config Sound.Tidal.Stream.Listen Sound.Tidal.Stream.Main Sound.Tidal.Stream.Process - Sound.Tidal.Stream.Types Sound.Tidal.Stream.Target + Sound.Tidal.Stream.Types Sound.Tidal.Stream.UI Sound.Tidal.Time Sound.Tidal.Transition From 12055a74a47be01293d79c81c11dfeadd93cdaa7 Mon Sep 17 00:00:00 2001 From: Alex McLean Date: Fri, 12 Apr 2024 17:15:48 +0100 Subject: [PATCH 24/46] undo S. experiment --- BootTidal.hs | 1 - src/Sound/Tidal/Context.hs | 1 + src/Sound/Tidal/Stepwise.hs | 120 ++++++++++++++++++------------------ 3 files changed, 61 insertions(+), 61 deletions(-) diff --git a/BootTidal.hs b/BootTidal.hs index 99f68c98f..af44fd5c3 100644 --- a/BootTidal.hs +++ b/BootTidal.hs @@ -2,7 +2,6 @@ :set prompt "" import Sound.Tidal.Context -import qualified Sound.Tidal.Stepwise as S import System.IO (hSetEncoding, stdout, utf8) hSetEncoding stdout utf8 diff --git a/src/Sound/Tidal/Context.hs b/src/Sound/Tidal/Context.hs index 34ba52076..1c683c57a 100644 --- a/src/Sound/Tidal/Context.hs +++ b/src/Sound/Tidal/Context.hs @@ -30,6 +30,7 @@ import Sound.Tidal.Pattern as C import Sound.Tidal.Scales as C import Sound.Tidal.Show as C import Sound.Tidal.Simple as C +import Sound.Tidal.Stepwise as C import Sound.Tidal.Stream as C import Sound.Tidal.Transition as C import Sound.Tidal.UI as C diff --git a/src/Sound/Tidal/Stepwise.hs b/src/Sound/Tidal/Stepwise.hs index 60cb8d90e..ea178d8b9 100644 --- a/src/Sound/Tidal/Stepwise.hs +++ b/src/Sound/Tidal/Stepwise.hs @@ -22,77 +22,77 @@ module Sound.Tidal.Stepwise where import Data.List (transpose) import Data.Maybe (fromMaybe) -import qualified Sound.Tidal.Core as T -import qualified Sound.Tidal.Pattern as T -import qualified Sound.Tidal.UI as T +import Sound.Tidal.Core +import Sound.Tidal.Pattern +import Sound.Tidal.UI (while) -cat :: [T.Pattern a] -> T.Pattern a -cat pats = T.timecat $ map (\pat -> (fromMaybe 1 $ T.tactus pat, pat)) pats +stepcat :: [Pattern a] -> Pattern a +stepcat pats = timecat $ map (\pat -> (fromMaybe 1 $ tactus pat, pat)) pats -_add :: Rational -> T.Pattern a -> T.Pattern a +_stepadd :: Rational -> Pattern a -> Pattern a -- raise error? -_add _ pat@(T.Pattern _ Nothing _) = pat -_add r pat@(T.Pattern _ (Just t) _) - | r == 0 = T.nothing +_stepadd _ pat@(Pattern _ Nothing _) = pat +_stepadd r pat@(Pattern _ (Just t) _) + | r == 0 = nothing | (abs r) >= t = pat - | r < 0 = T.zoom (1-((abs r)/t),1) pat - | otherwise = T.zoom (0, (r/t)) pat + | r < 0 = zoom (1-((abs r)/t),1) pat + | otherwise = zoom (0, (r/t)) pat -add :: T.Pattern Rational -> T.Pattern a -> T.Pattern a -add = T.tParam _add +stepadd :: Pattern Rational -> Pattern a -> Pattern a +stepadd = tParam _stepadd -_sub :: Rational -> T.Pattern a -> T.Pattern a -_sub _ pat@(T.Pattern _ Nothing _) = pat -_sub r pat@(T.Pattern _ (Just t) _) | r >= t = T.nothing - | r < 0 = _add (0- (t+r)) pat - | otherwise = _add (t-r) pat +_stepsub :: Rational -> Pattern a -> Pattern a +_stepsub _ pat@(Pattern _ Nothing _) = pat +_stepsub r pat@(Pattern _ (Just t) _) | r >= t = nothing + | r < 0 = _stepadd (0- (t+r)) pat + | otherwise = _stepadd (t-r) pat -sub :: T.Pattern Rational -> T.Pattern a -> T.Pattern a -sub = T.tParam _sub +stepsub :: Pattern Rational -> Pattern a -> Pattern a +stepsub = tParam _stepsub -when :: T.Pattern Bool -> (T.Pattern a -> T.Pattern a) -> T.Pattern a -> T.Pattern a -when patb f pat@(T.Pattern _ (Just t) _) = T.while (T._steps t patb) f pat +stepwhen :: Pattern Bool -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +stepwhen patb f pat@(Pattern _ (Just t) _) = while (_steps t patb) f pat -- TODO raise exception? -when _ _ pat = pat - --- _lastof :: Int -> (T.Pattern a -> T.Pattern a) -> T.Pattern a -> T.Pattern a --- _lastof i f pat | i <= 1 = pat --- | otherwise = when (fastcat $ map pure $ (replicate (i-1) False) ++ [True]) f pat - -_lastof :: Int -> (T.Pattern a -> T.Pattern a) -> T.Pattern a -> T.Pattern a -_lastof n f pat | n <= 1 = pat - | otherwise = T._fast t $ cat $ reverse $ (f $ head cycles):tail cycles - where cycles = reverse $ T.separateCycles n $ T._slow t pat - t = fromMaybe 1 $ T.tactus pat - -lastof :: T.Pattern Int -> (T.Pattern a -> T.Pattern a) -> T.Pattern a -> T.Pattern a -lastof (T.Pattern _ _ (Just i)) f pat = _lastof i f pat -lastof tp f p = T.innerJoin $ (\t -> _lastof t f p) <$> tp - -_firstof :: Int -> (T.Pattern a -> T.Pattern a) -> T.Pattern a -> T.Pattern a -_firstof n f pat | n <= 1 = pat - | otherwise = T._fast t $ cat $ (f $ head cycles):tail cycles - where cycles = T.separateCycles n $ T._slow t pat - t = fromMaybe 1 $ T.tactus pat - -firstof :: T.Pattern Int -> (T.Pattern a -> T.Pattern a) -> T.Pattern a -> T.Pattern a -firstof (T.Pattern _ _ (Just i)) f pat = _firstof i f pat -firstof tp f p = T.innerJoin $ (\t -> _firstof t f p) <$> tp - -every :: T.Pattern Int -> (T.Pattern a -> T.Pattern a) -> T.Pattern a -> T.Pattern a -every = firstof - --- | Like @taper@, but returns a list of repetitions -taperlist :: T.Pattern a -> [T.Pattern a] -taperlist pat@(T.Pattern _ (Just t) _) = pat : map (\r -> _sub r pat) [1 .. t] +stepwhen _ _ pat = pat + +-- _steplastof :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +-- _steplastof i f pat | i <= 1 = pat +-- | otherwise = stepwhen (fastcat $ map pure $ (replicate (i-1) False) ++ [True]) f pat + +_steplastof :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +_steplastof n f pat | n <= 1 = pat + | otherwise = _fast t $ stepcat $ reverse $ (f $ head cycles):tail cycles + where cycles = reverse $ separateCycles n $ _slow t pat + t = fromMaybe 1 $ tactus pat + +steplastof :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +steplastof (Pattern _ _ (Just i)) f pat = _steplastof i f pat +steplastof tp f p = innerJoin $ (\t -> _steplastof t f p) <$> tp + +_stepfirstof :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +_stepfirstof n f pat | n <= 1 = pat + | otherwise = _fast t $ stepcat $ (f $ head cycles):tail cycles + where cycles = separateCycles n $ _slow t pat + t = fromMaybe 1 $ tactus pat + +stepfirstof :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +stepfirstof (Pattern _ _ (Just i)) f pat = _stepfirstof i f pat +stepfirstof tp f p = innerJoin $ (\t -> _stepfirstof t f p) <$> tp + +stepevery :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +stepevery = stepfirstof + +-- | Like @steptaper@, but returns a list of repetitions +steptaperlist :: Pattern a -> [Pattern a] +steptaperlist pat@(Pattern _ (Just t) _) = pat : map (\r -> _stepsub r pat) [1 .. t] -- TODO exception? -taperlist pat = [pat] +steptaperlist pat = [pat] --- | Plays one fewer from the pattern each repetition, down to nothing -taper :: T.Pattern a -> T.Pattern a -taper = cat . taperlist +-- | Plays one fewer step from the pattern each repetition, down to nothing +steptaper :: Pattern a -> Pattern a +steptaper = stepcat . steptaperlist -- | Successively plays a pattern from each group in turn -alt :: [[T.Pattern a]] -> T.Pattern a -alt groups = cat $ concat $ take (c * length groups) $ transpose $ map cycle groups +stepalt :: [[Pattern a]] -> Pattern a +stepalt groups = stepcat $ concat $ take (c * length groups) $ transpose $ map cycle groups where c = foldl1 lcm $ map length groups From c7a78102b4d2db7068ebb3ad3cfa8bdf11ca8a8f Mon Sep 17 00:00:00 2001 From: Eric Conlon Date: Tue, 25 Apr 2023 12:14:24 -0700 Subject: [PATCH 25/46] Add Sound.Tidal.Boot module with standard aliases --- BootTidal.hs | 105 ++++++------------ example.tidal | 5 + src/Sound/Tidal/Boot.hs | 231 ++++++++++++++++++++++++++++++++++++++++ tidal.cabal | 4 +- 4 files changed, 272 insertions(+), 73 deletions(-) create mode 100644 example.tidal create mode 100644 src/Sound/Tidal/Boot.hs diff --git a/BootTidal.hs b/BootTidal.hs index c2548d2d3..e3639b5ae 100644 --- a/BootTidal.hs +++ b/BootTidal.hs @@ -1,82 +1,43 @@ +:set -fno-warn-orphans +:set -XMultiParamTypeClasses :set -XOverloadedStrings :set prompt "" -import Sound.Tidal.Context +default (Signal String, Integer, Double) -import System.IO (hSetEncoding, stdout, utf8) -hSetEncoding stdout utf8 +-- Import all the boot functions and aliases. +import Sound.Tidal.Boot -tidal <- startTidal (superdirtTarget {oLatency = 0.05, oAddress = "127.0.0.1", oPort = 57120}) (defaultConfig {cVerbose = True, cFrameTimespan = 1/20}) +-- Create a Tidal Stream with the default settings. +-- Use 'mkTidalWith' to customize these settings. +tidalInst <- mkTidal -:{ -let only = (hush >>) - p = streamReplace tidal - hush = streamHush tidal - panic = do hush - once $ sound "superpanic" - list = streamList tidal - mute = streamMute tidal - unmute = streamUnmute tidal - unmuteAll = streamUnmuteAll tidal - unsoloAll = streamUnsoloAll tidal - solo = streamSolo tidal - unsolo = streamUnsolo tidal - once = streamOnce tidal - first = streamFirst tidal - asap = once - nudgeAll = streamNudgeAll tidal - all = streamAll tidal - resetCycles = streamResetCycles tidal - setCycle = streamSetCycle tidal - setcps = asap . cps - getcps = streamGetCPS tidal - getnow = streamGetNow tidal - xfade i = transition tidal True (Sound.Tidal.Transition.xfadeIn 4) i - xfadeIn i t = transition tidal True (Sound.Tidal.Transition.xfadeIn t) i - histpan i t = transition tidal True (Sound.Tidal.Transition.histpan t) i - wait i t = transition tidal True (Sound.Tidal.Transition.wait t) i - waitT i f t = transition tidal True (Sound.Tidal.Transition.waitT f t) i - jump i = transition tidal True (Sound.Tidal.Transition.jump) i - jumpIn i t = transition tidal True (Sound.Tidal.Transition.jumpIn t) i - jumpIn' i t = transition tidal True (Sound.Tidal.Transition.jumpIn' t) i - jumpMod i t = transition tidal True (Sound.Tidal.Transition.jumpMod t) i - jumpMod' i t p = transition tidal True (Sound.Tidal.Transition.jumpMod' t p) i - mortal i lifespan release = transition tidal True (Sound.Tidal.Transition.mortal lifespan release) i - interpolate i = transition tidal True (Sound.Tidal.Transition.interpolate) i - interpolateIn i t = transition tidal True (Sound.Tidal.Transition.interpolateIn t) i - clutch i = transition tidal True (Sound.Tidal.Transition.clutch) i - clutchIn i t = transition tidal True (Sound.Tidal.Transition.clutchIn t) i - anticipate i = transition tidal True (Sound.Tidal.Transition.anticipate) i - anticipateIn i t = transition tidal True (Sound.Tidal.Transition.anticipateIn t) i - forId i t = transition tidal False (Sound.Tidal.Transition.mortalOverlay t) i - d1 = p 1 . (|< orbit 0) - d2 = p 2 . (|< orbit 1) - d3 = p 3 . (|< orbit 2) - d4 = p 4 . (|< orbit 3) - d5 = p 5 . (|< orbit 4) - d6 = p 6 . (|< orbit 5) - d7 = p 7 . (|< orbit 6) - d8 = p 8 . (|< orbit 7) - d9 = p 9 . (|< orbit 8) - d10 = p 10 . (|< orbit 9) - d11 = p 11 . (|< orbit 10) - d12 = p 12 . (|< orbit 11) - d13 = p 13 - d14 = p 14 - d15 = p 15 - d16 = p 16 -:} +-- This orphan instance makes the boot aliases work! +-- It has to go after you define 'tidalInst'. +instance Tidally where tidal = tidalInst -:{ -let getState = streamGet tidal - setI = streamSetI tidal - setF = streamSetF tidal - setS = streamSetS tidal - setR = streamSetR tidal - setB = streamSetB tidal -:} +-- You can add your own aliases in this file. Here are some examples: +-- :{ +-- let xfade i = transition tidal True (Sound.Tidal.Transition.xfadeIn 4) i +-- xfadeIn i t = transition tidal True (Sound.Tidal.Transition.xfadeIn t) i +-- histpan i t = transition tidal True (Sound.Tidal.Transition.histpan t) i +-- wait i t = transition tidal True (Sound.Tidal.Transition.wait t) i +-- waitT i f t = transition tidal True (Sound.Tidal.Transition.waitT f t) i +-- jump i = transition tidal True (Sound.Tidal.Transition.jump) i +-- jumpIn i t = transition tidal True (Sound.Tidal.Transition.jumpIn t) i +-- jumpIn' i t = transition tidal True (Sound.Tidal.Transition.jumpIn' t) i +-- jumpMod i t = transition tidal True (Sound.Tidal.Transition.jumpMod t) i +-- jumpMod' i t p = transition tidal True (Sound.Tidal.Transition.jumpMod' t p) i +-- mortal i lifespan release = transition tidal True (Sound.Tidal.Transition.mortal lifespan release) i +-- interpolate i = transition tidal True (Sound.Tidal.Transition.interpolate) i +-- interpolateIn i t = transition tidal True (Sound.Tidal.Transition.interpolateIn t) i +-- clutch i = transition tidal True (Sound.Tidal.Transition.clutch) i +-- clutchIn i t = transition tidal True (Sound.Tidal.Transition.clutchIn t) i +-- anticipate i = transition tidal True (Sound.Tidal.Transition.anticipate) i +-- anticipateIn i t = transition tidal True (Sound.Tidal.Transition.anticipateIn t) i +-- forId i t = transition tidal False (Sound.Tidal.Transition.mortalOverlay t) i +-- :} +:set -fwarn-orphans :set prompt "tidal> " :set prompt-cont "" - -default (Pattern String, Integer, Double) diff --git a/example.tidal b/example.tidal new file mode 100644 index 000000000..795b44045 --- /dev/null +++ b/example.tidal @@ -0,0 +1,5 @@ +-- This is an example file you can use to quickly test Tidal editor integration. + +d1 $ s "bd sd bd [~ sd] bd sd bd*3 sd" + +hush diff --git a/src/Sound/Tidal/Boot.hs b/src/Sound/Tidal/Boot.hs new file mode 100644 index 000000000..124d06835 --- /dev/null +++ b/src/Sound/Tidal/Boot.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module Sound.Tidal.Boot + ( Tidally (..) + , OscMap + , mkConfig + , mkOscMap + , mkTidal + , mkTidalWith + , only + , p + , hush + , panic + , list + , mute + , unmute + , unmuteAll + , unsoloAll + , solo + , unsolo + , once + , asap + , first + , nudgeAll + , all + , resetCycles + , setCycle + , setcps + , getcps + , getnow + , d1 + , d2 + , d3 + , d4 + , d5 + , d6 + , d7 + , d8 + , d9 + , d10 + , d11 + , d12 + , d13 + , d14 + , d15 + , d16 + , getState + , setI + , setF + , setS + , setR + , setB + , module Sound.Tidal.Context + ) +where + +{- + Boot.hs - Shortcuts for using an in-scope Tidal Stream. + Copyright (C) 2023, 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 . +-} + +import Prelude hiding (all, (*>), (<*)) +import Sound.Tidal.Context hiding (mute, solo) +import Sound.Tidal.ID (ID) +import System.IO (hSetEncoding, stdout, utf8) + +-- | Functions using this constraint can access the in-scope Tidal instance. +-- You must implement an instance of this in 'BootTidal.hs'. Note that GHC +-- will complain that it is an "orphan" instance, but that is ok. +class Tidally where + tidal :: Stream + +type OscMap = [(Target, [OSC])] + +-- | A reasonable config. +mkConfig :: Config +mkConfig = defaultConfig {cVerbose = True, cFrameTimespan = 1 / 20} + +-- | A reasonable OscMap +mkOscMap :: OscMap +mkOscMap = [(superdirtTarget {oLatency = 0.05, oAddress = "127.0.0.1", oPort = 57120}, [superdirtShape])] + +-- | Creates a Tidal instance using default config. Use 'mkTidalWith' to customize. +mkTidal :: IO Stream +mkTidal = mkTidalWith mkConfig mkOscMap + +-- | See 'Sound.Tidal.Stream.startStream'. +mkTidalWith :: Config -> OscMap -> IO Stream +mkTidalWith config oscmap = do + hSetEncoding stdout utf8 + startStream config oscmap + +-- | 'hush' then execute the given action. +only :: Tidally => IO () -> IO () +only = (hush >>) + +-- | See 'Sound.Tidal.Stream.streamReplace'. +p :: Tidally => ID -> ControlSignal -> IO () +p = streamReplace tidal + +-- | See 'Sound.Tidal.Stream.streamHush'. +hush :: Tidally => IO () +hush = streamHush tidal + +panic :: Tidally => IO () +panic = hush >> once (sound "superpanic") + +-- | See 'Sound.Tidal.Stream.streamList'. +list :: Tidally => IO () +list = streamList tidal + +-- | See 'Sound.Tidal.Stream.streamMute'. +mute :: Tidally => ID -> IO () +mute = streamMute tidal + +-- | See 'Sound.Tidal.Stream.streamUnmute'. +unmute :: Tidally => ID -> IO () +unmute = streamUnmute tidal + +-- | See 'Sound.Tidal.Stream.streamUnmuteAll'. +unmuteAll :: Tidally => IO () +unmuteAll = streamUnmuteAll tidal + +-- | See 'Sound.Tidal.Stream.streamUnsoloAll'. +unsoloAll :: Tidally => IO () +unsoloAll = streamUnsoloAll tidal + +-- | See 'Sound.Tidal.Stream.streamSolo'. +solo :: Tidally => ID -> IO () +solo = streamSolo tidal + +-- | See 'Sound.Tidal.Stream.streamUnsolo'. +unsolo :: Tidally => ID -> IO () +unsolo = streamUnsolo tidal + +-- | See 'Sound.Tidal.Stream.streamOnce'. +once :: Tidally => ControlSignal -> IO () +once = streamOnce tidal + +-- | An alias for 'once'. +asap :: Tidally => ControlSignal -> IO () +asap = once + +-- | See 'Sound.Tidal.Stream.first'. +first :: Tidally => ControlSignal -> IO () +first = streamFirst tidal + +-- | See 'Sound.Tidal.Stream.nudgeAll'. +nudgeAll :: Tidally => Double -> IO () +nudgeAll = streamNudgeAll tidal + +-- | See 'Sound.Tidal.Stream.streamAll'. +all :: Tidally => (ControlSignal -> ControlSignal) -> IO () +all = streamAll tidal + +-- | See 'Sound.Tidal.Stream.resetCycles'. +resetCycles :: Tidally => IO () +resetCycles = streamResetCycles tidal + +-- | See 'Sound.Tidal.Stream.streamSetCycle'. +setCycle :: Tidally => Time -> IO () +setCycle = streamSetCycle tidal + +-- | See 'Sound.Tidal.Params.cps'. +setcps :: Tidally => Signal Double -> IO () +setcps = once . cps + +-- | See 'Sound.Tidal.Stream.streamGetcps'. +getcps :: Tidally => IO Double +getcps = streamGetcps tidal + +-- | See 'Sound.Tidal.Stream.streamGetnow'. +getnow :: Tidally => IO Double +getnow = streamGetnow tidal + +-- | Replace what's playing on the given orbit. +d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12, d13, d14, d15, d16 :: Tidally => ControlSignal -> IO () +d1 = p 1 . (|. orbit 0) +d2 = p 2 . (|. orbit 1) +d3 = p 3 . (|. orbit 2) +d4 = p 4 . (|. orbit 3) +d5 = p 5 . (|. orbit 4) +d6 = p 6 . (|. orbit 5) +d7 = p 7 . (|. orbit 6) +d8 = p 8 . (|. orbit 7) +d9 = p 9 . (|. orbit 8) +d10 = p 10 . (|. orbit 9) +d11 = p 11 . (|. orbit 10) +d12 = p 12 . (|. orbit 11) +d13 = p 13 +d14 = p 14 +d15 = p 15 +d16 = p 16 + +-- | See 'Sound.Tidal.Stream.streamGet'. +getState :: Tidally => String -> IO (Maybe Value) +getState = streamGet tidal + +-- | See 'Sound.Tidal.Stream.streamSetI'. +setI :: Tidally => String -> Signal Int -> IO () +setI = streamSetI tidal + +-- | See 'Sound.Tidal.Stream.streamSetF'. +setF :: Tidally => String -> Signal Double -> IO () +setF = streamSetF tidal + +-- | See 'Sound.Tidal.Stream.streamSetS'. +setS :: Tidally => String -> Signal String -> IO () +setS = streamSetS tidal + +-- | See 'Sound.Tidal.Stream.streamSetR'. +setR :: Tidally => String -> Signal Rational -> IO () +setR = streamSetR tidal + +-- | See 'Sound.Tidal.Stream.streamSetB'. +setB :: Tidally => String -> Signal Bool -> IO () +setB = streamSetB tidal diff --git a/tidal.cabal b/tidal.cabal index 453437587..77af41dc4 100644 --- a/tidal.cabal +++ b/tidal.cabal @@ -27,7 +27,9 @@ library autogen-modules: Paths_tidal - Exposed-modules: Sound.Tidal.Bjorklund + Exposed-modules: Sound.Tidal.Arc + Sound.Tidal.Bjorklund + Sound.Tidal.Boot Sound.Tidal.Chords Sound.Tidal.Control Sound.Tidal.Context From 73d5f4d5e4212bfe4b699a7e79e1ad1bff956964 Mon Sep 17 00:00:00 2001 From: Matthew Kaney Date: Fri, 12 Apr 2024 13:44:57 -0400 Subject: [PATCH 26/46] Update clock function names in Boot --- src/Sound/Tidal/Boot.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Sound/Tidal/Boot.hs b/src/Sound/Tidal/Boot.hs index 124d06835..6d95fc620 100644 --- a/src/Sound/Tidal/Boot.hs +++ b/src/Sound/Tidal/Boot.hs @@ -181,11 +181,11 @@ setcps = once . cps -- | See 'Sound.Tidal.Stream.streamGetcps'. getcps :: Tidally => IO Double -getcps = streamGetcps tidal +getcps = streamGetCPS tidal -- | See 'Sound.Tidal.Stream.streamGetnow'. getnow :: Tidally => IO Double -getnow = streamGetnow tidal +getnow = streamGetNow tidal -- | Replace what's playing on the given orbit. d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12, d13, d14, d15, d16 :: Tidally => ControlSignal -> IO () From a00ed41bbe741a9a39afaa5b1d9003293eb7cc29 Mon Sep 17 00:00:00 2001 From: alex Date: Sat, 13 Apr 2024 12:29:43 +0100 Subject: [PATCH 27/46] separate stepfirstof and stepfirstofstep. need better names for these.. --- src/Sound/Tidal/Stepwise.hs | 48 +++++++++++++++++++++++-------------- src/Sound/Tidal/Utils.hs | 11 ++++++--- 2 files changed, 38 insertions(+), 21 deletions(-) diff --git a/src/Sound/Tidal/Stepwise.hs b/src/Sound/Tidal/Stepwise.hs index ea178d8b9..703795609 100644 --- a/src/Sound/Tidal/Stepwise.hs +++ b/src/Sound/Tidal/Stepwise.hs @@ -25,6 +25,7 @@ import Data.Maybe (fromMaybe) import Sound.Tidal.Core import Sound.Tidal.Pattern import Sound.Tidal.UI (while) +import Sound.Tidal.Utils (applyWhen) stepcat :: [Pattern a] -> Pattern a stepcat pats = timecat $ map (\pat -> (fromMaybe 1 $ tactus pat, pat)) pats @@ -55,29 +56,28 @@ stepwhen patb f pat@(Pattern _ (Just t) _) = while (_steps t patb) f pat -- TODO raise exception? stepwhen _ _ pat = pat --- _steplastof :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a --- _steplastof i f pat | i <= 1 = pat --- | otherwise = stepwhen (fastcat $ map pure $ (replicate (i-1) False) ++ [True]) f pat - -_steplastof :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -_steplastof n f pat | n <= 1 = pat - | otherwise = _fast t $ stepcat $ reverse $ (f $ head cycles):tail cycles - where cycles = reverse $ separateCycles n $ _slow t pat +_stepevery :: Bool -> Bool -> Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +_stepevery lastone stepwise n f pat + | n <= 1 = pat + | otherwise = applyWhen stepwise (_fast t) $ stepcat $ applyWhen lastone reverse $ (f $ head cycles):tail cycles + where cycles = applyWhen lastone reverse $ separateCycles n $ applyWhen stepwise (_slow t) pat t = fromMaybe 1 $ tactus pat steplastof :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -steplastof (Pattern _ _ (Just i)) f pat = _steplastof i f pat -steplastof tp f p = innerJoin $ (\t -> _steplastof t f p) <$> tp - -_stepfirstof :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -_stepfirstof n f pat | n <= 1 = pat - | otherwise = _fast t $ stepcat $ (f $ head cycles):tail cycles - where cycles = separateCycles n $ _slow t pat - t = fromMaybe 1 $ tactus pat +steplastof (Pattern _ _ (Just i)) f pat = _stepevery True False i f pat +steplastof tp f p = innerJoin $ (\t -> _stepevery True False t f p) <$> tp stepfirstof :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -stepfirstof (Pattern _ _ (Just i)) f pat = _stepfirstof i f pat -stepfirstof tp f p = innerJoin $ (\t -> _stepfirstof t f p) <$> tp +stepfirstof (Pattern _ _ (Just i)) f pat = _stepevery False False i f pat +stepfirstof tp f p = innerJoin $ (\t -> _stepevery False False t f p) <$> tp + +steplastofstep :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +steplastofstep (Pattern _ _ (Just i)) f pat = _stepevery True True i f pat +steplastofstep tp f p = innerJoin $ (\t -> _stepevery True True t f p) <$> tp + +stepfirstofstep :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +stepfirstofstep (Pattern _ _ (Just i)) f pat = _stepevery False True i f pat +stepfirstofstep tp f p = innerJoin $ (\t -> _stepevery False True t f p) <$> tp stepevery :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a stepevery = stepfirstof @@ -96,3 +96,15 @@ steptaper = stepcat . steptaperlist stepalt :: [[Pattern a]] -> Pattern a stepalt groups = stepcat $ concat $ take (c * length groups) $ transpose $ map cycle groups where c = foldl1 lcm $ map length groups + +_stepexpand :: Rational -> Pattern a -> Pattern a +_stepexpand factor pat = withTactus (* factor) pat + +_stepcontract :: Rational -> Pattern a -> Pattern a +_stepcontract factor pat = withTactus (/ factor) pat + +stepexpand :: Pattern Rational -> Pattern a -> Pattern a +stepexpand = tParam _stepexpand + +stepcontract :: Pattern Rational -> Pattern a -> Pattern a +stepcontract = tParam _stepcontract diff --git a/src/Sound/Tidal/Utils.hs b/src/Sound/Tidal/Utils.hs index d9955aa63..e2c7568a7 100644 --- a/src/Sound/Tidal/Utils.hs +++ b/src/Sound/Tidal/Utils.hs @@ -18,8 +18,8 @@ module Sound.Tidal.Utils where along with this library. If not, see . -} -import Data.List (delete) -import System.IO (hPutStrLn, stderr) +import Data.List (delete) +import System.IO (hPutStrLn, stderr) writeError :: String -> IO () writeError = hPutStrLn stderr @@ -71,7 +71,7 @@ nth 0 (x : _) = Just x nth n (_ : xs) = nth (n - 1) xs accumulate :: Num t => [t] -> [t] -accumulate [] = [] +accumulate [] = [] accumulate (x:xs) = scanl (+) x xs {- | enumerate a list of things @@ -101,3 +101,8 @@ matchMaybe x _ = x fromRight :: b -> Either a b -> b fromRight _ (Right b) = b fromRight b _ = b + +-- Available in Data.Function, but only since 4.18 +applyWhen :: Bool -> (a -> a) -> a -> a +applyWhen True f x = f x +applyWhen False _ x = x From db9c29eaa3cc6d57a057502692e9d5e3b7241914 Mon Sep 17 00:00:00 2001 From: Matthew Kaney Date: Sat, 13 Apr 2024 11:33:16 -0400 Subject: [PATCH 28/46] Remove 2.0 signals and Arc module --- src/Sound/Tidal/Boot.hs | 24 ++++++++++++------------ tidal.cabal | 3 +-- 2 files changed, 13 insertions(+), 14 deletions(-) diff --git a/src/Sound/Tidal/Boot.hs b/src/Sound/Tidal/Boot.hs index 6d95fc620..40803c5e7 100644 --- a/src/Sound/Tidal/Boot.hs +++ b/src/Sound/Tidal/Boot.hs @@ -109,7 +109,7 @@ only :: Tidally => IO () -> IO () only = (hush >>) -- | See 'Sound.Tidal.Stream.streamReplace'. -p :: Tidally => ID -> ControlSignal -> IO () +p :: Tidally => ID -> ControlPattern -> IO () p = streamReplace tidal -- | See 'Sound.Tidal.Stream.streamHush'. @@ -148,15 +148,15 @@ unsolo :: Tidally => ID -> IO () unsolo = streamUnsolo tidal -- | See 'Sound.Tidal.Stream.streamOnce'. -once :: Tidally => ControlSignal -> IO () +once :: Tidally => ControlPattern -> IO () once = streamOnce tidal -- | An alias for 'once'. -asap :: Tidally => ControlSignal -> IO () +asap :: Tidally => ControlPattern -> IO () asap = once -- | See 'Sound.Tidal.Stream.first'. -first :: Tidally => ControlSignal -> IO () +first :: Tidally => ControlPattern -> IO () first = streamFirst tidal -- | See 'Sound.Tidal.Stream.nudgeAll'. @@ -164,7 +164,7 @@ nudgeAll :: Tidally => Double -> IO () nudgeAll = streamNudgeAll tidal -- | See 'Sound.Tidal.Stream.streamAll'. -all :: Tidally => (ControlSignal -> ControlSignal) -> IO () +all :: Tidally => (ControlPattern -> ControlPattern) -> IO () all = streamAll tidal -- | See 'Sound.Tidal.Stream.resetCycles'. @@ -176,7 +176,7 @@ setCycle :: Tidally => Time -> IO () setCycle = streamSetCycle tidal -- | See 'Sound.Tidal.Params.cps'. -setcps :: Tidally => Signal Double -> IO () +setcps :: Tidally => Pattern Double -> IO () setcps = once . cps -- | See 'Sound.Tidal.Stream.streamGetcps'. @@ -188,7 +188,7 @@ getnow :: Tidally => IO Double getnow = streamGetNow tidal -- | Replace what's playing on the given orbit. -d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12, d13, d14, d15, d16 :: Tidally => ControlSignal -> IO () +d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12, d13, d14, d15, d16 :: Tidally => ControlPattern -> IO () d1 = p 1 . (|. orbit 0) d2 = p 2 . (|. orbit 1) d3 = p 3 . (|. orbit 2) @@ -211,21 +211,21 @@ getState :: Tidally => String -> IO (Maybe Value) getState = streamGet tidal -- | See 'Sound.Tidal.Stream.streamSetI'. -setI :: Tidally => String -> Signal Int -> IO () +setI :: Tidally => String -> Pattern Int -> IO () setI = streamSetI tidal -- | See 'Sound.Tidal.Stream.streamSetF'. -setF :: Tidally => String -> Signal Double -> IO () +setF :: Tidally => String -> Pattern Double -> IO () setF = streamSetF tidal -- | See 'Sound.Tidal.Stream.streamSetS'. -setS :: Tidally => String -> Signal String -> IO () +setS :: Tidally => String -> Pattern String -> IO () setS = streamSetS tidal -- | See 'Sound.Tidal.Stream.streamSetR'. -setR :: Tidally => String -> Signal Rational -> IO () +setR :: Tidally => String -> Pattern Rational -> IO () setR = streamSetR tidal -- | See 'Sound.Tidal.Stream.streamSetB'. -setB :: Tidally => String -> Signal Bool -> IO () +setB :: Tidally => String -> Pattern Bool -> IO () setB = streamSetB tidal diff --git a/tidal.cabal b/tidal.cabal index 77af41dc4..3fc9ef7e5 100644 --- a/tidal.cabal +++ b/tidal.cabal @@ -27,8 +27,7 @@ library autogen-modules: Paths_tidal - Exposed-modules: Sound.Tidal.Arc - Sound.Tidal.Bjorklund + Exposed-modules: Sound.Tidal.Bjorklund Sound.Tidal.Boot Sound.Tidal.Chords Sound.Tidal.Control From 82280fc7b6a2abb4b22109e58a1ddcdbb12ed50c Mon Sep 17 00:00:00 2001 From: alex Date: Sat, 13 Apr 2024 19:59:53 +0100 Subject: [PATCH 29/46] rename step prefixes to s_, rename tParam to patternify, add patternify variants to preserve tactus of source pattern in certain cases --- src/Sound/Tidal/Control.hs | 45 ++++++++-------- src/Sound/Tidal/Core.hs | 10 ++-- src/Sound/Tidal/Pattern.hs | 40 +++++++++------ src/Sound/Tidal/Stepwise.hs | 100 ++++++++++++++++++------------------ src/Sound/Tidal/UI.hs | 55 ++++++++++---------- 5 files changed, 132 insertions(+), 118 deletions(-) diff --git a/src/Sound/Tidal/Control.hs b/src/Sound/Tidal/Control.hs index 434b87159..c59c32455 100644 --- a/src/Sound/Tidal/Control.hs +++ b/src/Sound/Tidal/Control.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE FlexibleInstances, OverloadedStrings, FlexibleContexts, BangPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} module Sound.Tidal.Control where {- @@ -21,18 +24,18 @@ module Sound.Tidal.Control where along with this library. If not, see . -} -import Prelude hiding ((<*), (*>)) +import Prelude hiding ((*>), (<*)) -import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe, isJust, fromJust) -import Data.Ratio +import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust, fromMaybe, isJust) +import Data.Ratio -import Sound.Tidal.Pattern -import Sound.Tidal.Core -import Sound.Tidal.Stream.Types (patternTimeID) -import Sound.Tidal.UI -import qualified Sound.Tidal.Params as P -import Sound.Tidal.Utils +import Sound.Tidal.Core +import qualified Sound.Tidal.Params as P +import Sound.Tidal.Pattern +import Sound.Tidal.Stream.Types (patternTimeID) +import Sound.Tidal.UI +import Sound.Tidal.Utils {- | `spin` will "spin" and layer up a pattern the given number of times, with each successive layer offset in time by an additional @1/n@ of a cycle, @@ -44,7 +47,7 @@ around. This function work well on multichannel systems. > $ sound "drum*3 tabla:4 [arpy:2 ~ arpy] [can:2 can:3]" -} spin :: Pattern Int -> ControlPattern -> ControlPattern -spin = tParam _spin +spin = patternify _spin _spin :: Int -> ControlPattern -> ControlPattern _spin copies p = @@ -87,13 +90,13 @@ _spin copies p = > d1 $ loopAt 8 $ rev $ chop 32 $ sound "bev" -} chop :: Pattern Int -> ControlPattern -> ControlPattern -chop = tParam _chop +chop = patternify _chop chopArc :: Arc -> Int -> [Arc] chopArc (Arc s e) n = map (\i -> Arc (s + (e-s)*(fromIntegral i/fromIntegral n)) (s + (e-s)*(fromIntegral (i+1) / fromIntegral n))) [0 .. n-1] _chop :: Int -> ControlPattern -> ControlPattern -_chop n = withEvents (concatMap chopEvent) +_chop n pat = withTactus (* toRational n) $ withEvents (concatMap chopEvent) pat where -- for each part, chopEvent :: Event ValueMap -> [Event ValueMap] chopEvent (Event c (Just w) p' v) = map (chomp c v (length $ chopArc w n)) $ arcs w p' @@ -152,10 +155,10 @@ and manipulates those parts by reversing and rotating the loops: -} striate :: Pattern Int -> ControlPattern -> ControlPattern -striate = tParam _striate +striate = patternify _striate _striate :: Int -> ControlPattern -> ControlPattern -_striate n p = fastcat $ map offset [0 .. n-1] +_striate n p = keepTactus (withTactus (* toRational n) p) $ fastcat $ map offset [0 .. n-1] where offset i = mergePlayRange (fromIntegral i / fromIntegral n, fromIntegral (i+1) / fromIntegral n) <$> p mergePlayRange :: (Double, Double) -> ValueMap -> ValueMap @@ -180,7 +183,7 @@ internally. This means that you probably shouldn't also specify `begin` or `end`. -} striateBy :: Pattern Int -> Pattern Double -> ControlPattern -> ControlPattern -striateBy = tParam2 _striateBy +striateBy = patternify2 _striateBy -- | DEPRECATED, use 'striateBy' instead. striate' :: Pattern Int -> Pattern Double -> ControlPattern -> ControlPattern @@ -201,7 +204,7 @@ each sample is chopped into: -} gap :: Pattern Int -> ControlPattern -> ControlPattern -gap = tParam _gap +gap = patternify _gap _gap :: Int -> ControlPattern -> ControlPattern _gap n p = _fast (toRational n) (cat [pure 1, silence]) |>| _chop n p @@ -336,7 +339,7 @@ _slice n i p = > d1 $ fast 4 $ randslice 32 $ sound "bev" -} randslice :: Pattern Int -> ControlPattern -> ControlPattern -randslice = tParam $ \n p -> innerJoin $ (\i -> _slice n i p) <$> _irand n +randslice = patternify $ \n p -> keepTactus (withTactus (* (toRational n)) $ p) $ innerJoin $ (\i -> _slice n i p) <$> _irand n _splice :: Int -> Pattern Int -> ControlPattern -> Pattern (Map.Map String Value) _splice bits ipat pat = withEvent f (slice (pure bits) ipat pat) # P.unit (pure "c") @@ -441,7 +444,7 @@ smash' n xs p = slowcat $ map (`slow` p') xs > d1 $ echo 4 (-0.2) 0.5 $ sound "bd sn" -} echo :: Pattern Integer -> Pattern Rational -> Pattern Double -> ControlPattern -> ControlPattern -echo = tParam3 _echo +echo = patternify3' _echo _echo :: Integer -> Rational -> Double -> ControlPattern -> ControlPattern _echo count time feedback p = _echoWith count time (|* P.gain (pure $ feedback)) p @@ -470,7 +473,7 @@ _echoWith count time f p | count <= 1 = p -- | DEPRECATED, use 'echo' instead stut :: Pattern Integer -> Pattern Double -> Pattern Rational -> ControlPattern -> ControlPattern -stut = tParam3 _stut +stut = patternify3' _stut _stut :: Integer -> Double -> Rational -> ControlPattern -> ControlPattern _stut count feedback steptime p = stack (p:map (\x -> ((x%1)*steptime) `rotR` (p |* P.gain (pure $ scalegain (fromIntegral x)))) [1..(count-1)]) diff --git a/src/Sound/Tidal/Core.hs b/src/Sound/Tidal/Core.hs index e5af1fbfb..071eeeae7 100644 --- a/src/Sound/Tidal/Core.hs +++ b/src/Sound/Tidal/Core.hs @@ -428,11 +428,11 @@ stack = foldr overlay silence -- | Shifts a pattern back in time by the given amount, expressed in cycles (<~) :: Pattern Time -> Pattern a -> Pattern a -(<~) = tParam rotL +(<~) = patternify' rotL -- | Shifts a pattern forward in time by the given amount, expressed in cycles (~>) :: Pattern Time -> Pattern a -> Pattern a -(~>) = tParam rotR +(~>) = patternify' rotR {-| Slow down a pattern by the factors in the given time pattern, "squeezing" the pattern to fit the slot given in the time pattern. It is the slow analogue @@ -457,7 +457,7 @@ stack = foldr overlay silence > d1 $ s "bd*4 bd*2 [bd bd/2]" -} slowSqueeze :: Pattern Time -> Pattern a -> Pattern a -slowSqueeze = tParamSqueeze _slow +slowSqueeze = patternifySqueeze _slow -- | An alias for @slow@ sparsity :: Pattern Time -> Pattern a -> Pattern a @@ -492,7 +492,7 @@ zoomArc (Arc s e) p = withTactus (*d) $ splitQueries $ would be empty). The factor should be at least 1. -} fastGap :: Pattern Time -> Pattern a -> Pattern a -fastGap = tParam _fastGap +fastGap = patternify _fastGap -- | An alias for @fastGap@ densityGap :: Pattern Time -> Pattern a -> Pattern a @@ -523,7 +523,7 @@ compressTo :: (Time,Time) -> Pattern a -> Pattern a compressTo (s,e) = compressArcTo (Arc s e) repeatCycles :: Pattern Int -> Pattern a -> Pattern a -repeatCycles = tParam _repeatCycles +repeatCycles = patternify _repeatCycles _repeatCycles :: Int -> Pattern a -> Pattern a _repeatCycles n p = cat (replicate n p) diff --git a/src/Sound/Tidal/Pattern.hs b/src/Sound/Tidal/Pattern.hs index 122010d0b..7d8a2a2c4 100644 --- a/src/Sound/Tidal/Pattern.hs +++ b/src/Sound/Tidal/Pattern.hs @@ -74,7 +74,7 @@ _steps target p@(Pattern _ (Just t) _) = setTactus target $ _fast (target / t) p _steps _ p = p steps :: Pattern Rational -> Pattern a -> Pattern a -steps = tParam _steps +steps = patternify _steps keepMeta :: Pattern a -> Pattern a -> Pattern a keepMeta from to = to {tactus = tactus from, pureValue = pureValue from} @@ -555,7 +555,7 @@ second half: > d1 $ fast "2 4" $ sound "bd sn kurt cp" -} fast :: Pattern Time -> Pattern a -> Pattern a -fast t pat = keepTactus pat $ tParam _fast t pat +fast t pat = patternify' _fast t pat {-| @fastSqueeze@ speeds up a pattern by a time pattern given as input, squeezing the resulting pattern inside one cycle and playing the original @@ -590,7 +590,7 @@ fast t pat = keepTactus pat $ tParam _fast t pat > d1 $ s "[bd sn]*2" -} fastSqueeze :: Pattern Time -> Pattern a -> Pattern a -fastSqueeze = tParamSqueeze _fast +fastSqueeze = patternifySqueeze _fast -- | An alias for @fast@ density :: Pattern Time -> Pattern a -> Pattern a @@ -611,7 +611,7 @@ _fast rate pat | rate == 0 = silence > # slow 3 (vowel "a e o") -} slow :: Pattern Time -> Pattern a -> Pattern a -slow = tParam _slow +slow = patternify _slow _slow :: Time -> Pattern a -> Pattern a _slow 0 _ = silence _slow r p = _fast (1/r) p @@ -747,20 +747,30 @@ separateCycles n pat = map (\i -> skip $ rotL (toRational i) pat) [0 .. n-1] -- ** Temporal parameter helpers -tParam :: (t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a -tParam f (Pattern _ _ (Just a)) b = f a b -tParam f pa p = innerJoin $ (`f` p) <$> pa +patternify :: (t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a +patternify f (Pattern _ _ (Just a)) b = f a b +patternify f pa p = innerJoin $ (`f` p) <$> pa -tParam2 :: (a -> b -> c -> Pattern d) -> Pattern a -> Pattern b -> c -> Pattern d -tParam2 f (Pattern _ _ (Just a)) (Pattern _ _ (Just b)) c = f a b c -tParam2 f a b p = innerJoin $ (\x y -> f x y p) <$> a <*> b +-- versions that preserve the tactus +patternify' ::(b -> Pattern c -> Pattern a) -> Pattern b -> Pattern c -> Pattern a +patternify' f pa p = (patternify f pa p) {tactus = tactus p} -tParam3 :: (a -> b -> c -> Pattern d -> Pattern e) -> (Pattern a -> Pattern b -> Pattern c -> Pattern d -> Pattern e) -tParam3 f (Pattern _ _ (Just a)) (Pattern _ _ (Just b)) (Pattern _ _ (Just c)) d = f a b c d -tParam3 f a b c p = innerJoin $ (\x y z -> f x y z p) <$> a <*> b <*> c +patternify2 :: (a -> b -> c -> Pattern d) -> Pattern a -> Pattern b -> c -> Pattern d +patternify2 f (Pattern _ _ (Just a)) (Pattern _ _ (Just b)) c = f a b c +patternify2 f a b p = innerJoin $ (\x y -> f x y p) <$> a <*> b -tParamSqueeze :: (a -> Pattern b -> Pattern c) -> (Pattern a -> Pattern b -> Pattern c) -tParamSqueeze f tv p = squeezeJoin $ (`f` p) <$> tv +patternify2' :: (a -> b -> Pattern c -> Pattern d) -> Pattern a -> Pattern b -> Pattern c -> Pattern d +patternify2' f a b p = patternify2 f a b p + +patternify3 :: (a -> b -> c -> Pattern d -> Pattern e) -> (Pattern a -> Pattern b -> Pattern c -> Pattern d -> Pattern e) +patternify3 f (Pattern _ _ (Just a)) (Pattern _ _ (Just b)) (Pattern _ _ (Just c)) d = f a b c d +patternify3 f a b c p = innerJoin $ (\x y z -> f x y z p) <$> a <*> b <*> c + +patternify3' :: (a -> b -> c -> Pattern d -> Pattern e) -> (Pattern a -> Pattern b -> Pattern c -> Pattern d -> Pattern e) +patternify3' f a b c p = keepTactus p $ patternify3 f a b c p + +patternifySqueeze :: (a -> Pattern b -> Pattern c) -> (Pattern a -> Pattern b -> Pattern c) +patternifySqueeze f tv p = squeezeJoin $ (`f` p) <$> tv -- ** Context diff --git a/src/Sound/Tidal/Stepwise.hs b/src/Sound/Tidal/Stepwise.hs index 703795609..701f1804a 100644 --- a/src/Sound/Tidal/Stepwise.hs +++ b/src/Sound/Tidal/Stepwise.hs @@ -27,84 +27,84 @@ import Sound.Tidal.Pattern import Sound.Tidal.UI (while) import Sound.Tidal.Utils (applyWhen) -stepcat :: [Pattern a] -> Pattern a -stepcat pats = timecat $ map (\pat -> (fromMaybe 1 $ tactus pat, pat)) pats +s_cat :: [Pattern a] -> Pattern a +s_cat pats = timecat $ map (\pat -> (fromMaybe 1 $ tactus pat, pat)) pats -_stepadd :: Rational -> Pattern a -> Pattern a +_s_add :: Rational -> Pattern a -> Pattern a -- raise error? -_stepadd _ pat@(Pattern _ Nothing _) = pat -_stepadd r pat@(Pattern _ (Just t) _) +_s_add _ pat@(Pattern _ Nothing _) = pat +_s_add r pat@(Pattern _ (Just t) _) | r == 0 = nothing | (abs r) >= t = pat | r < 0 = zoom (1-((abs r)/t),1) pat | otherwise = zoom (0, (r/t)) pat -stepadd :: Pattern Rational -> Pattern a -> Pattern a -stepadd = tParam _stepadd +s_add :: Pattern Rational -> Pattern a -> Pattern a +s_add = patternify _s_add -_stepsub :: Rational -> Pattern a -> Pattern a -_stepsub _ pat@(Pattern _ Nothing _) = pat -_stepsub r pat@(Pattern _ (Just t) _) | r >= t = nothing - | r < 0 = _stepadd (0- (t+r)) pat - | otherwise = _stepadd (t-r) pat +_s_sub :: Rational -> Pattern a -> Pattern a +_s_sub _ pat@(Pattern _ Nothing _) = pat +_s_sub r pat@(Pattern _ (Just t) _) | r >= t = nothing + | r < 0 = _s_add (0- (t+r)) pat + | otherwise = _s_add (t-r) pat -stepsub :: Pattern Rational -> Pattern a -> Pattern a -stepsub = tParam _stepsub +s_sub :: Pattern Rational -> Pattern a -> Pattern a +s_sub = patternify _s_sub -stepwhen :: Pattern Bool -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -stepwhen patb f pat@(Pattern _ (Just t) _) = while (_steps t patb) f pat +s_when :: Pattern Bool -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +s_when patb f pat@(Pattern _ (Just t) _) = while (_steps t patb) f pat -- TODO raise exception? -stepwhen _ _ pat = pat +s_when _ _ pat = pat -_stepevery :: Bool -> Bool -> Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -_stepevery lastone stepwise n f pat +_s_th :: Bool -> Bool -> Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +_s_th lastone stepwise n f pat | n <= 1 = pat - | otherwise = applyWhen stepwise (_fast t) $ stepcat $ applyWhen lastone reverse $ (f $ head cycles):tail cycles + | otherwise = applyWhen stepwise (_fast t) $ s_cat $ applyWhen lastone reverse $ (f $ head cycles):tail cycles where cycles = applyWhen lastone reverse $ separateCycles n $ applyWhen stepwise (_slow t) pat t = fromMaybe 1 $ tactus pat -steplastof :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -steplastof (Pattern _ _ (Just i)) f pat = _stepevery True False i f pat -steplastof tp f p = innerJoin $ (\t -> _stepevery True False t f p) <$> tp +s_cycleth :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +s_cycleth (Pattern _ _ (Just i)) f pat = _s_th True False i f pat +s_cycleth tp f p = innerJoin $ (\t -> _s_th True False t f p) <$> tp -stepfirstof :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -stepfirstof (Pattern _ _ (Just i)) f pat = _stepevery False False i f pat -stepfirstof tp f p = innerJoin $ (\t -> _stepevery False False t f p) <$> tp +s_cycleth' :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +s_cycleth' (Pattern _ _ (Just i)) f pat = _s_th False False i f pat +s_cycleth' tp f p = innerJoin $ (\t -> _s_th False False t f p) <$> tp -steplastofstep :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -steplastofstep (Pattern _ _ (Just i)) f pat = _stepevery True True i f pat -steplastofstep tp f p = innerJoin $ (\t -> _stepevery True True t f p) <$> tp +s_th :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +s_th (Pattern _ _ (Just i)) f pat = _s_th True True i f pat +s_th tp f p = innerJoin $ (\t -> _s_th True True t f p) <$> tp -stepfirstofstep :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -stepfirstofstep (Pattern _ _ (Just i)) f pat = _stepevery False True i f pat -stepfirstofstep tp f p = innerJoin $ (\t -> _stepevery False True t f p) <$> tp +s_th' :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +s_th' (Pattern _ _ (Just i)) f pat = _s_th False True i f pat +s_th' tp f p = innerJoin $ (\t -> _s_th False True t f p) <$> tp -stepevery :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -stepevery = stepfirstof +s_every :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +s_every = s_th' --- | Like @steptaper@, but returns a list of repetitions -steptaperlist :: Pattern a -> [Pattern a] -steptaperlist pat@(Pattern _ (Just t) _) = pat : map (\r -> _stepsub r pat) [1 .. t] +-- | Like @s_taper@, but returns a list of repetitions +s_taperlist :: Pattern a -> [Pattern a] +s_taperlist pat@(Pattern _ (Just t) _) = pat : map (\r -> _s_sub r pat) [1 .. t] -- TODO exception? -steptaperlist pat = [pat] +s_taperlist pat = [pat] -- | Plays one fewer step from the pattern each repetition, down to nothing -steptaper :: Pattern a -> Pattern a -steptaper = stepcat . steptaperlist +s_taper :: Pattern a -> Pattern a +s_taper = s_cat . s_taperlist -- | Successively plays a pattern from each group in turn -stepalt :: [[Pattern a]] -> Pattern a -stepalt groups = stepcat $ concat $ take (c * length groups) $ transpose $ map cycle groups +s_alt :: [[Pattern a]] -> Pattern a +s_alt groups = s_cat $ concat $ take (c * length groups) $ transpose $ map cycle groups where c = foldl1 lcm $ map length groups -_stepexpand :: Rational -> Pattern a -> Pattern a -_stepexpand factor pat = withTactus (* factor) pat +_s_expand :: Rational -> Pattern a -> Pattern a +_s_expand factor pat = withTactus (* factor) pat -_stepcontract :: Rational -> Pattern a -> Pattern a -_stepcontract factor pat = withTactus (/ factor) pat +_s_contract :: Rational -> Pattern a -> Pattern a +_s_contract factor pat = withTactus (/ factor) pat -stepexpand :: Pattern Rational -> Pattern a -> Pattern a -stepexpand = tParam _stepexpand +s_expand :: Pattern Rational -> Pattern a -> Pattern a +s_expand = patternify _s_expand -stepcontract :: Pattern Rational -> Pattern a -> Pattern a -stepcontract = tParam _stepcontract +s_contract :: Pattern Rational -> Pattern a -> Pattern a +s_contract = patternify _s_contract diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs index 9bcd40e09..0ed887799 100644 --- a/src/Sound/Tidal/UI.hs +++ b/src/Sound/Tidal/UI.hs @@ -335,7 +335,7 @@ d1 $ s "bd hh?0.8 bd hh?0.4" @ -} degradeBy :: Pattern Double -> Pattern a -> Pattern a -degradeBy = tParam _degradeBy +degradeBy = patternify' _degradeBy _degradeBy :: Double -> Pattern a -> Pattern a _degradeBy = _degradeByUsing rand @@ -349,7 +349,7 @@ As 'degradeBy', but the pattern of probabilities represents the chances to retai than remove the corresponding element. -} unDegradeBy :: Pattern Double -> Pattern a -> Pattern a -unDegradeBy = tParam _unDegradeBy +unDegradeBy = patternify' _unDegradeBy _unDegradeBy :: Double -> Pattern a -> Pattern a _unDegradeBy x p = fmap fst $ filterValues ((<= x) . snd) $ (,) <$> p <* rand @@ -521,7 +521,7 @@ There is also `iter'`, which shifts the pattern in the opposite direction. -} iter :: Pattern Int -> Pattern c -> Pattern c -iter a pat = keepTactus pat $ tParam _iter a pat +iter a pat = keepTactus pat $ patternify' _iter a pat _iter :: Int -> Pattern a -> Pattern a _iter n p = slowcat $ map (\i -> (fromIntegral i % fromIntegral n) `rotL` p) [0 .. (n-1)] @@ -543,7 +543,7 @@ hh sn cp bd @ -} iter' :: Pattern Int -> Pattern c -> Pattern c -iter' = tParam _iter' +iter' = patternify' _iter' _iter' :: Int -> Pattern a -> Pattern a _iter' n p = slowcat $ map (\i -> (fromIntegral i % fromIntegral n) `rotR` p) [0 .. (n-1)] @@ -745,7 +745,7 @@ You can also pattern the first parameter, for example to cycle through three val > d1 $ trunc "<0.75 0.25 1>" $ sound "bd sn:2 [mt rs] hc" -} trunc :: Pattern Time -> Pattern a -> Pattern a -trunc = tParam _trunc +trunc = patternify' _trunc _trunc :: Time -> Pattern a -> Pattern a _trunc t = compress (0, t) . zoomArc (Arc 0 t) @@ -781,7 +781,7 @@ quarter: > d1 $ linger (-0.25) $ sound "bd sn*2 cp hh*4 arpy bd*2 cp bd*2" -} linger :: Pattern Time -> Pattern a -> Pattern a -linger = tParam _linger +linger = patternify' _linger _linger :: Time -> Pattern a -> Pattern a _linger n p | n < 0 = _fast (1/n) $ zoomArc (Arc (1 + n) 1) p @@ -920,7 +920,7 @@ There was once a shorter alias @e@ for this function. It has been removed, but y may see references to it in older Tidal code. -} euclid :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a -euclid = tParam2 _euclid +euclid = patternify2 _euclid _euclid :: Int -> Int -> Pattern a -> Pattern a _euclid n k a | n >= 0 = fastcat $ fmap (bool silence a) $ bjorklund (n,k) @@ -954,7 +954,7 @@ As 'euclid', but taking a third rotational parameter corresponding to the onset at which to start the rhythm. -} euclidOff :: Pattern Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a -euclidOff = tParam3 _euclidOff +euclidOff = patternify3 _euclidOff -- | A shorter alias for 'euclidOff'. eoff :: Pattern Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a @@ -966,7 +966,7 @@ _euclidOff n k s p = (rotL $ fromIntegral s%fromIntegral k) (_euclid n k p) -- | As 'euclidOff', but specialized to 'Bool'. May be more efficient than 'euclidOff'. euclidOffBool :: Pattern Int -> Pattern Int -> Pattern Int -> Pattern Bool -> Pattern Bool -euclidOffBool = tParam3 _euclidOffBool +euclidOffBool = patternify3 _euclidOffBool _euclidOffBool :: Int -> Int -> Int -> Pattern Bool -> Pattern Bool _euclidOffBool _ 0 _ _ = silence @@ -1008,7 +1008,7 @@ the hi-hat event fires on every one of the eight even beats that the bass drum does not. -} euclidInv :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a -euclidInv = tParam2 _euclidInv +euclidInv = patternify2 _euclidInv _euclidInv :: Int -> Int -> Pattern a -> Pattern a _euclidInv n k a = _euclid (-n) k a @@ -1143,7 +1143,7 @@ Additional example: > d1 $ every 4 (rot 2) $ slow 2 $ sound "bd hh hh hh" -} rot :: Ord a => Pattern Int -> Pattern a -> Pattern a -rot = tParam _rot +rot = patternify' _rot -- | Calculates a whole cycle, rotates it, then constrains events to the original query arc. _rot :: Ord a => Int -> Pattern a -> Pattern a @@ -1176,10 +1176,10 @@ at an undefined frequency which may be very high. > d1 $ n (slow 2 $ segment 16 $ range 0 32 $ sine) # sound "amencutup" -} segment :: Pattern Time -> Pattern a -> Pattern a -segment = tParam _segment +segment = patternify _segment _segment :: Time -> Pattern a -> Pattern a -_segment n p = _fast n (pure id) <* p +_segment n p = setTactus n $ _fast n (pure id) <* p -- | @discretise@: the old (deprecated) name for 'segment' discretise :: Pattern Time -> Pattern a -> Pattern a @@ -1234,7 +1234,7 @@ following cycle the /next/ three values in the list will be picked, i.e. -} fit :: Pattern Int -> [a] -> Pattern Int -> Pattern a -fit pint xs p = (tParam func) pint (xs,p) +fit pint xs p = (patternify func) pint (xs,p) where func i (xs',p') = _fit i xs' p' _fit :: Int -> [a] -> Pattern Int -> Pattern a @@ -1340,7 +1340,7 @@ durations will add up to a single cycle. @n@ can be supplied as a pattern of integers. -} stripe :: Pattern Int -> Pattern a -> Pattern a -stripe = tParam _stripe +stripe = patternify _stripe _stripe :: Int -> Pattern a -> Pattern a _stripe = substruct' . randStruct @@ -1432,10 +1432,10 @@ transition matrix is automatically normalized. For example: (⅞>1)|0 -} markovPat :: Pattern Int -> Pattern Int -> [[Double]] -> Pattern Int -markovPat = tParam2 _markovPat +markovPat = patternify2 _markovPat _markovPat :: Int -> Int -> [[Double]] -> Pattern Int -_markovPat n xi tp = splitQueries $ pattern (\(State a@(Arc s _) _) -> +_markovPat n xi tp = setTactus (toRational n) $ splitQueries $ pattern (\(State a@(Arc s _) _) -> queryArc (listToPat $ runMarkov n tp xi (sam s)) a) {-| @@ -1728,7 +1728,7 @@ is not a permutation of the parts. This could also be called “sampling without replacement”. -} shuffle :: Pattern Int -> Pattern a -> Pattern a -shuffle = tParam _shuffle +shuffle = patternify' _shuffle _shuffle :: Int -> Pattern a -> Pattern a _shuffle n = _rearrangeWith (randrun n) n @@ -1741,7 +1741,7 @@ For example, @scramble 3 "a b c"@ will randomly select 3 parts from This could also be called “sampling with replacement”. -} scramble :: Pattern Int -> Pattern a -> Pattern a -scramble = tParam _scramble +scramble = patternify' _scramble _scramble :: Int -> Pattern a -> Pattern a _scramble n = _rearrangeWith (_segment (fromIntegral n) $ _irand n) n @@ -1964,7 +1964,7 @@ thumbup thumbupdown @ -} arp :: Pattern String -> Pattern a -> Pattern a -arp = tParam _arp +arp = patternify _arp _arp :: String -> Pattern a -> Pattern a _arp name p = arpWith f p @@ -2018,7 +2018,7 @@ rolledBy "<1 -0.5 0.25 -0.125>" $ note "c'maj9" # s "superpiano" @ -} rolledBy :: Pattern (Ratio Integer) -> Pattern a -> Pattern a -rolledBy pt = tParam rolledWith (segment 1 $ pt) +rolledBy pt = patternify rolledWith (segment 1 $ pt) rolledWith :: Ratio Integer -> Pattern a -> Pattern a rolledWith t = withEvents aux @@ -2079,7 +2079,7 @@ d1 $ every 3 (ply 4) $ s "bd ~ sn cp" @ -} ply :: Pattern Rational -> Pattern a -> Pattern a -ply = tParam _ply +ply = patternify' _ply _ply :: Rational -> Pattern a -> Pattern a _ply n pat = squeezeJoin $ (_fast n . pure) <$> pat @@ -2147,7 +2147,7 @@ press = _pressBy 0.5 > ] -} pressBy :: Pattern Time -> Pattern a -> Pattern a -pressBy = tParam _pressBy +pressBy = patternify' _pressBy _pressBy :: Time -> Pattern a -> Pattern a _pressBy r pat = squeezeJoin $ (compressTo (r,1) . pure) <$> pat @@ -2289,7 +2289,8 @@ juxBy -> (Pattern ValueMap -> Pattern ValueMap) -> Pattern ValueMap -> Pattern ValueMap -juxBy n f p = stack [p |+ P.pan 0.5 |- P.pan (n/2), f $ p |+ P.pan 0.5 |+ P.pan (n/2)] +-- TODO: lcm tactus of p and f p? +juxBy n f p = keepTactus p $ stack [p |+ P.pan 0.5 |- P.pan (n/2), f $ p |+ P.pan 0.5 |+ P.pan (n/2)] {- | Given a sample's directory name and number, this generates a string @@ -2516,7 +2517,7 @@ tabby nInt p p' = stack [maskedWarp, -- | Chooses from a list of patterns, using a pattern of floats (from 0 to 1). select :: Pattern Double -> [Pattern a] -> Pattern a -select = tParam _select +select = patternify _select _select :: Double -> [Pattern a] -> Pattern a _select f ps = ps !! floor (max 0 (min 1 f) * fromIntegral (length ps - 1)) @@ -2865,10 +2866,10 @@ _binary :: Data.Bits.Bits b => Int -> b -> Pattern Bool _binary n num = listToPat $ __binary n num _binaryN :: Int -> Pattern Int -> Pattern Bool -_binaryN n p = squeezeJoin $ _binary n <$> p +_binaryN n p = setTactus (toRational n) $ squeezeJoin $ _binary n <$> p binaryN :: Pattern Int -> Pattern Int -> Pattern Bool -binaryN n p = tParam _binaryN n p +binaryN n p = patternify _binaryN n p binary :: Pattern Int -> Pattern Bool binary = binaryN 8 From 84925845e4ed4f7a460a0213b2d66f0215e1c0a8 Mon Sep 17 00:00:00 2001 From: Alex McLean Date: Sun, 14 Apr 2024 22:51:46 +0100 Subject: [PATCH 30/46] th -> nth and cycleth -> nthcycle --- src/Sound/Tidal/Stepwise.hs | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/Sound/Tidal/Stepwise.hs b/src/Sound/Tidal/Stepwise.hs index 701f1804a..fe97c8a65 100644 --- a/src/Sound/Tidal/Stepwise.hs +++ b/src/Sound/Tidal/Stepwise.hs @@ -56,31 +56,31 @@ s_when patb f pat@(Pattern _ (Just t) _) = while (_steps t patb) f pat -- TODO raise exception? s_when _ _ pat = pat -_s_th :: Bool -> Bool -> Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -_s_th lastone stepwise n f pat +_s_nth :: Bool -> Bool -> Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +_s_nth lastone stepwise n f pat | n <= 1 = pat | otherwise = applyWhen stepwise (_fast t) $ s_cat $ applyWhen lastone reverse $ (f $ head cycles):tail cycles where cycles = applyWhen lastone reverse $ separateCycles n $ applyWhen stepwise (_slow t) pat t = fromMaybe 1 $ tactus pat -s_cycleth :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -s_cycleth (Pattern _ _ (Just i)) f pat = _s_th True False i f pat -s_cycleth tp f p = innerJoin $ (\t -> _s_th True False t f p) <$> tp +s_nthcycle :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +s_nthcycle (Pattern _ _ (Just i)) f pat = _s_nth True False i f pat +s_nthcycle tp f p = innerJoin $ (\t -> _s_nth True False t f p) <$> tp -s_cycleth' :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -s_cycleth' (Pattern _ _ (Just i)) f pat = _s_th False False i f pat -s_cycleth' tp f p = innerJoin $ (\t -> _s_th False False t f p) <$> tp +s_nthcycle' :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +s_nthcycle' (Pattern _ _ (Just i)) f pat = _s_nth False False i f pat +s_nthcycle' tp f p = innerJoin $ (\t -> _s_nth False False t f p) <$> tp -s_th :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -s_th (Pattern _ _ (Just i)) f pat = _s_th True True i f pat -s_th tp f p = innerJoin $ (\t -> _s_th True True t f p) <$> tp +s_nth :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +s_nth (Pattern _ _ (Just i)) f pat = _s_nth True True i f pat +s_nth tp f p = innerJoin $ (\t -> _s_nth True True t f p) <$> tp -s_th' :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -s_th' (Pattern _ _ (Just i)) f pat = _s_th False True i f pat -s_th' tp f p = innerJoin $ (\t -> _s_th False True t f p) <$> tp +s_nth' :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +s_nth' (Pattern _ _ (Just i)) f pat = _s_nth False True i f pat +s_nth' tp f p = innerJoin $ (\t -> _s_nth False True t f p) <$> tp s_every :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -s_every = s_th' +s_every = s_nth' -- | Like @s_taper@, but returns a list of repetitions s_taperlist :: Pattern a -> [Pattern a] From f24251f6f47d508e0e531a2a5493f63ee8eefa40 Mon Sep 17 00:00:00 2001 From: heyarne Date: Wed, 19 Apr 2023 18:51:58 +0200 Subject: [PATCH 31/46] Add capital-M aliases for major chords --- src/Sound/Tidal/Chords.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Sound/Tidal/Chords.hs b/src/Sound/Tidal/Chords.hs index 8131dac48..323bc05e7 100644 --- a/src/Sound/Tidal/Chords.hs +++ b/src/Sound/Tidal/Chords.hs @@ -184,14 +184,18 @@ chordTable = [("major", major), ("6by9", sixNine), ("major7", major7), ("maj7", major7), + ("M7", major7), ("major9", major9), ("maj9", major9), + ("M9", major9), ("add9", add9), ("major11", major11), ("maj11", major11), + ("M11", major11), ("add11", add11), ("major13", major13), ("maj13", major13), + ("M13", major13), ("add13", add13), ("dom7", dom7), ("dom9", dom9), From 73070728461c9dcd01cad9ef830a15ccb83f1ede Mon Sep 17 00:00:00 2001 From: Alex McLean Date: Mon, 15 Apr 2024 10:18:14 +0100 Subject: [PATCH 32/46] more efficient sew, plus some auto-reformatting --- src/Sound/Tidal/UI.hs | 78 ++++++++++++++++++++++++++----------------- 1 file changed, 47 insertions(+), 31 deletions(-) diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs index d0c28c952..ea3ca48a8 100644 --- a/src/Sound/Tidal/UI.hs +++ b/src/Sound/Tidal/UI.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} {- UI.hs - Tidal's main 'user interface' functions, for transforming @@ -33,22 +35,25 @@ module Sound.Tidal.UI where -import Prelude hiding ((<*), (*>)) +import Prelude hiding ((*>), (<*)) -import Data.Char (digitToInt, isDigit, ord) -import Data.Bits (testBit, Bits, xor, shiftL, shiftR) +import Data.Bits (Bits, shiftL, shiftR, testBit, xor) +import Data.Char (digitToInt, isDigit, ord) -import Data.Ratio ((%), Ratio) -import Data.Fixed (mod') -import Data.List (sort, sortOn, findIndices, elemIndex, groupBy, transpose, intercalate, findIndex) -import Data.Maybe (isJust, fromJust, fromMaybe, mapMaybe) -import qualified Data.Text as T -import qualified Data.Map.Strict as Map -import Data.Bool (bool) +import Data.Bool (bool) +import Data.Fixed (mod') +import Data.List (elemIndex, findIndex, findIndices, + groupBy, intercalate, sort, sortOn, + transpose) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, + mapMaybe) +import Data.Ratio (Ratio, (%)) +import qualified Data.Text as T import Sound.Tidal.Bjorklund (bjorklund) import Sound.Tidal.Core -import qualified Sound.Tidal.Params as P +import qualified Sound.Tidal.Params as P import Sound.Tidal.Pattern import Sound.Tidal.Utils @@ -689,7 +694,7 @@ wedge pt pa pb = innerJoin $ (\t -> _wedge t pa pb) <$> pt _wedge :: Time -> Pattern a -> Pattern a -> Pattern a _wedge 0 _ p' = p' -_wedge 1 p _ = p +_wedge 1 p _ = p _wedge t p p' = overlay (_fastGap (1/t) p) (t `rotR` _fastGap (1/(1-t)) p') @@ -976,10 +981,10 @@ _distrib :: [Int] -> Pattern a -> Pattern a _distrib xs p = boolsToPat (foldr distrib' (replicate (last xs) True) (reverse $ layers xs)) p where distrib' :: [Bool] -> [Bool] -> [Bool] - distrib' [] _ = [] - distrib' (_:a) [] = False : distrib' a [] + distrib' [] _ = [] + distrib' (_:a) [] = False : distrib' a [] distrib' (True:a) (x:b) = x : distrib' a b - distrib' (False:a) b = False : distrib' a b + distrib' (False:a) b = False : distrib' a b layers = map bjorklund . (zip<*>tail) boolsToPat a b' = flip const <$> filterValues (== True) (fastFromList a) <* b' @@ -1296,9 +1301,9 @@ randArcs n = return pairs where pairUp [] = [] pairUp xs = Arc 0 (head xs) : pairUp' xs - pairUp' [] = [] - pairUp' [_] = [] - pairUp' [a, _] = [Arc a 1] + pairUp' [] = [] + pairUp' [_] = [] + pairUp' [a, _] = [Arc a 1] pairUp' (a:b:xs) = Arc a b: pairUp' (b:xs) @@ -1850,12 +1855,12 @@ ur t outer_p ps fs = _slow t $ unwrap $ adjust <$> timedValues (getPat . split < where split = wordsBy (==':') getPat (s:xs) = (match s, transform xs) -- TODO - check this really can't happen.. - getPat _ = error "can't happen?" + getPat _ = error "can't happen?" match s = fromMaybe silence $ lookup s ps' ps' = map (fmap (_fast t)) ps adjust (a, (p, f)) = f a p transform (x:_) a = transform' x a - transform _ _ = id + transform _ _ = id transform' str (Arc s e) p = s `rotR` inside (pure $ 1/(e-s)) (matchF str) p matchF str = fromMaybe id $ lookup str fs timedValues = withEvent (\(Event c (Just a) a' v) -> Event c (Just a) a' (a,v)) . filterDigital @@ -1886,7 +1891,7 @@ inhabit ps p = squeezeJoin $ (\s -> fromMaybe silence $ lookup s ps) <$> p spaceOut :: [Time] -> Pattern a -> Pattern a spaceOut xs p = _slow (toRational $ sum xs) $ stack $ map (`compressArc` p) spaceArcs where markOut :: Time -> [Time] -> [Arc] - markOut _ [] = [] + markOut _ [] = [] markOut offset (x:xs') = Arc offset (offset+x):markOut (offset+x) xs' spaceArcs = map (\(Arc a b) -> Arc (a/s) (b/s)) $ markOut 0 xs s = sum xs @@ -1979,7 +1984,7 @@ _arp name p = arpWith f p ("thumbup", thumbup), ("thumbupdown", \x -> init (thumbup x) ++ init (reverse $ thumbup x)) ] - converge [] = [] + converge [] = [] converge (x:xs) = x : converge' xs converge' [] = [] converge' xs = last xs : converge (init xs) @@ -2020,7 +2025,7 @@ 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 steppityIn xs = mapMaybe (\(n, ev) -> (timeguard n xs ev t)) $ enumerate xs - timeguard _ _ ev 0 = return ev + timeguard _ _ ev 0 = return ev timeguard n xs ev _ = (shiftIt n (length xs) ev) shiftIt n d (Event c (Just (Arc s e)) a' v) = do a'' <- subArc (Arc newS e) a' @@ -2171,7 +2176,18 @@ _pressBy r pat = squeezeJoin $ (compressTo (r,1) . pure) <$> pat > (s "cp:3*16" # speed sine + 1.5) -} sew :: Pattern Bool -> Pattern a -> Pattern a -> Pattern a -sew pb a b = overlay (mask pb a) (mask (inv pb) b) +-- Replaced with more efficient version below +-- sew pb a b = overlay (mask pb a) (mask (inv pb) b) +sew pb a b = Pattern $ pf + where pf st = concatMap match evs + where evs = query pb st + parts = map part evs + subarc = Arc (minimum $ map start parts) (maximum $ map stop parts) + match ev | value ev = find (query a st {arc = subarc}) ev + | otherwise = find (query b st {arc = subarc}) ev + find evs' ev = catMaybes $ map (check ev) evs' + check bev xev = do newarc <- subArc (part bev) (part xev) + return $ xev {part = newarc} {-| Uses the first (binary) pattern to switch between the following two patterns. The resulting structure comes from the binary @@ -2595,7 +2611,7 @@ contrastRange = contrastBy f f (VF s, VF e) (VF v) = v >= s && v <= e f (VN s, VN e) (VN v) = v >= s && v <= e f (VS s, VS e) (VS v) = v == s && v == e - f _ _ = False + f _ _ = False {- | The @fix@ function applies another function to matching events in a pattern of @@ -2694,7 +2710,7 @@ mono :: Pattern a -> Pattern a mono p = Pattern $ \(State a cm) -> flatten $ query p (State a cm) where flatten :: [Event a] -> [Event a] flatten = mapMaybe constrainPart . truncateOverlaps . sortOn whole - truncateOverlaps [] = [] + truncateOverlaps [] = [] truncateOverlaps (e:es) = e : truncateOverlaps (mapMaybe (snip e) es) -- TODO - decide what to do about analog events.. snip a b | start (wholeOrPart b) >= stop (wholeOrPart a) = Just b @@ -2782,9 +2798,9 @@ deconstruct :: Int -> Pattern String -> String deconstruct n p = intercalate " " $ map showStep $ toList p where showStep :: [String] -> String - showStep [] = "~" + showStep [] = "~" showStep [x] = x - showStep xs = "[" ++ (intercalate ", " xs) ++ "]" + showStep xs = "[" ++ (intercalate ", " xs) ++ "]" toList :: Pattern a -> [[a]] toList pat = map (\(s,e) -> map value $ queryArc (_segment n' pat) (Arc s e)) arcs where breaks = [0, (1/n') ..] @@ -2820,7 +2836,7 @@ _bite n ipat pat = squeezeJoin $ zoompat <$> ipat -- | Chooses from a list of patterns, using a pattern of integers. squeeze :: Pattern Int -> [Pattern a] -> Pattern a -squeeze _ [] = silence +squeeze _ [] = silence squeeze ipat pats = squeezeJoin $ (pats !!!) <$> ipat squeezeJoinUp :: Pattern (ControlPattern) -> ControlPattern @@ -2896,5 +2912,5 @@ grain s w = P.begin b # P.end e necklace :: Rational -> [Int] -> Pattern Bool necklace perCycle xs = _slow ((toRational $ sum xs) / perCycle) $ listToPat $ list xs where list :: [Int] -> [Bool] - list [] = [] + list [] = [] list (x:xs') = (True:(replicate (x-1) False)) ++ list xs' From 00b079a5a8d37d37caef9220c09b1bd572397053 Mon Sep 17 00:00:00 2001 From: Alex McLean Date: Mon, 15 Apr 2024 12:12:06 +0100 Subject: [PATCH 33/46] s_when -> s_while --- src/Sound/Tidal/Stepwise.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Sound/Tidal/Stepwise.hs b/src/Sound/Tidal/Stepwise.hs index fe97c8a65..51725fa15 100644 --- a/src/Sound/Tidal/Stepwise.hs +++ b/src/Sound/Tidal/Stepwise.hs @@ -51,10 +51,10 @@ _s_sub r pat@(Pattern _ (Just t) _) | r >= t = nothing s_sub :: Pattern Rational -> Pattern a -> Pattern a s_sub = patternify _s_sub -s_when :: Pattern Bool -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -s_when patb f pat@(Pattern _ (Just t) _) = while (_steps t patb) f pat +s_while :: Pattern Bool -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +s_while patb f pat@(Pattern _ (Just t) _) = while (_steps t patb) f pat -- TODO raise exception? -s_when _ _ pat = pat +s_while _ _ pat = pat _s_nth :: Bool -> Bool -> Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a _s_nth lastone stepwise n f pat From 5dae76f6f429edd85fc037bf6df77957c5bf25ac Mon Sep 17 00:00:00 2001 From: Alex McLean Date: Mon, 15 Apr 2024 14:17:52 +0100 Subject: [PATCH 34/46] s_everycycle alias --- src/Sound/Tidal/Stepwise.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Sound/Tidal/Stepwise.hs b/src/Sound/Tidal/Stepwise.hs index 51725fa15..9f48897af 100644 --- a/src/Sound/Tidal/Stepwise.hs +++ b/src/Sound/Tidal/Stepwise.hs @@ -82,6 +82,9 @@ s_nth' tp f p = innerJoin $ (\t -> _s_nth False True t f p) <$> tp s_every :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a s_every = s_nth' +s_everycycle :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +s_everycycle = s_nthcycle' + -- | Like @s_taper@, but returns a list of repetitions s_taperlist :: Pattern a -> [Pattern a] s_taperlist pat@(Pattern _ (Just t) _) = pat : map (\r -> _s_sub r pat) [1 .. t] From d48d3d59491353cd9a6373cf8fcca14940654ef0 Mon Sep 17 00:00:00 2001 From: Alex McLean Date: Mon, 15 Apr 2024 14:22:47 +0100 Subject: [PATCH 35/46] bump upper bounds of network dependency to 3.3 --- tidal.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tidal.cabal b/tidal.cabal index 453437587..dd39bb43c 100644 --- a/tidal.cabal +++ b/tidal.cabal @@ -62,7 +62,7 @@ library , hosc >= 0.20 && < 0.21 , text < 2.2 , parsec >= 3.1.12 && < 3.2 - , network < 3.2 + , network < 3.3 , transformers >= 0.5 && < 0.7 , bytestring < 0.13 , clock < 0.9 From 1f38f4a93ae1fd52d19d2f88522792ee9ab16325 Mon Sep 17 00:00:00 2001 From: Matthew Kaney Date: Mon, 15 Apr 2024 10:07:01 -0400 Subject: [PATCH 36/46] Integrate new clock changes into Boot file --- src/Sound/Tidal/Boot.hs | 35 +++++++++++++++-------------------- 1 file changed, 15 insertions(+), 20 deletions(-) diff --git a/src/Sound/Tidal/Boot.hs b/src/Sound/Tidal/Boot.hs index 40803c5e7..9d4d04a6e 100644 --- a/src/Sound/Tidal/Boot.hs +++ b/src/Sound/Tidal/Boot.hs @@ -4,7 +4,6 @@ module Sound.Tidal.Boot ( Tidally (..) , OscMap - , mkConfig , mkOscMap , mkTidal , mkTidalWith @@ -86,17 +85,13 @@ class Tidally where type OscMap = [(Target, [OSC])] --- | A reasonable config. -mkConfig :: Config -mkConfig = defaultConfig {cVerbose = True, cFrameTimespan = 1 / 20} - -- | A reasonable OscMap mkOscMap :: OscMap mkOscMap = [(superdirtTarget {oLatency = 0.05, oAddress = "127.0.0.1", oPort = 57120}, [superdirtShape])] -- | Creates a Tidal instance using default config. Use 'mkTidalWith' to customize. mkTidal :: IO Stream -mkTidal = mkTidalWith mkConfig mkOscMap +mkTidal = mkTidalWith defaultConfig mkOscMap -- | See 'Sound.Tidal.Stream.startStream'. mkTidalWith :: Config -> OscMap -> IO Stream @@ -180,27 +175,27 @@ setcps :: Tidally => Pattern Double -> IO () setcps = once . cps -- | See 'Sound.Tidal.Stream.streamGetcps'. -getcps :: Tidally => IO Double +getcps :: Tidally => IO Time getcps = streamGetCPS tidal -- | See 'Sound.Tidal.Stream.streamGetnow'. -getnow :: Tidally => IO Double +getnow :: Tidally => IO Time getnow = streamGetNow tidal -- | Replace what's playing on the given orbit. d1, d2, d3, d4, d5, d6, d7, d8, d9, d10, d11, d12, d13, d14, d15, d16 :: Tidally => ControlPattern -> IO () -d1 = p 1 . (|. orbit 0) -d2 = p 2 . (|. orbit 1) -d3 = p 3 . (|. orbit 2) -d4 = p 4 . (|. orbit 3) -d5 = p 5 . (|. orbit 4) -d6 = p 6 . (|. orbit 5) -d7 = p 7 . (|. orbit 6) -d8 = p 8 . (|. orbit 7) -d9 = p 9 . (|. orbit 8) -d10 = p 10 . (|. orbit 9) -d11 = p 11 . (|. orbit 10) -d12 = p 12 . (|. orbit 11) +d1 = p 1 . (|< orbit 0) +d2 = p 2 . (|< orbit 1) +d3 = p 3 . (|< orbit 2) +d4 = p 4 . (|< orbit 3) +d5 = p 5 . (|< orbit 4) +d6 = p 6 . (|< orbit 5) +d7 = p 7 . (|< orbit 6) +d8 = p 8 . (|< orbit 7) +d9 = p 9 . (|< orbit 8) +d10 = p 10 . (|< orbit 9) +d11 = p 11 . (|< orbit 10) +d12 = p 12 . (|< orbit 11) d13 = p 13 d14 = p 14 d15 = p 15 From e6c05dee7dab16b72da7d7176296b4e98f649e28 Mon Sep 17 00:00:00 2001 From: Alex McLean Date: Wed, 17 Apr 2024 13:46:57 +0100 Subject: [PATCH 37/46] stepJoin experiment --- src/Sound/Tidal/Core.hs | 4 +++- src/Sound/Tidal/Stepwise.hs | 33 +++++++++++++++++++++++++++++---- src/Sound/Tidal/Utils.hs | 4 ++++ 3 files changed, 36 insertions(+), 5 deletions(-) diff --git a/src/Sound/Tidal/Core.hs b/src/Sound/Tidal/Core.hs index 071eeeae7..5e9f7eb27 100644 --- a/src/Sound/Tidal/Core.hs +++ b/src/Sound/Tidal/Core.hs @@ -422,7 +422,9 @@ pattern to multiple patterns at once: > ] # speed "[[1 0.8], [1.5 2]*2]/3" -} stack :: [Pattern a] -> Pattern a -stack = foldr overlay silence +stack pats = (foldr overlay silence pats) {tactus = t} + where t | length pats == 0 = Nothing + | otherwise = foldl1 lcmr <$> (sequence $ map tactus pats) -- ** Manipulating time diff --git a/src/Sound/Tidal/Stepwise.hs b/src/Sound/Tidal/Stepwise.hs index 9f48897af..62b7ac3ae 100644 --- a/src/Sound/Tidal/Stepwise.hs +++ b/src/Sound/Tidal/Stepwise.hs @@ -19,13 +19,17 @@ module Sound.Tidal.Stepwise where -import Data.List (transpose) -import Data.Maybe (fromMaybe) +import Data.Containers.ListUtils (nubOrd) +import Data.List (sort, transpose) +import Data.Maybe (catMaybes, fromMaybe, isJust) import Sound.Tidal.Core import Sound.Tidal.Pattern -import Sound.Tidal.UI (while) -import Sound.Tidal.Utils (applyWhen) +import Sound.Tidal.UI (while) +import Sound.Tidal.Utils (applyWhen, pairs) + +_lcmtactus :: [Pattern a] -> Maybe Time +_lcmtactus pats = foldl1 lcmr <$> (sequence $ map tactus pats) s_cat :: [Pattern a] -> Pattern a s_cat pats = timecat $ map (\pat -> (fromMaybe 1 $ tactus pat, pat)) pats @@ -111,3 +115,24 @@ s_expand = patternify _s_expand s_contract :: Pattern Rational -> Pattern a -> Pattern a s_contract = patternify _s_contract + +stepJoin :: Pattern (Pattern a) -> Pattern a +stepJoin pp = Pattern q Nothing Nothing + where q st@(State a c) = query (timecat $ retime $ slices $ query (rotL (sam $ start a) pp) (st {arc = Arc 0 1})) st + retime :: [(Time, Pattern a)] -> [(Time, Pattern a)] + retime xs = map (\(dur, pat) -> adjust dur pat) xs + where occupied_perc = sum $ map fst $ filter (isJust . tactus . snd) xs + occupied_tactus = sum $ catMaybes $ map (tactus . snd) xs + total_tactus = occupied_tactus / occupied_perc + adjust dur pat@(Pattern {tactus = Just t}) = (t, pat) + adjust dur pat = (dur*total_tactus, pat) + -- break up events at all start/end points, into groups, including empty ones. + slices :: [Event (Pattern a)] -> [(Time, Pattern a)] + slices evs = map (\s -> ((snd s - fst s), stack $ map value $ fit s evs)) $ pairs $ sort $ nubOrd $ 0:1:concatMap (\ev -> start (part ev):stop (part ev):[]) evs + -- list of slices of events within the given range + fit :: (Rational, Rational) -> [Event (Pattern a)] -> [Event (Pattern a)] + fit (b,e) evs = catMaybes $ map (match (b,e)) evs + -- slice of event within the given range + match :: (Rational, Rational) -> Event (Pattern a) -> Maybe (Event (Pattern a)) + match (b,e) ev = do a <- subArc (Arc b e) $ part ev + return ev {part = a} diff --git a/src/Sound/Tidal/Utils.hs b/src/Sound/Tidal/Utils.hs index e2c7568a7..2d745da03 100644 --- a/src/Sound/Tidal/Utils.hs +++ b/src/Sound/Tidal/Utils.hs @@ -106,3 +106,7 @@ fromRight b _ = b applyWhen :: Bool -> (a -> a) -> a -> a applyWhen True f x = f x applyWhen False _ x = x + +-- pair up neighbours in list +pairs :: [a] -> [(a,a)] +pairs rs = zip rs (tail rs) From cabffb30f5941bac7b42a72cf0cff21bd33ef25e Mon Sep 17 00:00:00 2001 From: Alex McLean Date: Thu, 18 Apr 2024 08:45:59 +0100 Subject: [PATCH 38/46] set lower bounds of containers, for nubord --- tidal.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tidal.cabal b/tidal.cabal index a9b566fc2..522c763fa 100644 --- a/tidal.cabal +++ b/tidal.cabal @@ -58,7 +58,7 @@ library Paths_tidal Build-depends: base >=4.8 && <5 - , containers < 0.8 + , containers >= 0.6 && < 0.8 , colour < 2.4 , hosc >= 0.20 && < 0.21 , text < 2.2 From 88f546b6eba0645c1a4f48d863c69c2e238f8e72 Mon Sep 17 00:00:00 2001 From: Alex McLean Date: Thu, 18 Apr 2024 09:09:54 +0100 Subject: [PATCH 39/46] retire ghc 8.4.4 support. add tests for stable ghc 9.x releases --- .github/workflows/ci.yml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index f66084552..d6a7e2e81 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -17,6 +17,12 @@ jobs: cabal: latest args: --allow-newer=base,template-haskell experimental: true + - ghc: 9.8.2 + cabal: 3.10.2.0 + experimental: false + - ghc: 9.6.5 + cabal: 3.10.0.0 + experimental: false - ghc: 9.4.1 cabal: 3.8.1.0 args: --allow-newer=base,template-haskell @@ -36,9 +42,6 @@ jobs: - ghc: 8.6.5 cabal: 3.4.0.0 experimental: false - - ghc: 8.4.4 - cabal: 3.4.0.0 - experimental: false continue-on-error: ${{ matrix.versions.experimental }} name: cabal ${{ matrix.versions.cabal }} - ghc ${{ matrix.versions.ghc }} From 9809c08e7942b3d828b59ff76db6bb8211ab10bb Mon Sep 17 00:00:00 2001 From: Alex McLean Date: Thu, 18 Apr 2024 09:10:01 +0100 Subject: [PATCH 40/46] retire ghc 8.4.4 support. add tests for stable ghc 9.x releases --- tidal.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tidal.cabal b/tidal.cabal index 522c763fa..f9de059d9 100644 --- a/tidal.cabal +++ b/tidal.cabal @@ -13,7 +13,7 @@ Stability: Experimental Copyright: (c) Alex McLean and other contributors, 2021 category: Sound build-type: Simple -tested-with: GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.1, GHC == 9.0.1 +tested-with: GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.1, GHC == 9.0.1, GHC == 9.4.8, GHC == 9.6.5, GHC == 9.8.2 data-files: BootTidal.hs Extra-source-files: README.md CHANGELOG.md tidal.el From f9f3b3f2c8db6aa22b99ba400e05bd27a07224fd Mon Sep 17 00:00:00 2001 From: Alex McLean Date: Thu, 18 Apr 2024 09:14:00 +0100 Subject: [PATCH 41/46] ghc 9.6.5 seems to be missing from the github action.. --- .github/workflows/ci.yml | 3 --- tidal.cabal | 2 +- 2 files changed, 1 insertion(+), 4 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index d6a7e2e81..43c487571 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -20,9 +20,6 @@ jobs: - ghc: 9.8.2 cabal: 3.10.2.0 experimental: false - - ghc: 9.6.5 - cabal: 3.10.0.0 - experimental: false - ghc: 9.4.1 cabal: 3.8.1.0 args: --allow-newer=base,template-haskell diff --git a/tidal.cabal b/tidal.cabal index f9de059d9..e1279e461 100644 --- a/tidal.cabal +++ b/tidal.cabal @@ -13,7 +13,7 @@ Stability: Experimental Copyright: (c) Alex McLean and other contributors, 2021 category: Sound build-type: Simple -tested-with: GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.1, GHC == 9.0.1, GHC == 9.4.8, GHC == 9.6.5, GHC == 9.8.2 +tested-with: GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.1, GHC == 9.0.1, GHC == 9.4.8, GHC == 9.8.2 data-files: BootTidal.hs Extra-source-files: README.md CHANGELOG.md tidal.el From 2e7f02cca6c16333c58bc4dbeb34dcd0eed2ec2a Mon Sep 17 00:00:00 2001 From: Alex McLean Date: Thu, 18 Apr 2024 10:10:16 +0100 Subject: [PATCH 42/46] stepJoin experiment continued --- src/Sound/Tidal/Stepwise.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/Sound/Tidal/Stepwise.hs b/src/Sound/Tidal/Stepwise.hs index 62b7ac3ae..8164d007f 100644 --- a/src/Sound/Tidal/Stepwise.hs +++ b/src/Sound/Tidal/Stepwise.hs @@ -44,7 +44,7 @@ _s_add r pat@(Pattern _ (Just t) _) | otherwise = zoom (0, (r/t)) pat s_add :: Pattern Rational -> Pattern a -> Pattern a -s_add = patternify _s_add +s_add = s_patternify _s_add _s_sub :: Rational -> Pattern a -> Pattern a _s_sub _ pat@(Pattern _ Nothing _) = pat @@ -53,7 +53,7 @@ _s_sub r pat@(Pattern _ (Just t) _) | r >= t = nothing | otherwise = _s_add (t-r) pat s_sub :: Pattern Rational -> Pattern a -> Pattern a -s_sub = patternify _s_sub +s_sub = s_patternify _s_sub s_while :: Pattern Bool -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a s_while patb f pat@(Pattern _ (Just t) _) = while (_steps t patb) f pat @@ -111,10 +111,14 @@ _s_contract :: Rational -> Pattern a -> Pattern a _s_contract factor pat = withTactus (/ factor) pat s_expand :: Pattern Rational -> Pattern a -> Pattern a -s_expand = patternify _s_expand +s_expand = s_patternify _s_expand s_contract :: Pattern Rational -> Pattern a -> Pattern a -s_contract = patternify _s_contract +s_contract = s_patternify _s_contract + +s_patternify :: (a -> Pattern b -> Pattern c) -> (Pattern a -> Pattern b -> Pattern c) +s_patternify f (Pattern _ _ (Just a)) b = f a b +s_patternify f pa p = keepTactus p $ stepJoin $ (`f` p) <$> pa stepJoin :: Pattern (Pattern a) -> Pattern a stepJoin pp = Pattern q Nothing Nothing From 4f344b457a4951a4412bf8cae3b8563d20ff0445 Mon Sep 17 00:00:00 2001 From: Alex McLean Date: Thu, 18 Apr 2024 10:26:06 +0100 Subject: [PATCH 43/46] calculate tactus from the first cycle --- src/Sound/Tidal/Stepwise.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Sound/Tidal/Stepwise.hs b/src/Sound/Tidal/Stepwise.hs index 8164d007f..be568c29b 100644 --- a/src/Sound/Tidal/Stepwise.hs +++ b/src/Sound/Tidal/Stepwise.hs @@ -118,11 +118,13 @@ s_contract = s_patternify _s_contract s_patternify :: (a -> Pattern b -> Pattern c) -> (Pattern a -> Pattern b -> Pattern c) s_patternify f (Pattern _ _ (Just a)) b = f a b -s_patternify f pa p = keepTactus p $ stepJoin $ (`f` p) <$> pa +s_patternify f pa p = stepJoin $ (`f` p) <$> pa stepJoin :: Pattern (Pattern a) -> Pattern a -stepJoin pp = Pattern q Nothing Nothing +stepJoin pp = Pattern q first_t Nothing where q st@(State a c) = query (timecat $ retime $ slices $ query (rotL (sam $ start a) pp) (st {arc = Arc 0 1})) st + first_t :: Maybe Rational + first_t = tactus $ timecat $ retime $ slices $ queryArc pp (Arc 0 1) retime :: [(Time, Pattern a)] -> [(Time, Pattern a)] retime xs = map (\(dur, pat) -> adjust dur pat) xs where occupied_perc = sum $ map fst $ filter (isJust . tactus . snd) xs From 1be53d1e4cbea6acf33c606153c516c4d3fa88a3 Mon Sep 17 00:00:00 2001 From: Alex McLean Date: Thu, 18 Apr 2024 13:13:29 +0100 Subject: [PATCH 44/46] hard fork nobOrd to get around dependency issue --- src/Sound/Tidal/Stepwise.hs | 9 +++-- src/Sound/Tidal/Utils.hs | 65 +++++++++++++++++++++++++++++++++++++ tidal.cabal | 2 +- 3 files changed, 70 insertions(+), 6 deletions(-) diff --git a/src/Sound/Tidal/Stepwise.hs b/src/Sound/Tidal/Stepwise.hs index be568c29b..2ba8fa29e 100644 --- a/src/Sound/Tidal/Stepwise.hs +++ b/src/Sound/Tidal/Stepwise.hs @@ -19,14 +19,13 @@ module Sound.Tidal.Stepwise where -import Data.Containers.ListUtils (nubOrd) -import Data.List (sort, transpose) -import Data.Maybe (catMaybes, fromMaybe, isJust) +import Data.List (sort, transpose) +import Data.Maybe (catMaybes, fromMaybe, isJust) import Sound.Tidal.Core import Sound.Tidal.Pattern -import Sound.Tidal.UI (while) -import Sound.Tidal.Utils (applyWhen, pairs) +import Sound.Tidal.UI (while) +import Sound.Tidal.Utils (applyWhen, nubOrd, pairs) _lcmtactus :: [Pattern a] -> Maybe Time _lcmtactus pats = foldl1 lcmr <$> (sequence $ map tactus pats) diff --git a/src/Sound/Tidal/Utils.hs b/src/Sound/Tidal/Utils.hs index 2d745da03..e8f9986fd 100644 --- a/src/Sound/Tidal/Utils.hs +++ b/src/Sound/Tidal/Utils.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} + module Sound.Tidal.Utils where {- @@ -21,6 +24,15 @@ module Sound.Tidal.Utils where import Data.List (delete) import System.IO (hPutStrLn, stderr) +import Data.Set (Set) +import qualified Data.Set as Set +-- import qualified Data.IntSet as IntSet +-- import Data.IntSet (IntSet) +#ifdef __GLASGOW_HASKELL__ +import GHC.Exts (build) +#endif + + writeError :: String -> IO () writeError = hPutStrLn stderr @@ -110,3 +122,56 @@ applyWhen False _ x = x -- pair up neighbours in list pairs :: [a] -> [(a,a)] pairs rs = zip rs (tail rs) + +-- The following is from Data.Containers.ListUtils, (c) Gershom Bazerman 2018, +-- Used under a BSD 3-clause license +-- https://hackage.haskell.org/package/containers + +nubOrd :: Ord a => [a] -> [a] +nubOrd = nubOrdOn id + +{-# INLINE nubOrd #-} +nubOrdOn :: Ord b => (a -> b) -> [a] -> [a] +nubOrdOn f = \xs -> nubOrdOnExcluding f Set.empty xs +{-# INLINE nubOrdOn #-} + +nubOrdOnExcluding :: Ord b => (a -> b) -> Set b -> [a] -> [a] +nubOrdOnExcluding f = go + where + go _ [] = [] + go s (x:xs) + | fx `Set.member` s = go s xs + | otherwise = x : go (Set.insert fx s) xs + where !fx = f x + +#ifdef __GLASGOW_HASKELL__ +{-# INLINABLE [1] nubOrdOnExcluding #-} + +{-# RULES +-- Rewrite to a fusible form. +"nubOrdOn" [~1] forall f as s. nubOrdOnExcluding f s as = + build (\c n -> foldr (nubOrdOnFB f c) (constNubOn n) as s) + +-- Rewrite back to a plain form +"nubOrdOnList" [1] forall f as s. + foldr (nubOrdOnFB f (:)) (constNubOn []) as s = + nubOrdOnExcluding f s as + #-} + +nubOrdOnFB :: Ord b + => (a -> b) + -> (a -> r -> r) + -> a + -> (Set b -> r) + -> Set b + -> r +nubOrdOnFB f c x r s + | fx `Set.member` s = r s + | otherwise = x `c` r (Set.insert fx s) + where !fx = f x +{-# INLINABLE [0] nubOrdOnFB #-} + +constNubOn :: a -> b -> a +constNubOn x _ = x +{-# INLINE [0] constNubOn #-} +#endif diff --git a/tidal.cabal b/tidal.cabal index e1279e461..477a8783a 100644 --- a/tidal.cabal +++ b/tidal.cabal @@ -58,7 +58,7 @@ library Paths_tidal Build-depends: base >=4.8 && <5 - , containers >= 0.6 && < 0.8 + , containers < 0.8 , colour < 2.4 , hosc >= 0.20 && < 0.21 , text < 2.2 From b7907331057fe1635b298a8226ac93b436133a7c Mon Sep 17 00:00:00 2001 From: Alex McLean Date: Thu, 18 Apr 2024 13:17:14 +0100 Subject: [PATCH 45/46] remove ghc 9.8.2 from tests for now --- .github/workflows/ci.yml | 3 --- 1 file changed, 3 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 43c487571..ce9e6e74f 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -17,9 +17,6 @@ jobs: cabal: latest args: --allow-newer=base,template-haskell experimental: true - - ghc: 9.8.2 - cabal: 3.10.2.0 - experimental: false - ghc: 9.4.1 cabal: 3.8.1.0 args: --allow-newer=base,template-haskell From 653d8b90a02ecc46d9411b9069f9801af172f3a2 Mon Sep 17 00:00:00 2001 From: Alex McLean Date: Thu, 18 Apr 2024 13:56:31 +0100 Subject: [PATCH 46/46] fixes for boot and sew --- BootTidal.hs | 4 ++-- src/Sound/Tidal/Boot.hs | 10 +++++----- src/Sound/Tidal/UI.hs | 2 +- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/BootTidal.hs b/BootTidal.hs index e3639b5ae..b72acbce2 100644 --- a/BootTidal.hs +++ b/BootTidal.hs @@ -3,11 +3,11 @@ :set -XOverloadedStrings :set prompt "" -default (Signal String, Integer, Double) - -- Import all the boot functions and aliases. import Sound.Tidal.Boot +default (Pattern String, Integer, Double) + -- Create a Tidal Stream with the default settings. -- Use 'mkTidalWith' to customize these settings. tidalInst <- mkTidal diff --git a/src/Sound/Tidal/Boot.hs b/src/Sound/Tidal/Boot.hs index 9d4d04a6e..edae71f52 100644 --- a/src/Sound/Tidal/Boot.hs +++ b/src/Sound/Tidal/Boot.hs @@ -1,5 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Sound.Tidal.Boot ( Tidally (..) @@ -72,10 +72,10 @@ where along with this library. If not, see . -} -import Prelude hiding (all, (*>), (<*)) -import Sound.Tidal.Context hiding (mute, solo) -import Sound.Tidal.ID (ID) -import System.IO (hSetEncoding, stdout, utf8) +import Prelude hiding (all, (*>), (<*)) +import Sound.Tidal.Context +import Sound.Tidal.ID (ID) +import System.IO (hSetEncoding, stdout, utf8) -- | Functions using this constraint can access the in-scope Tidal instance. -- You must implement an instance of this in 'BootTidal.hs'. Note that GHC diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs index e74ec3f6d..b3af7f38a 100644 --- a/src/Sound/Tidal/UI.hs +++ b/src/Sound/Tidal/UI.hs @@ -2179,7 +2179,7 @@ _pressBy r pat = squeezeJoin $ (compressTo (r,1) . pure) <$> pat sew :: Pattern Bool -> Pattern a -> Pattern a -> Pattern a -- Replaced with more efficient version below -- sew pb a b = overlay (mask pb a) (mask (inv pb) b) -sew pb a b = Pattern $ pf +sew pb a b = Pattern pf Nothing Nothing where pf st = concatMap match evs where evs = query pb st parts = map part evs