From c5cc1e25de5c8d556f7d3b5550aee28ad972cd74 Mon Sep 17 00:00:00 2001 From: alex Date: Sun, 12 Nov 2023 21:10:29 +0000 Subject: [PATCH] committing some things I was working on a while ago and lost my way with.. --- old/Sound/Tidal/Scales.hs | 295 -------------------- tidal-core/src/Sound/Tidal/Compose.hs | 4 +- tidal-core/src/Sound/Tidal/InstanceHacks.hs | 2 +- tidal-core/src/Sound/Tidal/Pattern.hs | 34 ++- tidal-core/src/Sound/Tidal/Sequence.hs | 49 +++- tidal-core/src/Sound/Tidal/Signal.hs | 18 +- tidal-core/src/Sound/Tidal/Types.hs | 21 +- 7 files changed, 99 insertions(+), 324 deletions(-) delete mode 100644 old/Sound/Tidal/Scales.hs diff --git a/old/Sound/Tidal/Scales.hs b/old/Sound/Tidal/Scales.hs deleted file mode 100644 index 339b32653..000000000 --- a/old/Sound/Tidal/Scales.hs +++ /dev/null @@ -1,295 +0,0 @@ -module Sound.Tidal.Scales (scale, scaleList, scaleTable, getScale) where - -{- - Scale.hs - Scales for TidalCycles - Copyright (C) 2020, lvm (Mauro) 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 Data.Maybe -import Prelude hiding ((*>), (<*)) -import Sound.Tidal.Pattern ((<*)) -import Sound.Tidal.Signal.Base () -import Sound.Tidal.Types -import Sound.Tidal.Utils - --- five notes scales -minPent :: Fractional a => [a] -minPent = [0,3,5,7,10] -majPent :: Fractional a => [a] -majPent = [0,2,4,7,9] - --- another mode of major pentatonic -ritusen :: Fractional a => [a] -ritusen = [0,2,5,7,9] - --- another mode of major pentatonic -egyptian :: Fractional a => [a] -egyptian = [0,2,5,7,10] - --- -kumai :: Fractional a => [a] -kumai = [0,2,3,7,9] -hirajoshi :: Fractional a => [a] -hirajoshi = [0,2,3,7,8] -iwato :: Fractional a => [a] -iwato = [0,1,5,6,10] -chinese :: Fractional a => [a] -chinese = [0,4,6,7,11] -indian :: Fractional a => [a] -indian = [0,4,5,7,10] -pelog :: Fractional a => [a] -pelog = [0,1,3,7,8] - --- -prometheus :: Fractional a => [a] -prometheus = [0,2,4,6,11] -scriabin :: Fractional a => [a] -scriabin = [0,1,4,7,9] - --- han chinese pentatonic scales -gong :: Fractional a => [a] -gong = [0,2,4,7,9] -shang :: Fractional a => [a] -shang = [0,2,5,7,10] -jiao :: Fractional a => [a] -jiao = [0,3,5,8,10] -zhi :: Fractional a => [a] -zhi = [0,2,5,7,9] -yu :: Fractional a => [a] -yu = [0,3,5,7,10] - --- 6 note scales -whole' :: Fractional a => [a] -whole' = [0,2,4,6,8,10] -augmented :: Fractional a => [a] -augmented = [0,3,4,7,8,11] -augmented2 :: Fractional a => [a] -augmented2 = [0,1,4,5,8,9] - --- hexatonic modes with no tritone -hexMajor7 :: Fractional a => [a] -hexMajor7 = [0,2,4,7,9,11] -hexDorian :: Fractional a => [a] -hexDorian = [0,2,3,5,7,10] -hexPhrygian :: Fractional a => [a] -hexPhrygian = [0,1,3,5,8,10] -hexSus :: Fractional a => [a] -hexSus = [0,2,5,7,9,10] -hexMajor6 :: Fractional a => [a] -hexMajor6 = [0,2,4,5,7,9] -hexAeolian :: Fractional a => [a] -hexAeolian = [0,3,5,7,8,10] - --- 7 note scales -major :: Fractional a => [a] -major = [0,2,4,5,7,9,11] -ionian :: Fractional a => [a] -ionian = [0,2,4,5,7,9,11] -dorian :: Fractional a => [a] -dorian = [0,2,3,5,7,9,10] -phrygian :: Fractional a => [a] -phrygian = [0,1,3,5,7,8,10] -lydian :: Fractional a => [a] -lydian = [0,2,4,6,7,9,11] -mixolydian :: Fractional a => [a] -mixolydian = [0,2,4,5,7,9,10] -aeolian :: Fractional a => [a] -aeolian = [0,2,3,5,7,8,10] -minor :: Fractional a => [a] -minor = [0,2,3,5,7,8,10] -locrian :: Fractional a => [a] -locrian = [0,1,3,5,6,8,10] -harmonicMinor :: Fractional a => [a] -harmonicMinor = [0,2,3,5,7,8,11] -harmonicMajor :: Fractional a => [a] -harmonicMajor = [0,2,4,5,7,8,11] -melodicMinor :: Fractional a => [a] -melodicMinor = [0,2,3,5,7,9,11] -melodicMinorDesc :: Fractional a => [a] -melodicMinorDesc = [0,2,3,5,7,8,10] -melodicMajor :: Fractional a => [a] -melodicMajor = [0,2,4,5,7,8,10] -bartok :: Fractional a => [a] -bartok = melodicMajor -hindu :: Fractional a => [a] -hindu = melodicMajor - --- raga modes -todi :: Fractional a => [a] -todi = [0,1,3,6,7,8,11] -purvi :: Fractional a => [a] -purvi = [0,1,4,6,7,8,11] -marva :: Fractional a => [a] -marva = [0,1,4,6,7,9,11] -bhairav :: Fractional a => [a] -bhairav = [0,1,4,5,7,8,11] -ahirbhairav :: Fractional a => [a] -ahirbhairav = [0,1,4,5,7,9,10] - --- -superLocrian :: Fractional a => [a] -superLocrian = [0,1,3,4,6,8,10] -romanianMinor :: Fractional a => [a] -romanianMinor = [0,2,3,6,7,9,10] -hungarianMinor :: Fractional a => [a] -hungarianMinor = [0,2,3,6,7,8,11] -neapolitanMinor :: Fractional a => [a] -neapolitanMinor = [0,1,3,5,7,8,11] -enigmatic :: Fractional a => [a] -enigmatic = [0,1,4,6,8,10,11] -spanish :: Fractional a => [a] -spanish = [0,1,4,5,7,8,10] - --- modes of whole tones with added note -> -leadingWhole :: Fractional a => [a] -leadingWhole = [0,2,4,6,8,10,11] -lydianMinor :: Fractional a => [a] -lydianMinor = [0,2,4,6,7,8,10] -neapolitanMajor :: Fractional a => [a] -neapolitanMajor = [0,1,3,5,7,9,11] -locrianMajor :: Fractional a => [a] -locrianMajor = [0,2,4,5,6,8,10] - --- 8 note scales -diminished :: Fractional a => [a] -diminished = [0,1,3,4,6,7,9,10] -diminished2 :: Fractional a => [a] -diminished2 = [0,2,3,5,6,8,9,11] - --- modes of limited transposition -messiaen1 :: Fractional a => [a] -messiaen1 = whole' -messiaen2 :: Fractional a => [a] -messiaen2 = diminished -messiaen3 :: Fractional a => [a] -messiaen3 = [0, 2, 3, 4, 6, 7, 8, 10, 11] -messiaen4 :: Fractional a => [a] -messiaen4 = [0, 1, 2, 5, 6, 7, 8, 11] -messiaen5 :: Fractional a => [a] -messiaen5 = [0, 1, 5, 6, 7, 11] -messiaen6 :: Fractional a => [a] -messiaen6 = [0, 2, 4, 5, 6, 8, 10, 11] -messiaen7 :: Fractional a => [a] -messiaen7 = [0, 1, 2, 3, 5, 6, 7, 8, 9, 11] - --- Arabic maqams taken from SuperCollider's Scale.sc -bayati :: Fractional a => [a] -bayati = [0, 1.5, 3, 5, 7, 8, 10] -hijaz :: Fractional a => [a] -hijaz = [0, 1, 4, 5, 7, 8.5, 10] -sikah :: Fractional a => [a] -sikah = [0, 1.5, 3.5, 5.5, 7, 8.5, 10.5] -rast :: Fractional a => [a] -rast = [0, 2, 3.5, 5, 7, 9, 10.5] -iraq :: Fractional a => [a] -iraq = [0, 1.5, 3.5, 5, 6.5, 8.5, 10.5] -saba :: Fractional a => [a] -saba = [0, 1.5, 3, 4, 6, 8, 10] - --- 12 note scales -chromatic :: Fractional a => [a] -chromatic = [0,1,2,3,4,5,6,7,8,9,10,11] - -scale :: Fractional a => Signal String -> Signal Int -> Signal a -scale = getScale scaleTable - -getScale :: Fractional a => [(String, [a])] -> Signal String -> Signal Int -> Signal a -getScale table sp p = (\n scaleName - -> noteInScale (fromMaybe [0] $ lookup scaleName table) n) <$> p <* sp - where octave s x = x `div` length s - noteInScale s x = (s !!! x) + fromIntegral (12 * octave s x) - -scaleList :: String -scaleList = unwords $ map fst (scaleTable :: [(String, [Rational])]) - -scaleTable :: Fractional a => [(String, [a])] -scaleTable = [("minPent", minPent), - ("majPent", majPent), - ("ritusen", ritusen), - ("egyptian", egyptian), - ("kumai", kumai), - ("hirajoshi", hirajoshi), - ("iwato", iwato), - ("chinese", chinese), - ("indian", indian), - ("pelog", pelog), - ("prometheus", prometheus), - ("scriabin", scriabin), - ("gong", gong), - ("shang", shang), - ("jiao", jiao), - ("zhi", zhi), - ("yu", yu), - ("whole", whole'), - ("wholetone", whole'), - ("augmented", augmented), - ("augmented2", augmented2), - ("hexMajor7", hexMajor7), - ("hexDorian", hexDorian), - ("hexPhrygian", hexPhrygian), - ("hexSus", hexSus), - ("hexMajor6", hexMajor6), - ("hexAeolian", hexAeolian), - ("major", major), - ("ionian", ionian), - ("dorian", dorian), - ("phrygian", phrygian), - ("lydian", lydian), - ("mixolydian", mixolydian), - ("aeolian", aeolian), - ("minor", minor), - ("locrian", locrian), - ("harmonicMinor", harmonicMinor), - ("harmonicMajor", harmonicMajor), - ("melodicMinor", melodicMinor), - ("melodicMinorDesc", melodicMinorDesc), - ("melodicMajor", melodicMajor), - ("bartok", bartok), - ("hindu", hindu), - ("todi", todi), - ("purvi", purvi), - ("marva", marva), - ("bhairav", bhairav), - ("ahirbhairav", ahirbhairav), - ("superLocrian", superLocrian), - ("romanianMinor", romanianMinor), - ("hungarianMinor", hungarianMinor), - ("neapolitanMinor", neapolitanMinor), - ("enigmatic", enigmatic), - ("spanish", spanish), - ("leadingWhole", leadingWhole), - ("lydianMinor", lydianMinor), - ("neapolitanMajor", neapolitanMajor), - ("locrianMajor", locrianMajor), - ("diminished", diminished), - ("octatonic", diminished), - ("diminished2", diminished2), - ("octatonic2", diminished2), - ("messiaen1", messiaen1), - ("messiaen2", messiaen2), - ("messiaen3", messiaen3), - ("messiaen4", messiaen4), - ("messiaen5", messiaen5), - ("messiaen6", messiaen6), - ("messiaen7", messiaen7), - ("chromatic", chromatic), - ("bayati", bayati), - ("hijaz", hijaz), - ("sikah", sikah), - ("rast", rast), - ("saba", saba), - ("iraq", iraq) - ] diff --git a/tidal-core/src/Sound/Tidal/Compose.hs b/tidal-core/src/Sound/Tidal/Compose.hs index 39d4e027a..cb9557a55 100644 --- a/tidal-core/src/Sound/Tidal/Compose.hs +++ b/tidal-core/src/Sound/Tidal/Compose.hs @@ -12,7 +12,7 @@ import Data.Bits import Data.Bool (bool) import qualified Data.Map.Strict as Map import Prelude hiding (Applicative (..)) -import Sound.Tidal.Pattern (filterJusts, flexBind) +import Sound.Tidal.Pattern (filterJusts) import Sound.Tidal.Types -- ************************************************************ -- @@ -30,7 +30,7 @@ instance {-# OVERLAPPING #-} Unionable ValueMap where union = Map.union liftP2 :: Pattern p => (a -> b -> c) -> (p a -> p b -> p c) -liftP2 op apat bpat = apat `flexBind` \a -> op a <$> bpat +liftP2 op apat bpat = apat `mixBind` \a -> op a <$> bpat set, keep :: Pattern p => p a -> p a -> p a set = liftA2 (flip union) diff --git a/tidal-core/src/Sound/Tidal/InstanceHacks.hs b/tidal-core/src/Sound/Tidal/InstanceHacks.hs index 15c132a42..5156d860e 100644 --- a/tidal-core/src/Sound/Tidal/InstanceHacks.hs +++ b/tidal-core/src/Sound/Tidal/InstanceHacks.hs @@ -11,7 +11,7 @@ import qualified Data.Map.Strict as Map -- import Sound.Tidal.Compose (liftA2) import Sound.Tidal.Sequence () import Sound.Tidal.Signal () -import Sound.Tidal.Span (withSpanTime) +-- import Sound.Tidal.Span (withSpanTime) import Sound.Tidal.Types import Sound.Tidal.Value diff --git a/tidal-core/src/Sound/Tidal/Pattern.hs b/tidal-core/src/Sound/Tidal/Pattern.hs index 5ba761c21..2fad673dd 100644 --- a/tidal-core/src/Sound/Tidal/Pattern.hs +++ b/tidal-core/src/Sound/Tidal/Pattern.hs @@ -23,25 +23,34 @@ alignify f = \apat bpat -> uncurry f (patAlign apat bpat) patternify_P :: Pattern p => (a -> p b) -> (p a -> p b) patternify_P f apat = apat `bind` f - where bind = patBind apat + where bind = patBindMix apat + +patternify' :: Pattern p => BindSpec p -> (a -> p b) -> (p a -> p b) +patternify' spec f apat = apat `bind` f + where bind = specToBind spec + + +-- patternify_P' :: (Pattern p) => BindSpec (p a) -> (a -> p b) -> (p a -> p b) +-- patternify_P' spec f apat = apat `bind` f +-- where bind = patBindMix apat patternify_P_n :: Pattern p => (a -> b -> p c) -> (p a -> b -> p c) patternify_P_n f apat b = apat `bind` \a -> f a b - where bind = patBind apat + where bind = patBindMix apat patternify_P_p :: Pattern p => (a -> p b -> p c) -> (p a -> p b -> p c) patternify_P_p = alignify . patternify_P_n +patternify_P_P :: Pattern p => (a -> b -> p c) -> (p a -> p b -> p c) +patternify_P_P f = alignify $ patternify_P_n $ patternify_P <$> f + patternify_P_n_n :: Pattern p => (a -> b -> c -> p d) -> (p a -> b -> c -> p d) patternify_P_n_n f apat b c = apat `bind` \a -> f a b c - where bind = patBind apat + where bind = patBindMix apat patternify_P_n_n_n :: Pattern p => (a -> b -> c -> d -> p e) -> (p a -> b -> c -> d -> p e) patternify_P_n_n_n f apat b c d = apat `bind` \a -> f a b c d - where bind = patBind apat - -patternify_P_P :: Pattern p => (a -> b -> p c) -> (p a -> p b -> p c) -patternify_P_P f = alignify $ patternify_P_n $ patternify_P <$> f + where bind = patBindMix apat patternify_P_P_n :: Pattern p => (a -> b -> c -> p d) -> (p a -> p b -> c -> p d) patternify_P_P_n f = alignify $ patternify_P_n_n $ patternify_P_n <$> f @@ -53,12 +62,15 @@ patternify_P_P_P_n :: Pattern p => (a -> b -> c -> d -> p e) -> p a -> p b -> p patternify_P_P_P_n f = alignify $ patternify_P_n_n_n $ patternify_P_P_n <$> f (<*), (*>) :: Pattern p => p (t -> b) -> p t -> p b -pf <* px = pf `innerBind` \f -> px `innerBind` \x -> pure $ f x -pf *> px = pf `outerBind` \f -> px `outerBind` \x -> pure $ f x +pf <* px = pf `innerBind` (<$> px) +pf *> px = pf `outerBind` (<$> px) infixl 4 <*, *> -flexBind :: Pattern p => p b -> (b -> p c) -> p c -flexBind a b = (patBind a) a b +(|>>=), (>>=|), (|>>=|) :: Pattern p => p a -> (a -> p b) -> p b +(|>>=) = innerBind +(>>=|) = outerBind +(|>>=|) = (>>=) -- mixBind +infixl 4 |>>=, >>=|, |>>=| filterJusts :: Pattern p => p (Maybe a) -> p a filterJusts = fmap fromJust . filterValues isJust diff --git a/tidal-core/src/Sound/Tidal/Sequence.hs b/tidal-core/src/Sound/Tidal/Sequence.hs index 2c6c08645..913c3f8ff 100644 --- a/tidal-core/src/Sound/Tidal/Sequence.hs +++ b/tidal-core/src/Sound/Tidal/Sequence.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} module Sound.Tidal.Sequence where @@ -19,7 +20,8 @@ instance Functor Sequence where instance Monad Sequence where return = pure - (>>=) a b = (patBind a) a b + -- (>>=) a b = (patBind a) a b + (>>=) = mixBind instance Applicative Sequence where pure = step 1 @@ -28,6 +30,8 @@ instance Applicative Sequence where -- where (pf', px') = patAlign pf px instance Pattern Sequence where + data BindSpec Sequence = Strat BindDir Alignment + -- specToBindDir (SequenceBindSpec dir _) = dir withTime f _ pat = withAtomTime f pat cat = Cat -- TODO - shallow cat? -- maintain unit (beats) @@ -52,7 +56,9 @@ instance Pattern Sequence where squeeze = setAlignment SqueezeIn squeezeOut = setAlignment SqueezeOut - patBind = getSeqBind + patBindIn = getSeqBind SeqIn + patBindOut = getSeqBind SeqOut + patBindMix = getSeqBind SeqMix patAlign = getSeqAlign _early t = (\(a, b) -> cat [a,b]) . seqSplitAt t @@ -174,6 +180,23 @@ seqTakeLoop t (Cat ss) = Cat $ loop t $ cycle ss where stepDur = duration s seqTakeLoop t (SeqMetadata _ x) = seqTakeLoop t x +-- If you ask for too much, the result gets right padded with silence +seqTake :: Time -> Sequence a -> Sequence a +seqTake 0 _ = gap 0 +seqTake t pat@(Atom m d i _ v) | t > d = seqTake t $ Cat $ repeat pat + | otherwise = Atom m t i (max 0 $ d - t) v +seqTake t (Stack ss) = Stack $ map (seqTake t) ss +seqTake t (Cat []) = gap t +seqTake t (Cat ss) = Cat $ loop t ss + where loop :: Time -> [Sequence a] -> [Sequence a] + loop t [] = [gap t] + loop t' (s:ss') | t' <= 0 = [] + | t' <= stepDur = [seqTake t' s] + | otherwise = seqTake stepDur s : loop (t' - stepDur) ss' + where stepDur = duration s +seqTake t (SeqMetadata _ x) = seqTake t x + + seqDrop :: Time -> Sequence a -> Sequence a seqDrop 0 s = s -- The mod makes this 'safe' but is probably a bad idea.. @@ -205,6 +228,17 @@ withAtom f (SeqMetadata _ x) = withAtom f x withAtomTime :: (Time -> Time) -> Sequence a -> Sequence a withAtomTime f = withAtom $ \m d i o v -> Atom m (f d) (f i) (f o) v +withAtomContext :: (Time -> Time -> Metadata -> Time -> Time -> Time -> + Maybe a -> Sequence a) -> Sequence a -> Sequence a +withAtomContext f pat = withAtomContext' 0 pat + where withAtomContext' pos (Atom m d i o v) = f pos patdur m d i o v + withAtomContext' pos (Cat xs) = Cat $ loop pos xs + where loop pos' [] = [] + loop pos' (x:xs) = withAtomContext' pos' x : loop (pos' + duration x) xs + withAtomContext' pos (Stack xs) = Stack $ map (withAtomContext' pos) xs + withAtomContext' pos (SeqMetadata _ x) = withAtomContext' pos x + patdur = duration pat + -- One beat per cycle seqToSignal :: Sequence a -> Signal a seqToSignal pat = _slow (duration pat) $ seqToSignal' pat @@ -235,8 +269,8 @@ bindAlignment (SeqMetadata strat _) = strat -- default strategy and alignment bindAlignment _ = SeqBindAlignment Expand SeqIn -getSeqBind :: Pattern p => Sequence a -> p b -> (b -> p c) -> p c -getSeqBind pat = case (seqBind $ bindAlignment pat) of +getSeqBind :: SequenceBind -> Pattern p => Sequence a -> p b -> (b -> p c) -> p c +getSeqBind defaultBind pat = case (seqBind $ bindAlignment pat) of SeqIn -> innerBind SeqOut -> outerBind SeqMix -> (>>=) @@ -313,9 +347,10 @@ withLargest f a b | o == LT = (a, f b) where o = compare (duration a) (duration b) align :: Alignment -> Sequence a -> Sequence b -> (Sequence a, Sequence b) -align Repeat a b = (replic a, replic b) +align Repeat a b = (seqReplicate (floor $ d / duration a) a, + seqReplicate (floor $ d / duration b) b + ) where d = lcmTime (duration a) (duration b) - replic x = seqReplicate (floor $ d / duration x) x seqReplicate :: Int -> Sequence a -> Sequence a seqReplicate n (Cat xs) = Cat $ concat $ replicate n xs seqReplicate n x = Cat $ replicate n x diff --git a/tidal-core/src/Sound/Tidal/Signal.hs b/tidal-core/src/Sound/Tidal/Signal.hs index 8bb9e3850..2b922c9cb 100644 --- a/tidal-core/src/Sound/Tidal/Signal.hs +++ b/tidal-core/src/Sound/Tidal/Signal.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TypeFamilies #-} + module Sound.Tidal.Signal where -- To get liftA2.. avoids import warning @@ -16,8 +18,8 @@ import Sound.Tidal.Types import Sound.Tidal.Utils (enumerate) instance Monad Signal where - (>>=) a b = (patBind a) a b - -- (>>=) = mixBind + -- (>>=) a b = (patBind a) a b + (>>=) = mixBind return = pure -- Define applicative from monad @@ -27,8 +29,10 @@ instance Applicative Signal where pf <*> px = pf >>= (<$> px) instance Pattern Signal where + data BindSpec Signal = BindDir -- We always work with signals as if they have a duration of 1 -- cycle, even though successive cycles very often differ + -- specToBindDir (SignalBindSpec dir) = dir duration _ = 1 withTime fa fb pat = withEventTime fa $ withQueryTime fb pat -- | Alternative binds/joins @@ -47,7 +51,9 @@ instance Pattern Signal where squeeze = setSigBind SigSqueeze squeezeOut = setSigBind SigSqueezeOut - patBind = getSigBind + patBindIn = getSigBind SigIn + patBindOut = getSigBind SigOut + patBindMix = getSigBind SigMix -- Signals are always aligned cycle-by-cycle patAlign a b = (a,b) @@ -78,8 +84,8 @@ instance Pattern Signal where $ withQuerySpan (mapCycle ((+s) . (*d))) p where d = e-s -getSigBind :: Signal a -> Signal b -> (b -> Signal c) -> Signal c -getSigBind pat = case (signalBind pat) of +getSigBind :: SignalBind -> Signal a -> Signal b -> (b -> Signal c) -> Signal c +getSigBind defaultBind pat = case (signalBind pat) of SigIn -> innerBind SigOut -> outerBind SigSqueeze -> squeezeBind @@ -89,7 +95,7 @@ getSigBind pat = case (signalBind pat) of SigMix -> mixBind where signalBind :: Signal a -> SignalBind signalBind (Signal {sigMetadata = SignalMetadata (Just bind)}) = bind - signalBind _ = SigIn + signalBind _ = defaultBind setSigBind :: SignalBind -> Signal a -> Signal a setSigBind bind pat = pat {sigMetadata = SignalMetadata (Just bind)} diff --git a/tidal-core/src/Sound/Tidal/Types.hs b/tidal-core/src/Sound/Tidal/Types.hs index d2ada0a3e..ee6959e48 100644 --- a/tidal-core/src/Sound/Tidal/Types.hs +++ b/tidal-core/src/Sound/Tidal/Types.hs @@ -39,18 +39,33 @@ class Applicative t => Applicable t a b where toA :: a -> t b instance forall a t. Applicative t => Applicable t (a) (a) where toA = pure instance forall a t. Applicative t => Applicable t (t a) (a) where toA = id +data BindDir = Inner | Outer | Both + deriving Eq + +-- data family BindSpec a +-- data instance BindSpec (Signal b) = SignalBindSpec BindDir +-- data instance BindSpec (Sequence b) = SequenceBindSpec BindDir Alignment + +specToBind :: (Pattern p1, Pattern p2) => BindSpec p1 -> p2 a -> (a -> p2 b) -> p2 b +specToBind spec | bindDir == Inner = innerBind + | bindDir == Outer = outerBind + | bindDir == Both = mixBind + where bindDir = specToBindDir spec + -- | A type class for patterns class (Functor p, Applicative p, Monad p) => Pattern p where + data BindSpec p :: * {-# MINIMAL (mixBind | mixJoin), (innerBind | innerJoin), (outerBind | outerJoin), (squeezeBind | squeezeJoin), (squeezeOutBind | squeezeOutJoin), - patBind, patAlign, + patBindIn, patBindOut, patBindMix, patAlign, inner, outer, mix, trig, trig0, squeeze, squeezeOut, duration, withTime, cat, timeCat, stack, _early, rev, toSignal, withMetadata, silence, _zoomSpan #-} + specToBindDir :: BindSpec p -> BindDir duration :: p a -> Time withTime :: (Time -> Time) -> (Time -> Time) -> p a -> p a mixBind, innerBind, outerBind, squeezeBind, squeezeOutBind :: p a -> (a -> p b) -> p b @@ -75,7 +90,9 @@ class (Functor p, Applicative p, Monad p) => Pattern p where squeeze :: p a -> p a squeezeOut :: p a -> p a - patBind :: p a -> p b -> (b -> p c) -> p c + patBindIn :: p a -> p b -> (b -> p c) -> p c + patBindOut :: p a -> p b -> (b -> p c) -> p c + patBindMix :: p a -> p b -> (b -> p c) -> p c patAlign :: p a -> p b -> (p a, p b) cat :: [p a] -> p a