From 0af6c1e98a376e05efe7e6fec38319fbe8b26963 Mon Sep 17 00:00:00 2001 From: alex Date: Mon, 27 Jan 2025 15:26:04 +0100 Subject: [PATCH 01/12] add ormolu job to check formatting --- .github/workflows/ci.yml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 699e4394..f1e73bfe 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -75,4 +75,9 @@ jobs: - name: test run: cabal v2-test ${{ matrix.versions.args }} --enable-tests --enable-benchmarks all + ormolu: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v4 + - uses: haskell-actions/run-ormolu@v17 From 7cbd6104614fd5cba806d037f86854e074faee3a Mon Sep 17 00:00:00 2001 From: alex Date: Mon, 27 Jan 2025 15:30:52 +0100 Subject: [PATCH 02/12] hello ormolu --- src/Sound/Tidal/Bjorklund.hs | 40 +- src/Sound/Tidal/Boot.hs | 180 +- src/Sound/Tidal/Chords.hs | 524 ++- src/Sound/Tidal/Context.hs | 32 +- src/Sound/Tidal/Control.hs | 717 ++- src/Sound/Tidal/Core.hs | 816 ++-- src/Sound/Tidal/ID.hs | 7 +- src/Sound/Tidal/Listener.hs | 18 +- src/Sound/Tidal/Params.hs | 2207 ++++++--- src/Sound/Tidal/ParseBP.hs | 739 +-- src/Sound/Tidal/Pattern.hs | 1018 +++-- src/Sound/Tidal/Safe/Boot.hs | 121 +- src/Sound/Tidal/Safe/Context.hs | 104 +- src/Sound/Tidal/Scales.hs | 517 ++- src/Sound/Tidal/Show.hs | 214 +- src/Sound/Tidal/Simple.hs | 8 +- src/Sound/Tidal/Stepwise.hs | 98 +- src/Sound/Tidal/Stream.hs | 31 +- src/Sound/Tidal/Stream/Config.hs | 43 +- src/Sound/Tidal/Stream/Listen.hs | 194 +- src/Sound/Tidal/Stream/Main.hs | 85 +- src/Sound/Tidal/Stream/Process.hs | 444 +- src/Sound/Tidal/Stream/Target.hs | 212 +- src/Sound/Tidal/Stream/Types.hs | 115 +- src/Sound/Tidal/Stream/UI.hs | 117 +- src/Sound/Tidal/TH.hs | 24 +- src/Sound/Tidal/Time.hs | 57 +- src/Sound/Tidal/Transition.hs | 266 +- src/Sound/Tidal/UI.hs | 3947 +++++++++-------- src/Sound/Tidal/Utils.hs | 113 +- src/Sound/Tidal/Version.hs | 8 +- test/Sound/Tidal/ChordsTest.hs | 97 +- test/Sound/Tidal/ControlTest.hs | 50 +- test/Sound/Tidal/CoreTest.hs | 12 +- test/Sound/Tidal/ExceptionsTest.hs | 51 +- test/Sound/Tidal/ParamsTest.hs | 44 +- test/Sound/Tidal/ParseTest.hs | 208 +- test/Sound/Tidal/PatternTest.hs | 522 +-- test/Sound/Tidal/ScalesTest.hs | 683 +-- test/Sound/Tidal/StreamTest.hs | 12 +- test/Sound/Tidal/UITest.hs | 420 +- test/Sound/Tidal/UtilsTest.hs | 56 +- tidal-link/src/hs/Sound/Tidal/Clock.hs | 294 +- tidal-parse/src/Sound/Tidal/Parse.hs | 950 ++-- .../test/Sound/Tidal/TidalParseTest.hs | 190 +- tidal-parse/test/Test.hs | 3 +- 46 files changed, 9148 insertions(+), 7460 deletions(-) diff --git a/src/Sound/Tidal/Bjorklund.hs b/src/Sound/Tidal/Bjorklund.hs index f1ca05e2..f9c5cdd2 100644 --- a/src/Sound/Tidal/Bjorklund.hs +++ b/src/Sound/Tidal/Bjorklund.hs @@ -22,29 +22,29 @@ module Sound.Tidal.Bjorklund (bjorklund) where -- the library but removed for now due to dependency problems.. We -- could however likely benefit from other parts of the library.. -type STEP a = ((Int,Int),([[a]],[[a]])) +type STEP a = ((Int, Int), ([[a]], [[a]])) left :: STEP a -> STEP a -left ((i,j),(xs,ys)) = - let (xs',xs'') = splitAt j xs - in ((j,i-j),(zipWith (++) xs' ys,xs'')) +left ((i, j), (xs, ys)) = + let (xs', xs'') = splitAt j xs + in ((j, i - j), (zipWith (++) xs' ys, xs'')) right :: STEP a -> STEP a -right ((i,j),(xs,ys)) = - let (ys',ys'') = splitAt i ys - in ((i,j-i),(zipWith (++) xs ys',ys'')) +right ((i, j), (xs, ys)) = + let (ys', ys'') = splitAt i ys + in ((i, j - i), (zipWith (++) xs ys', ys'')) bjorklund' :: STEP a -> STEP a -bjorklund' (n,x) = - let (i,j) = n - in if min i j <= 1 - then (n,x) - else bjorklund' (if i > j then left (n,x) else right (n,x)) - -bjorklund :: (Int,Int) -> [Bool] -bjorklund (i,j') = - let j = j' - i - x = replicate i [True] - y = replicate j [False] - (_,(x',y')) = bjorklund' ((i,j),(x,y)) - in concat x' ++ concat y' +bjorklund' (n, x) = + let (i, j) = n + in if min i j <= 1 + then (n, x) + else bjorklund' (if i > j then left (n, x) else right (n, x)) + +bjorklund :: (Int, Int) -> [Bool] +bjorklund (i, j') = + let j = j' - i + x = replicate i [True] + y = replicate j [False] + (_, (x', y')) = bjorklund' ((i, j), (x, y)) + in concat x' ++ concat y' diff --git a/src/Sound/Tidal/Boot.hs b/src/Sound/Tidal/Boot.hs index 7461f2b7..84a29812 100644 --- a/src/Sound/Tidal/Boot.hs +++ b/src/Sound/Tidal/Boot.hs @@ -1,92 +1,92 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Sound.Tidal.Boot - ( Tidally (..) - , OscMap - , mkOscMap - , mkTidal - , mkTidalWith - , only - , p - , _p - , p_ - , hush - , panic - , list - , mute - , unmute - , unmuteAll - , unsoloAll - , solo - , unsolo - , once - , asap - , first - , nudgeAll - , all - , resetCycles - , setCycle - , setcps - , getcps - , setbpm - , getbpm - , getnow - , d1 - , d2 - , d3 - , d4 - , d5 - , d6 - , d7 - , d8 - , d9 - , d10 - , d11 - , d12 - , d13 - , d14 - , d15 - , d16 - , _d1 - , _d2 - , _d3 - , _d4 - , _d5 - , _d6 - , _d7 - , _d8 - , _d9 - , _d10 - , _d11 - , _d12 - , _d13 - , _d14 - , _d15 - , _d16 - , 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 + ( Tidally (..), + OscMap, + mkOscMap, + mkTidal, + mkTidalWith, + only, + p, + _p, + p_, + hush, + panic, + list, + mute, + unmute, + unmuteAll, + unsoloAll, + solo, + unsolo, + once, + asap, + first, + nudgeAll, + all, + resetCycles, + setCycle, + setcps, + getcps, + setbpm, + getbpm, + getnow, + d1, + d2, + d3, + d4, + d5, + d6, + d7, + d8, + d9, + d10, + d11, + d12, + d13, + d14, + d15, + d16, + _d1, + _d2, + _d3, + _d4, + _d5, + _d6, + _d7, + _d8, + _d9, + _d10, + _d11, + _d12, + _d13, + _d14, + _d15, + _d16, + 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 @@ -108,10 +108,10 @@ where along with this library. If not, see . -} -import Prelude hiding (all, (*>), (<*)) -import Sound.Tidal.Context -import Sound.Tidal.ID (ID) -import System.IO (hSetEncoding, stdout, utf8) +import Sound.Tidal.Context +import Sound.Tidal.ID (ID) +import System.IO (hSetEncoding, stdout, utf8) +import Prelude hiding (all, (*>), (<*)) -- | 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/Chords.hs b/src/Sound/Tidal/Chords.hs index 323bc05e..3d4d371f 100644 --- a/src/Sound/Tidal/Chords.hs +++ b/src/Sound/Tidal/Chords.hs @@ -19,7 +19,6 @@ module Sound.Tidal.Chords where -} import Data.Maybe - import Sound.Tidal.Pattern -- * Chord definitions @@ -27,117 +26,162 @@ import Sound.Tidal.Pattern -- ** Major chords major :: Num a => [a] -major = [0,4,7] +major = [0, 4, 7] + aug :: Num a => [a] -aug = [0,4,8] +aug = [0, 4, 8] + six :: Num a => [a] -six = [0,4,7,9] +six = [0, 4, 7, 9] + sixNine :: Num a => [a] -sixNine = [0,4,7,9,14] +sixNine = [0, 4, 7, 9, 14] + major7 :: Num a => [a] -major7 = [0,4,7,11] +major7 = [0, 4, 7, 11] + major9 :: Num a => [a] -major9 = [0,4,7,11,14] +major9 = [0, 4, 7, 11, 14] + add9 :: Num a => [a] -add9 = [0,4,7,14] +add9 = [0, 4, 7, 14] + major11 :: Num a => [a] -major11 = [0,4,7,11,14,17] +major11 = [0, 4, 7, 11, 14, 17] + add11 :: Num a => [a] -add11 = [0,4,7,17] +add11 = [0, 4, 7, 17] + major13 :: Num a => [a] -major13 = [0,4,7,11,14,21] +major13 = [0, 4, 7, 11, 14, 21] + add13 :: Num a => [a] -add13 = [0,4,7,21] +add13 = [0, 4, 7, 21] -- ** Dominant chords dom7 :: Num a => [a] -dom7 = [0,4,7,10] +dom7 = [0, 4, 7, 10] + dom9 :: Num a => [a] -dom9 = [0,4,7,14] +dom9 = [0, 4, 7, 14] + dom11 :: Num a => [a] -dom11 = [0,4,7,17] +dom11 = [0, 4, 7, 17] + dom13 :: Num a => [a] -dom13 = [0,4,7,21] +dom13 = [0, 4, 7, 21] + sevenFlat5 :: Num a => [a] -sevenFlat5 = [0,4,6,10] +sevenFlat5 = [0, 4, 6, 10] + sevenSharp5 :: Num a => [a] -sevenSharp5 = [0,4,8,10] +sevenSharp5 = [0, 4, 8, 10] + sevenFlat9 :: Num a => [a] -sevenFlat9 = [0,4,7,10,13] +sevenFlat9 = [0, 4, 7, 10, 13] + nine :: Num a => [a] -nine = [0,4,7,10,14] +nine = [0, 4, 7, 10, 14] + eleven :: Num a => [a] -eleven = [0,4,7,10,14,17] +eleven = [0, 4, 7, 10, 14, 17] + thirteen :: Num a => [a] -thirteen = [0,4,7,10,14,17,21] +thirteen = [0, 4, 7, 10, 14, 17, 21] -- ** Minor chords minor :: Num a => [a] -minor = [0,3,7] +minor = [0, 3, 7] + diminished :: Num a => [a] -diminished = [0,3,6] +diminished = [0, 3, 6] + minorSharp5 :: Num a => [a] -minorSharp5 = [0,3,8] +minorSharp5 = [0, 3, 8] + minor6 :: Num a => [a] -minor6 = [0,3,7,9] +minor6 = [0, 3, 7, 9] + minorSixNine :: Num a => [a] -minorSixNine = [0,3,9,7,14] +minorSixNine = [0, 3, 9, 7, 14] + minor7flat5 :: Num a => [a] -minor7flat5 = [0,3,6,10] +minor7flat5 = [0, 3, 6, 10] + minor7 :: Num a => [a] -minor7 = [0,3,7,10] +minor7 = [0, 3, 7, 10] + minor7sharp5 :: Num a => [a] -minor7sharp5 = [0,3,8,10] +minor7sharp5 = [0, 3, 8, 10] + minor7flat9 :: Num a => [a] -minor7flat9 = [0,3,7,10,13] +minor7flat9 = [0, 3, 7, 10, 13] + minor7sharp9 :: Num a => [a] -minor7sharp9 = [0,3,7,10,15] +minor7sharp9 = [0, 3, 7, 10, 15] + diminished7 :: Num a => [a] -diminished7 = [0,3,6,9] +diminished7 = [0, 3, 6, 9] + minor9 :: Num a => [a] -minor9 = [0,3,7,10,14] +minor9 = [0, 3, 7, 10, 14] + minor11 :: Num a => [a] -minor11 = [0,3,7,10,14,17] +minor11 = [0, 3, 7, 10, 14, 17] + minor13 :: Num a => [a] -minor13 = [0,3,7,10,14,17,21] +minor13 = [0, 3, 7, 10, 14, 17, 21] + minorMajor7 :: Num a => [a] -minorMajor7 = [0,3,7,11] +minorMajor7 = [0, 3, 7, 11] -- ** Other chords one :: Num a => [a] one = [0] + five :: Num a => [a] -five = [0,7] +five = [0, 7] + sus2 :: Num a => [a] -sus2 = [0,2,7] +sus2 = [0, 2, 7] + sus4 :: Num a => [a] -sus4 = [0,5,7] +sus4 = [0, 5, 7] + sevenSus2 :: Num a => [a] -sevenSus2 = [0,2,7,10] +sevenSus2 = [0, 2, 7, 10] + sevenSus4 :: Num a => [a] -sevenSus4 = [0,5,7,10] +sevenSus4 = [0, 5, 7, 10] + nineSus4 :: Num a => [a] -nineSus4 = [0,5,7,10,14] +nineSus4 = [0, 5, 7, 10, 14] -- ** Questionable chords sevenFlat10 :: Num a => [a] -sevenFlat10 = [0,4,7,10,15] +sevenFlat10 = [0, 4, 7, 10, 15] + nineSharp5 :: Num a => [a] -nineSharp5 = [0,1,13] +nineSharp5 = [0, 1, 13] + minor9sharp5 :: Num a => [a] -minor9sharp5 = [0,1,14] +minor9sharp5 = [0, 1, 14] + sevenSharp5flat9 :: Num a => [a] -sevenSharp5flat9 = [0,4,8,10,13] +sevenSharp5flat9 = [0, 4, 8, 10, 13] + minor7sharp5flat9 :: Num a => [a] -minor7sharp5flat9 = [0,3,8,10,13] +minor7sharp5flat9 = [0, 3, 8, 10, 13] + elevenSharp :: Num a => [a] -elevenSharp = [0,4,7,10,14,18] +elevenSharp = [0, 4, 7, 10, 14, 18] + minor11sharp :: Num a => [a] -minor11sharp = [0,3,7,10,14,18] +minor11sharp = [0, 3, 7, 10, 14, 18] -- * Chord functions @@ -153,188 +197,187 @@ minor11sharp = [0,3,7,10,14,18] -- enchord :: Num a => [[a]] -> Pattern a -> Pattern Int -> Pattern a -- enchord chords pn pc = flatpat $ (chordate chords) <$> pn <*> pc -{-| - The @chordTable@ function outputs a list of all available chords and their - corresponding notes. For example, its first entry is @("major",[0,4,7])@ which - means that a major triad is formed by the root (0), the major third (4 semitones - above the root), and the perfect fifth (7 semitones above the root). - - As the list is big, you can use the function 'chordL'. - - If you know the notes from a chord, but can’t find the name of it, you can use this Haskell code to do a reverse look up into the table: - - > filter (\(_,x)->x==[0,4,7,10]) chordTable - - This will output @[("dom7",[0,4,7,10])]@ - - (You’ll need to run @import Sound.Tidal.Chords@ before using this function.) --} +-- | +-- The @chordTable@ function outputs a list of all available chords and their +-- corresponding notes. For example, its first entry is @("major",[0,4,7])@ which +-- means that a major triad is formed by the root (0), the major third (4 semitones +-- above the root), and the perfect fifth (7 semitones above the root). +-- +-- As the list is big, you can use the function 'chordL'. +-- +-- If you know the notes from a chord, but can’t find the name of it, you can use this Haskell code to do a reverse look up into the table: +-- +-- > filter (\(_,x)->x==[0,4,7,10]) chordTable +-- +-- This will output @[("dom7",[0,4,7,10])]@ +-- +-- (You’ll need to run @import Sound.Tidal.Chords@ before using this function.) chordTable :: Num a => [(String, [a])] -chordTable = [("major", major), - ("maj", major), - ("M", major), - ("aug", aug), - ("plus", aug), - ("sharp5", aug), - ("six", six), - ("6", six), - ("sixNine", sixNine), - ("six9", sixNine), - ("sixby9", sixNine), - ("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), - ("dom11", dom11), - ("dom13", dom13), - ("sevenFlat5", sevenFlat5), - ("7f5", sevenFlat5), - ("sevenSharp5", sevenSharp5), - ("7s5", sevenSharp5), - ("sevenFlat9", sevenFlat9), - ("7f9", sevenFlat9), - ("nine", nine), - ("eleven", eleven), - ("11", eleven), - ("thirteen", thirteen), - ("13", thirteen), - ("minor", minor), - ("min", minor), - ("m", minor), - ("diminished", diminished), - ("dim", diminished), - ("minorSharp5", minorSharp5), - ("msharp5", minorSharp5), - ("mS5", minorSharp5), - ("minor6", minor6), - ("min6", minor6), - ("m6", minor6), - ("minorSixNine", minorSixNine), - ("minor69", minorSixNine), - ("min69", minorSixNine), - ("minSixNine", minorSixNine), - ("m69", minorSixNine), - ("mSixNine", minorSixNine), - ("m6by9", minorSixNine), - ("minor7flat5", minor7flat5), - ("minor7f5", minor7flat5), - ("min7flat5", minor7flat5), - ("min7f5", minor7flat5), - ("m7flat5", minor7flat5), - ("m7f5", minor7flat5), - ("minor7", minor7), - ("min7", minor7), - ("m7", minor7), - ("minor7sharp5", minor7sharp5), - ("minor7s5", minor7sharp5), - ("min7sharp5", minor7sharp5), - ("min7s5", minor7sharp5), - ("m7sharp5", minor7sharp5), - ("m7s5", minor7sharp5), - ("minor7flat9", minor7flat9), - ("minor7f9", minor7flat9), - ("min7flat9", minor7flat9), - ("min7f9", minor7flat9), - ("m7flat9", minor7flat9), - ("m7f9", minor7flat9), - ("minor7sharp9", minor7sharp9), - ("minor7s9", minor7sharp9), - ("min7sharp9", minor7sharp9), - ("min7s9", minor7sharp9), - ("m7sharp9", minor7sharp9), - ("m7s9", minor7sharp9), - ("diminished7", diminished7), - ("dim7", diminished7), - ("minor9", minor9), - ("min9", minor9), - ("m9", minor9), - ("minor11", minor11), - ("min11", minor11), - ("m11", minor11), - ("minor13", minor13), - ("min13", minor13), - ("m13", minor13), - ("minorMajor7", minorMajor7), - ("minMaj7", minorMajor7), - ("mmaj7", minorMajor7), - ("one", one), - ("1", one), - ("five", five), - ("5", five), - ("sus2", sus2), - ("sus4", sus4), - ("sevenSus2", sevenSus2), - ("7sus2", sevenSus2), - ("sevenSus4", sevenSus4), - ("7sus4", sevenSus4), - ("nineSus4", nineSus4), - ("ninesus4", nineSus4), - ("9sus4", nineSus4), - ("sevenFlat10", sevenFlat10), - ("7f10", sevenFlat10), - ("nineSharp5", nineSharp5), - ("9sharp5", nineSharp5), - ("9s5", nineSharp5), - ("minor9sharp5", minor9sharp5), - ("minor9s5", minor9sharp5), - ("min9sharp5", minor9sharp5), - ("min9s5", minor9sharp5), - ("m9sharp5", minor9sharp5), - ("m9s5", minor9sharp5), - ("sevenSharp5flat9", sevenSharp5flat9), - ("7s5f9", sevenSharp5flat9), - ("minor7sharp5flat9", minor7sharp5flat9), - ("m7sharp5flat9", minor7sharp5flat9), - ("elevenSharp", elevenSharp), - ("11s", elevenSharp), - ("minor11sharp", minor11sharp), - ("m11sharp", minor11sharp), - ("m11s", minor11sharp) - ] +chordTable = + [ ("major", major), + ("maj", major), + ("M", major), + ("aug", aug), + ("plus", aug), + ("sharp5", aug), + ("six", six), + ("6", six), + ("sixNine", sixNine), + ("six9", sixNine), + ("sixby9", sixNine), + ("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), + ("dom11", dom11), + ("dom13", dom13), + ("sevenFlat5", sevenFlat5), + ("7f5", sevenFlat5), + ("sevenSharp5", sevenSharp5), + ("7s5", sevenSharp5), + ("sevenFlat9", sevenFlat9), + ("7f9", sevenFlat9), + ("nine", nine), + ("eleven", eleven), + ("11", eleven), + ("thirteen", thirteen), + ("13", thirteen), + ("minor", minor), + ("min", minor), + ("m", minor), + ("diminished", diminished), + ("dim", diminished), + ("minorSharp5", minorSharp5), + ("msharp5", minorSharp5), + ("mS5", minorSharp5), + ("minor6", minor6), + ("min6", minor6), + ("m6", minor6), + ("minorSixNine", minorSixNine), + ("minor69", minorSixNine), + ("min69", minorSixNine), + ("minSixNine", minorSixNine), + ("m69", minorSixNine), + ("mSixNine", minorSixNine), + ("m6by9", minorSixNine), + ("minor7flat5", minor7flat5), + ("minor7f5", minor7flat5), + ("min7flat5", minor7flat5), + ("min7f5", minor7flat5), + ("m7flat5", minor7flat5), + ("m7f5", minor7flat5), + ("minor7", minor7), + ("min7", minor7), + ("m7", minor7), + ("minor7sharp5", minor7sharp5), + ("minor7s5", minor7sharp5), + ("min7sharp5", minor7sharp5), + ("min7s5", minor7sharp5), + ("m7sharp5", minor7sharp5), + ("m7s5", minor7sharp5), + ("minor7flat9", minor7flat9), + ("minor7f9", minor7flat9), + ("min7flat9", minor7flat9), + ("min7f9", minor7flat9), + ("m7flat9", minor7flat9), + ("m7f9", minor7flat9), + ("minor7sharp9", minor7sharp9), + ("minor7s9", minor7sharp9), + ("min7sharp9", minor7sharp9), + ("min7s9", minor7sharp9), + ("m7sharp9", minor7sharp9), + ("m7s9", minor7sharp9), + ("diminished7", diminished7), + ("dim7", diminished7), + ("minor9", minor9), + ("min9", minor9), + ("m9", minor9), + ("minor11", minor11), + ("min11", minor11), + ("m11", minor11), + ("minor13", minor13), + ("min13", minor13), + ("m13", minor13), + ("minorMajor7", minorMajor7), + ("minMaj7", minorMajor7), + ("mmaj7", minorMajor7), + ("one", one), + ("1", one), + ("five", five), + ("5", five), + ("sus2", sus2), + ("sus4", sus4), + ("sevenSus2", sevenSus2), + ("7sus2", sevenSus2), + ("sevenSus4", sevenSus4), + ("7sus4", sevenSus4), + ("nineSus4", nineSus4), + ("ninesus4", nineSus4), + ("9sus4", nineSus4), + ("sevenFlat10", sevenFlat10), + ("7f10", sevenFlat10), + ("nineSharp5", nineSharp5), + ("9sharp5", nineSharp5), + ("9s5", nineSharp5), + ("minor9sharp5", minor9sharp5), + ("minor9s5", minor9sharp5), + ("min9sharp5", minor9sharp5), + ("min9s5", minor9sharp5), + ("m9sharp5", minor9sharp5), + ("m9s5", minor9sharp5), + ("sevenSharp5flat9", sevenSharp5flat9), + ("7s5f9", sevenSharp5flat9), + ("minor7sharp5flat9", minor7sharp5flat9), + ("m7sharp5flat9", minor7sharp5flat9), + ("elevenSharp", elevenSharp), + ("11s", elevenSharp), + ("minor11sharp", minor11sharp), + ("m11sharp", minor11sharp), + ("m11s", minor11sharp) + ] -- | Look up a specific chord: @chordL "minor7"@ returns @(0>1)|[0,3,7,10]@. chordL :: Num a => Pattern String -> Pattern [a] chordL p = (\name -> fromMaybe [] $ lookup name chordTable) <$> p -{-| -Outputs all the available chords: - -@ -major maj M aug plus sharp5 six 6 sixNine six9 sixby9 6by9 major7 maj7 -major9 maj9 add9 major11 maj11 add11 major13 maj13 add13 dom7 dom9 dom11 -dom13 sevenFlat5 7f5 sevenSharp5 7s5 sevenFlat9 7f9 nine eleven 11 thirteen 13 -minor min m diminished dim minorSharp5 msharp5 mS5 minor6 min6 m6 minorSixNine -minor69 min69 minSixNine m69 mSixNine m6by9 minor7flat5 minor7f5 min7flat5 -min7f5 m7flat5 m7f5 minor7 min7 m7 minor7sharp5 minor7s5 min7sharp5 min7s5 -m7sharp5 m7s5 minor7flat9 minor7f9 min7flat9 min7f9 m7flat9 m7f9 minor7sharp9 -minor7s9 min7sharp9 min7s9 m7sharp9 m7s9 diminished7 dim7 minor9 min9 m9 -minor11 min11 m11 minor13 min13 m13 minorMajor7 minMaj7 mmaj7 one 1 five 5 -sus2 sus4 sevenSus2 7sus2 sevenSus4 7sus4 nineSus4 ninesus4 9sus4 sevenFlat10 -7f10 nineSharp5 9sharp5 9s5 minor9sharp5 minor9s5 min9sharp5 min9s5 m9sharp5 -m9s5 sevenSharp5flat9 7s5f9 minor7sharp5flat9 m7sharp5flat9 elevenSharp 11s -minor11sharp m11sharp m11s -@ - -(You’ll need to run @import Sound.Tidal.Chords@ before using this function.) --} +-- | +-- Outputs all the available chords: +-- +-- @ +-- major maj M aug plus sharp5 six 6 sixNine six9 sixby9 6by9 major7 maj7 +-- major9 maj9 add9 major11 maj11 add11 major13 maj13 add13 dom7 dom9 dom11 +-- dom13 sevenFlat5 7f5 sevenSharp5 7s5 sevenFlat9 7f9 nine eleven 11 thirteen 13 +-- minor min m diminished dim minorSharp5 msharp5 mS5 minor6 min6 m6 minorSixNine +-- minor69 min69 minSixNine m69 mSixNine m6by9 minor7flat5 minor7f5 min7flat5 +-- min7f5 m7flat5 m7f5 minor7 min7 m7 minor7sharp5 minor7s5 min7sharp5 min7s5 +-- m7sharp5 m7s5 minor7flat9 minor7f9 min7flat9 min7f9 m7flat9 m7f9 minor7sharp9 +-- minor7s9 min7sharp9 min7s9 m7sharp9 m7s9 diminished7 dim7 minor9 min9 m9 +-- minor11 min11 m11 minor13 min13 m13 minorMajor7 minMaj7 mmaj7 one 1 five 5 +-- sus2 sus4 sevenSus2 7sus2 sevenSus4 7sus4 nineSus4 ninesus4 9sus4 sevenFlat10 +-- 7f10 nineSharp5 9sharp5 9s5 minor9sharp5 minor9s5 min9sharp5 min9s5 m9sharp5 +-- m9s5 sevenSharp5flat9 7s5f9 minor7sharp5flat9 m7sharp5flat9 elevenSharp 11s +-- minor11sharp m11sharp m11s +-- @ +-- +-- (You’ll need to run @import Sound.Tidal.Chords@ before using this function.) chordList :: String chordList = unwords $ map fst (chordTable :: [(String, [Int])]) -data Modifier = Range Int | Drop Int | Invert | Open deriving Eq +data Modifier = Range Int | Drop Int | Invert | Open deriving (Eq) instance Show Modifier where show (Range i) = "Range " ++ show i @@ -343,36 +386,37 @@ instance Show Modifier where show Open = "Open" applyModifier :: (Enum a, Num a) => Modifier -> [a] -> [a] -applyModifier (Range i) ds = take i $ concatMap (\x -> map (+ x) ds) [0,12..] +applyModifier (Range i) ds = take i $ concatMap (\x -> map (+ x) ds) [0, 12 ..] applyModifier Invert [] = [] -applyModifier Invert (d:ds) = ds ++ [d+12] +applyModifier Invert (d : ds) = ds ++ [d + 12] applyModifier Open ds = case length ds > 2 of - True -> [ (ds !! 0 - 12), (ds !! 2 - 12), (ds !! 1) ] ++ reverse (take (length ds - 3) (reverse ds)) - False -> ds + True -> [(ds !! 0 - 12), (ds !! 2 - 12), (ds !! 1)] ++ reverse (take (length ds - 3) (reverse ds)) + False -> ds applyModifier (Drop i) ds = case length ds < i of - True -> ds - False -> (ds!!s - 12):(xs ++ drop 1 ys) - where (xs,ys) = splitAt s ds - s = length ds - i + True -> ds + False -> (ds !! s - 12) : (xs ++ drop 1 ys) + where + (xs, ys) = splitAt s ds + s = length ds - i applyModifierPat :: (Num a, Enum a) => Pattern [a] -> Pattern [Modifier] -> Pattern [a] applyModifierPat pat modsP = do - ch <- pat - ms <- modsP - return $ foldl (flip applyModifier) ch ms + ch <- pat + ms <- modsP + return $ foldl (flip applyModifier) ch ms applyModifierPatSeq :: (Num a, Enum a) => (a -> b) -> Pattern [a] -> [Pattern [Modifier]] -> Pattern [b] applyModifierPatSeq f pat [] = fmap (map f) pat -applyModifierPatSeq f pat (mP:msP) = applyModifierPatSeq f (applyModifierPat pat mP) msP +applyModifierPatSeq f pat (mP : msP) = applyModifierPatSeq f (applyModifierPat pat mP) msP chordToPatSeq :: (Num a, Enum a) => (a -> b) -> Pattern a -> Pattern String -> [Pattern [Modifier]] -> Pattern b chordToPatSeq f noteP nameP modsP = uncollect $ do - n <- noteP - name <- nameP - let ch = map (+ n) (fromMaybe [0] $ lookup name chordTable) - applyModifierPatSeq f (return ch) modsP + n <- noteP + name <- nameP + let ch = map (+ n) (fromMaybe [0] $ lookup name chordTable) + applyModifierPatSeq f (return ch) modsP -- | Turns a given pattern of some 'Num' type, a pattern of chord names, and a -- list of patterns of modifiers into a chord pattern -chord :: (Num a, Enum a) => Pattern a -> Pattern String -> [Pattern [Modifier]] -> Pattern a +chord :: (Num a, Enum a) => Pattern a -> Pattern String -> [Pattern [Modifier]] -> Pattern a chord = chordToPatSeq id diff --git a/src/Sound/Tidal/Context.hs b/src/Sound/Tidal/Context.hs index 1c683c57..00f9f2fb 100644 --- a/src/Sound/Tidal/Context.hs +++ b/src/Sound/Tidal/Context.hs @@ -18,20 +18,18 @@ module Sound.Tidal.Context (module C) where along with this library. If not, see . -} -import Prelude hiding ((*>), (<*)) - -import Data.Ratio 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.Stepwise 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 +import Data.Ratio 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.Stepwise 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 +import Prelude hiding ((*>), (<*)) diff --git a/src/Sound/Tidal/Control.hs b/src/Sound/Tidal/Control.hs index 0e28794e..6521e0ae 100644 --- a/src/Sound/Tidal/Control.hs +++ b/src/Sound/Tidal/Control.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} module Sound.Tidal.Control where + {- Control.hs - Functions which concern control patterns, which are patterns of hashmaps, used for synth control values. @@ -24,139 +25,136 @@ module Sound.Tidal.Control where along with this library. If not, see . -} -import Prelude hiding ((*>), (<*)) - -import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust, fromMaybe, isJust) -import Data.Ratio - -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, -and panned by an additional @1/n@. The result is a pattern that seems to spin -around. This function work well on multichannel systems. - -> d1 $ slow 3 -> $ spin 4 -> $ sound "drum*3 tabla:4 [arpy:2 ~ arpy] [can:2 can:3]" --} +import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust, fromMaybe, isJust) +import Data.Ratio +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 +import Prelude hiding ((*>), (<*)) + +-- | `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, +-- and panned by an additional @1/n@. The result is a pattern that seems to spin +-- around. This function work well on multichannel systems. +-- +-- > d1 $ slow 3 +-- > $ spin 4 +-- > $ sound "drum*3 tabla:4 [arpy:2 ~ arpy] [can:2 can:3]" spin :: Pattern Int -> ControlPattern -> ControlPattern spin = patternify _spin _spin :: Int -> ControlPattern -> ControlPattern _spin copies p = - stack $ map (\i -> let offset = toInteger i % toInteger copies in - offset `rotL` p - # P.pan (pure $ fromRational offset) - ) - [0 .. (copies - 1)] - - - -{- | `chop` granularises every sample in place as it is played, turning a - pattern of samples into a pattern of sample parts. Can be used to explore - granular synthesis. - - Use an integer value to specify how many granules each sample is chopped into: - - > d1 $ chop 16 $ sound "arpy arp feel*4 arpy*4" - - Different values of @chop@ can yield very different results, depending on the - samples used: - - > d1 $ chop 16 $ sound (samples "arpy*8" (run 16)) - > d1 $ chop 32 $ sound (samples "arpy*8" (run 16)) - > d1 $ chop 256 $ sound "bd*4 [sn cp] [hh future]*2 [cp feel]" - - You can also use @chop@ (or 'striate') with very long samples to cut them into short - chunks and pattern those chunks. The following cuts a sample into 32 parts, and - plays it over 8 cycles: - - > d1 $ loopAt 8 $ chop 32 $ sound "bev" - - The 'loopAt' takes care of changing the speed of sample playback so that the - sample fits in the given number of cycles perfectly. As a result, in the above - the granules line up perfectly, so you can’t really hear that the sample has - been cut into bits. Again, this becomes more apparent when you do further - manipulations of the pattern, for example 'rev' to reverse the order of the cut - up bits: - - > d1 $ loopAt 8 $ rev $ chop 32 $ sound "bev" --} + stack $ + map + ( \i -> + let offset = toInteger i % toInteger copies + in offset `rotL` p + # P.pan (pure $ fromRational offset) + ) + [0 .. (copies - 1)] + +-- | `chop` granularises every sample in place as it is played, turning a +-- pattern of samples into a pattern of sample parts. Can be used to explore +-- granular synthesis. +-- +-- Use an integer value to specify how many granules each sample is chopped into: +-- +-- > d1 $ chop 16 $ sound "arpy arp feel*4 arpy*4" +-- +-- Different values of @chop@ can yield very different results, depending on the +-- samples used: +-- +-- > d1 $ chop 16 $ sound (samples "arpy*8" (run 16)) +-- > d1 $ chop 32 $ sound (samples "arpy*8" (run 16)) +-- > d1 $ chop 256 $ sound "bd*4 [sn cp] [hh future]*2 [cp feel]" +-- +-- You can also use @chop@ (or 'striate') with very long samples to cut them into short +-- chunks and pattern those chunks. The following cuts a sample into 32 parts, and +-- plays it over 8 cycles: +-- +-- > d1 $ loopAt 8 $ chop 32 $ sound "bev" +-- +-- The 'loopAt' takes care of changing the speed of sample playback so that the +-- sample fits in the given number of cycles perfectly. As a result, in the above +-- the granules line up perfectly, so you can’t really hear that the sample has +-- been cut into bits. Again, this becomes more apparent when you do further +-- manipulations of the pattern, for example 'rev' to reverse the order of the cut +-- up bits: +-- +-- > d1 $ loopAt 8 $ rev $ chop 32 $ sound "bev" chop :: Pattern Int -> ControlPattern -> ControlPattern 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] +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 pat = squeezeJoin $ f <$> pat - where f v = fastcat $ map (pure . rangemap v) slices - rangemap v (b, e) = Map.union (fromMaybe (makeMap (b,e)) $ merge v (b,e)) v - merge :: ValueMap -> (Double, Double) -> Maybe ValueMap - merge v (b, e) = do b' <- Map.lookup "begin" v >>= getF - e' <- Map.lookup "end" v >>= getF - let d = e' - b' - return $ makeMap (b' + b*d, b' + e*d) - makeMap (b,e) = Map.fromList [("begin", VF b), ("end", VF $ e)] - slices = map (\i -> (frac i, frac $ i + 1)) [0 .. n-1] - frac i = fromIntegral i / fromIntegral n - -{-| Striate is a kind of granulator, cutting samples into bits in a similar to -chop, but the resulting bits are organised differently. For example: - -> d1 $ striate 3 $ sound "ho ho:2 ho:3 hc" - -This plays the loop the given number of times, but triggers progressive portions -of each sample. So in this case it plays the loop three times, the first -time playing the first third of each sample, then the second time playing the -second third of each sample, and lastly playing the last third of each sample. -Replacing @striate@ with 'chop' above, one can hear that the ''chop' version -plays the bits from each chopped-up sample in turn, while @striate@ "interlaces" -the cut up bits of samples together. - -You can also use @striate@ with very long samples, to cut them into short -chunks and pattern those chunks. This is where things get towards granular -synthesis. The following cuts a sample into 128 parts, plays it over 8 cycles -and manipulates those parts by reversing and rotating the loops: - -> d1 $ slow 8 $ striate 128 $ sound "bev" --} - + where + f v = fastcat $ map (pure . rangemap v) slices + rangemap v (b, e) = Map.union (fromMaybe (makeMap (b, e)) $ merge v (b, e)) v + merge :: ValueMap -> (Double, Double) -> Maybe ValueMap + merge v (b, e) = do + b' <- Map.lookup "begin" v >>= getF + e' <- Map.lookup "end" v >>= getF + let d = e' - b' + return $ makeMap (b' + b * d, b' + e * d) + makeMap (b, e) = Map.fromList [("begin", VF b), ("end", VF $ e)] + slices = map (\i -> (frac i, frac $ i + 1)) [0 .. n - 1] + frac i = fromIntegral i / fromIntegral n + +-- | Striate is a kind of granulator, cutting samples into bits in a similar to +-- chop, but the resulting bits are organised differently. For example: +-- +-- > d1 $ striate 3 $ sound "ho ho:2 ho:3 hc" +-- +-- This plays the loop the given number of times, but triggers progressive portions +-- of each sample. So in this case it plays the loop three times, the first +-- time playing the first third of each sample, then the second time playing the +-- second third of each sample, and lastly playing the last third of each sample. +-- Replacing @striate@ with 'chop' above, one can hear that the ''chop' version +-- plays the bits from each chopped-up sample in turn, while @striate@ "interlaces" +-- the cut up bits of samples together. +-- +-- You can also use @striate@ with very long samples, to cut them into short +-- chunks and pattern those chunks. This is where things get towards granular +-- synthesis. The following cuts a sample into 128 parts, plays it over 8 cycles +-- and manipulates those parts by reversing and rotating the loops: +-- +-- > d1 $ slow 8 $ striate 128 $ sound "bev" striate :: Pattern Int -> ControlPattern -> ControlPattern striate = patternify _striate _striate :: Int -> ControlPattern -> ControlPattern -_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 +_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 -mergePlayRange (b,e) cm = Map.insert "begin" (VF ((b*d')+b')) $ Map.insert "end" (VF ((e*d')+b')) cm - where b' = fromMaybe 0 $ Map.lookup "begin" cm >>= getF - e' = fromMaybe 1 $ Map.lookup "end" cm >>= getF - d' = e' - b' - - -{-| -The @striateBy@ function is a variant of `striate` with an extra -parameter which specifies the length of each part. The @striateBy@ -function still scans across the sample over a single cycle, but if -each bit is longer, it creates a sort of stuttering effect. For -example the following will cut the @bev@ sample into 32 parts, but each -will be 1/16th of a sample long: - -> d1 $ slow 32 $ striateBy 32 (1/16) $ sound "bev" - -Note that `striate` and @striateBy@ use the `begin` and `end` parameters -internally. This means that you probably shouldn't also specify `begin` or -`end`. --} +mergePlayRange (b, e) cm = Map.insert "begin" (VF ((b * d') + b')) $ Map.insert "end" (VF ((e * d') + b')) cm + where + b' = fromMaybe 0 $ Map.lookup "begin" cm >>= getF + e' = fromMaybe 1 $ Map.lookup "end" cm >>= getF + d' = e' - b' + +-- | +-- The @striateBy@ function is a variant of `striate` with an extra +-- parameter which specifies the length of each part. The @striateBy@ +-- function still scans across the sample over a single cycle, but if +-- each bit is longer, it creates a sort of stuttering effect. For +-- example the following will cut the @bev@ sample into 32 parts, but each +-- will be 1/16th of a sample long: +-- +-- > d1 $ slow 32 $ striateBy 32 (1/16) $ sound "bev" +-- +-- Note that `striate` and @striateBy@ use the `begin` and `end` parameters +-- internally. This means that you probably shouldn't also specify `begin` or +-- `end`. striateBy :: Pattern Int -> Pattern Double -> ControlPattern -> ControlPattern striateBy = patternify2 _striateBy @@ -165,90 +163,86 @@ striate' :: Pattern Int -> Pattern Double -> ControlPattern -> ControlPattern striate' = striateBy _striateBy :: Int -> Double -> ControlPattern -> ControlPattern -_striateBy n f p = keepTactus (withTactus (* toRational n) p) $ fastcat $ map (offset . fromIntegral) [0 .. n-1] - where offset i = mergePlayRange (slot*i, (slot*i)+f) <$> p - slot = (1 - f) / fromIntegral (n-1) - - -{- | `gap` is similar to `chop` in that it granualizes every sample in place as it is played, -but every other grain is silent. Use an integer value to specify how many granules -each sample is chopped into: - -> d1 $ gap 8 $ sound "jvbass" -> d1 $ gap 16 $ sound "[jvbass drum:4]" --} +_striateBy n f p = keepTactus (withTactus (* toRational n) p) $ fastcat $ map (offset . fromIntegral) [0 .. n - 1] + where + offset i = mergePlayRange (slot * i, (slot * i) + f) <$> p + slot = (1 - f) / fromIntegral (n - 1) +-- | `gap` is similar to `chop` in that it granualizes every sample in place as it is played, +-- but every other grain is silent. Use an integer value to specify how many granules +-- each sample is chopped into: +-- +-- > d1 $ gap 8 $ sound "jvbass" +-- > d1 $ gap 16 $ sound "[jvbass drum:4]" gap :: Pattern Int -> ControlPattern -> ControlPattern gap = patternify _gap _gap :: Int -> ControlPattern -> ControlPattern _gap n p = _fast (toRational n) (cat [pure 1, silence]) |>| _chop n p -{- | - @weave@ applies one control pattern to a list of other control patterns, with - a successive time offset. It uses an `OscPattern` to apply the function at - different levels to each pattern, creating a weaving effect. For example: - - > d1 $ weave 16 (pan sine) - > [ sound "bd sn cp" - > , sound "casio casio:1" - > , sound "[jvbass*2 jvbass:2]/2" - > , sound "hc*4" - > ] - - In the above, the @pan sine@ control pattern is slowed down by the given - number of cycles, in particular 16, and applied to all of the given sound - patterns. What makes this interesting is that the @pan@ control pattern is - successively offset for each of the given sound patterns; because the @pan@ is - closed down by 16 cycles, and there are four patterns, they are ‘spread out’, - i.e. with a gap of four cycles. For this reason, the four patterns seem to - chase after each other around the stereo field. Try listening on headphones to - hear this more clearly. - - You can even have it the other way round, and have the effect parameters chasing - after each other around a sound parameter, like this: - - > d1 $ weave 16 (sound "arpy" >| n (run 8)) - > [ vowel "a e i" - > , vowel "i [i o] o u" - > , vowel "[e o]/3 [i o u]/2" - > , speed "1 2 3" - > ] --} +-- | +-- @weave@ applies one control pattern to a list of other control patterns, with +-- a successive time offset. It uses an `OscPattern` to apply the function at +-- different levels to each pattern, creating a weaving effect. For example: +-- +-- > d1 $ weave 16 (pan sine) +-- > [ sound "bd sn cp" +-- > , sound "casio casio:1" +-- > , sound "[jvbass*2 jvbass:2]/2" +-- > , sound "hc*4" +-- > ] +-- +-- In the above, the @pan sine@ control pattern is slowed down by the given +-- number of cycles, in particular 16, and applied to all of the given sound +-- patterns. What makes this interesting is that the @pan@ control pattern is +-- successively offset for each of the given sound patterns; because the @pan@ is +-- closed down by 16 cycles, and there are four patterns, they are ‘spread out’, +-- i.e. with a gap of four cycles. For this reason, the four patterns seem to +-- chase after each other around the stereo field. Try listening on headphones to +-- hear this more clearly. +-- +-- You can even have it the other way round, and have the effect parameters chasing +-- after each other around a sound parameter, like this: +-- +-- > d1 $ weave 16 (sound "arpy" >| n (run 8)) +-- > [ vowel "a e i" +-- > , vowel "i [i o] o u" +-- > , vowel "[e o]/3 [i o u]/2" +-- > , speed "1 2 3" +-- > ] weave :: Time -> ControlPattern -> [ControlPattern] -> ControlPattern weave t p ps = weave' t p (map (#) ps) - -{-| - @weaveWith@ is similar to the above, but weaves with a list of functions, rather - than a list of controls. For example: - - > d1 $ weaveWith 3 (sound "bd [sn drum:2*2] bd*2 [sn drum:1]") - > [ fast 2 - > , (# speed "0.5") - > , chop 16 - > ] --} +-- | +-- @weaveWith@ is similar to the above, but weaves with a list of functions, rather +-- than a list of controls. For example: +-- +-- > d1 $ weaveWith 3 (sound "bd [sn drum:2*2] bd*2 [sn drum:1]") +-- > [ fast 2 +-- > , (# speed "0.5") +-- > , chop 16 +-- > ] weaveWith :: Time -> Pattern a -> [Pattern a -> Pattern a] -> Pattern a -weaveWith t p fs | l == 0 = silence - | otherwise = _slow t $ stack $ zipWith (\ i f -> (fromIntegral i % l) `rotL` _fast t (f (_slow t p))) [0 :: Int ..] fs - where l = fromIntegral $ length fs +weaveWith t p fs + | l == 0 = silence + | otherwise = _slow t $ stack $ zipWith (\i f -> (fromIntegral i % l) `rotL` _fast t (f (_slow t p))) [0 :: Int ..] fs + where + l = fromIntegral $ length fs -- | An old alias for 'weaveWith'. weave' :: Time -> Pattern a -> [Pattern a -> Pattern a] -> Pattern a weave' = weaveWith -{- | -(A function that takes two ControlPatterns, and blends them together into -a new ControlPattern. An ControlPattern is basically a pattern of messages to -a synthesiser.) - -Shifts between the two given patterns, using distortion. - -Example: - -> d1 $ interlace (sound "bd sn kurt") (every 3 rev $ sound "bd sn:2") --} +-- | +-- (A function that takes two ControlPatterns, and blends them together into +-- a new ControlPattern. An ControlPattern is basically a pattern of messages to +-- a synthesiser.) +-- +-- Shifts between the two given patterns, using distortion. +-- +-- Example: +-- +-- > d1 $ interlace (sound "bd sn kurt") (every 3 rev $ sound "bd sn:2") interlace :: ControlPattern -> ControlPattern -> ControlPattern interlace a b = weave 16 (P.shape (sine * 0.9)) [a, b] @@ -270,27 +264,25 @@ _striateL :: Int -> Int -> ControlPattern -> ControlPattern _striateL n l p = _striate n p # loop (pure $ fromIntegral l) _striateL' n f l p = _striateBy n f p # loop (pure $ fromIntegral l) - en :: [(Int, Int)] -> Pattern String -> Pattern String en ns p = stack $ map (\(i, (k, n)) -> _e k n (samples p (pure i))) $ enumerate ns -} -{-| @slice@ is similar to 'chop' and 'striate', in that it’s used to slice - samples up into bits. The difference is that it allows you to rearrange those - bits as a pattern. - - > d1 $ slice 8 "7 6 5 4 3 2 1 0" - > $ sound "breaks165" - > # legato 1 - - The above slices the sample into eight bits, and then plays them backwards, - equivalent of applying rev $ chop 8. Here’s a more complex example: - - > d1 $ slice 8 "[<0*8 0*2> 3*4 2 4] [4 .. 7]" - > $ sound "breaks165" - > # legato 1 --} +-- | @slice@ is similar to 'chop' and 'striate', in that it’s used to slice +-- samples up into bits. The difference is that it allows you to rearrange those +-- bits as a pattern. +-- +-- > d1 $ slice 8 "7 6 5 4 3 2 1 0" +-- > $ sound "breaks165" +-- > # legato 1 +-- +-- The above slices the sample into eight bits, and then plays them backwards, +-- equivalent of applying rev $ chop 8. Here’s a more complex example: +-- +-- > d1 $ slice 8 "[<0*8 0*2> 3*4 2 4] [4 .. 7]" +-- > $ sound "breaks165" +-- > # legato 1 slice :: Pattern Int -> Pattern Int -> ControlPattern -> ControlPattern slice pN pI p = P.begin b # P.end e # p where @@ -300,172 +292,169 @@ slice pN pI p = P.begin b # P.end e # p div' :: Int -> Int -> Double div' num den = fromIntegral (num `mod` den) / fromIntegral den - _slice :: Int -> Int -> ControlPattern -> ControlPattern _slice n i p = - p - # P.begin (pure $ fromIntegral i / fromIntegral n) - # P.end (pure $ fromIntegral (i+1) / fromIntegral n) - -{-| - @randslice@ chops the sample into the given number of pieces and then plays back - a random one each cycle: + p + # P.begin (pure $ fromIntegral i / fromIntegral n) + # P.end (pure $ fromIntegral (i + 1) / fromIntegral n) - > d1 $ randslice 32 $ sound "bev" - - Use 'fast' to get more than one per cycle: - - > d1 $ fast 4 $ randslice 32 $ sound "bev" --} +-- | +-- @randslice@ chops the sample into the given number of pieces and then plays back +-- a random one each cycle: +-- +-- > d1 $ randslice 32 $ sound "bev" +-- +-- Use 'fast' to get more than one per cycle: +-- +-- > d1 $ fast 4 $ randslice 32 $ sound "bev" randslice :: Pattern Int -> ControlPattern -> ControlPattern 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") - where f ev = case Map.lookup "speed" (value ev) of - (Just (VF s)) -> ev {value = Map.insert "speed" (VF $ d*s) (value ev)} -- if there is a speed parameter already present - _ -> ev {value = Map.insert "speed" (VF d) (value ev)} - where d = sz / fromRational (wholeStop ev - wholeStart ev) - sz = 1/fromIntegral bits - -{-| - @splice@ is similar to 'slice', but the slices are automatically pitched up or down - to fit their ‘slot’. - - > d1 $ splice 8 "[<0*8 0*2> 3*4 2 4] [4 .. 7]" $ sound "breaks165" --} + where + f ev = case Map.lookup "speed" (value ev) of + (Just (VF s)) -> ev {value = Map.insert "speed" (VF $ d * s) (value ev)} -- if there is a speed parameter already present + _ -> ev {value = Map.insert "speed" (VF d) (value ev)} + where + d = sz / fromRational (wholeStop ev - wholeStart ev) + sz = 1 / fromIntegral bits + +-- | +-- @splice@ is similar to 'slice', but the slices are automatically pitched up or down +-- to fit their ‘slot’. +-- +-- > d1 $ splice 8 "[<0*8 0*2> 3*4 2 4] [4 .. 7]" $ sound "breaks165" splice :: Pattern Int -> Pattern Int -> ControlPattern -> Pattern (Map.Map String Value) splice bitpat ipat pat = setTactusFrom bitpat $ innerJoin $ (\bits -> _splice bits ipat pat) <$> bitpat -{-| - @loopAt@ makes a sample fit the given number of cycles. Internally, it - works by setting the `unit` parameter to @"c"@, changing the playback - speed of the sample with the `speed` parameter, and setting setting - the `density` of the pattern to match. - - > d1 $ loopAt 4 $ sound "breaks125" - - It’s a good idea to use this in conjuction with 'chop', so the break is chopped - into pieces and you don’t have to wait for the whole sample to start/stop. - - > d1 $ loopAt 4 $ chop 32 $ sound "breaks125" - - Like all Tidal functions, you can mess about with this considerably. The below - example shows how you can supply a pattern of cycle counts to @loopAt@: - - > d1 $ juxBy 0.6 (|* speed "2") - > $ slowspread (loopAt) [4,6,2,3] - > $ chop 12 - > $ sound "fm:14" --} +-- | +-- @loopAt@ makes a sample fit the given number of cycles. Internally, it +-- works by setting the `unit` parameter to @"c"@, changing the playback +-- speed of the sample with the `speed` parameter, and setting setting +-- the `density` of the pattern to match. +-- +-- > d1 $ loopAt 4 $ sound "breaks125" +-- +-- It’s a good idea to use this in conjuction with 'chop', so the break is chopped +-- into pieces and you don’t have to wait for the whole sample to start/stop. +-- +-- > d1 $ loopAt 4 $ chop 32 $ sound "breaks125" +-- +-- Like all Tidal functions, you can mess about with this considerably. The below +-- example shows how you can supply a pattern of cycle counts to @loopAt@: +-- +-- > d1 $ juxBy 0.6 (|* speed "2") +-- > $ slowspread (loopAt) [4,6,2,3] +-- > $ chop 12 +-- > $ sound "fm:14" loopAt :: Pattern Time -> ControlPattern -> ControlPattern -loopAt n p = slow n p |* P.speed (fromRational <$> (1/n)) # P.unit (pure "c") - -{-| - @hurry@ is similiar to 'fast' in that it speeds up a pattern, but it also - increases the speed control by the same factor. So, if you’re triggering - samples, the sound gets higher in pitch. For example: +loopAt n p = slow n p |* P.speed (fromRational <$> (1 / n)) # P.unit (pure "c") - > d1 $ every 2 (hurry 2) $ sound "bd sn:2 ~ cp" --} +-- | +-- @hurry@ is similiar to 'fast' in that it speeds up a pattern, but it also +-- increases the speed control by the same factor. So, if you’re triggering +-- samples, the sound gets higher in pitch. For example: +-- +-- > d1 $ every 2 (hurry 2) $ sound "bd sn:2 ~ cp" hurry :: Pattern Rational -> ControlPattern -> ControlPattern hurry !x = (|* P.speed (fromRational <$> x)) . fast x -{- | @smash@ is a combination of `spread` and `striate` — it cuts the samples -into the given number of bits, and then cuts between playing the loop -at different speeds according to the values in the list. So this: - -> d1 $ smash 3 [2,3,4] $ sound "ho ho:2 ho:3 hc" - -is a bit like this: - -> d1 $ spread (slow) [2,3,4] $ striate 3 $ sound "ho ho:2 ho:3 hc" - -This is quite dancehall: - -> d1 $ ( spread' slow "1%4 2 1 3" -> $ spread (striate) [2,3,4,1] -> $ sound "sn:2 sid:3 cp sid:4" -> ) -> # speed "[1 2 1 1]/2" --} - +-- | @smash@ is a combination of `spread` and `striate` — it cuts the samples +-- into the given number of bits, and then cuts between playing the loop +-- at different speeds according to the values in the list. So this: +-- +-- > d1 $ smash 3 [2,3,4] $ sound "ho ho:2 ho:3 hc" +-- +-- is a bit like this: +-- +-- > d1 $ spread (slow) [2,3,4] $ striate 3 $ sound "ho ho:2 ho:3 hc" +-- +-- This is quite dancehall: +-- +-- > d1 $ ( spread' slow "1%4 2 1 3" +-- > $ spread (striate) [2,3,4,1] +-- > $ sound "sn:2 sid:3 cp sid:4" +-- > ) +-- > # speed "[1 2 1 1]/2" smash :: Pattern Int -> [Pattern Time] -> ControlPattern -> Pattern ValueMap smash n xs p = slowcat $ map (`slow` p') xs - where p' = striate n p - -{- | An altenative form of `smash`, which uses `chop` instead of `striate`. - - Compare the following variations: + where + p' = striate n p - > d1 $ smash 6 [2,3,4] $ sound "ho ho:2 ho:3 hc" - > d1 $ smash' 6 [2,3,4] $ sound "ho ho:2 ho:3 hc" - > d1 $ smash 12 [2,3,4] $ s "bev*4" - > d1 $ smash' 12 [2,3,4] $ s "bev*4" --} +-- | An altenative form of `smash`, which uses `chop` instead of `striate`. +-- +-- Compare the following variations: +-- +-- > d1 $ smash 6 [2,3,4] $ sound "ho ho:2 ho:3 hc" +-- > d1 $ smash' 6 [2,3,4] $ sound "ho ho:2 ho:3 hc" +-- > d1 $ smash 12 [2,3,4] $ s "bev*4" +-- > d1 $ smash' 12 [2,3,4] $ s "bev*4" smash' :: Int -> [Pattern Time] -> ControlPattern -> ControlPattern smash' n xs p = slowcat $ map (`slow` p') xs - where p' = _chop n p - -{- | - Applies a type of delay to a pattern. - It has three parameters, which could be called @depth@, @time@ and @feedback@. - @depth@ is and integer, and @time@ and @feedback@ are floating point numbers. - - This adds a bit of echo: - - > d1 $ echo 4 0.2 0.5 $ sound "bd sn" - - The above results in 4 echos, each one 50% quieter than the last, with 1/5th of a cycle between them. - - It is possible to reverse the echo: + where + p' = _chop n p - > d1 $ echo 4 (-0.2) 0.5 $ sound "bd sn" --} +-- | +-- Applies a type of delay to a pattern. +-- It has three parameters, which could be called @depth@, @time@ and @feedback@. +-- @depth@ is and integer, and @time@ and @feedback@ are floating point numbers. +-- +-- This adds a bit of echo: +-- +-- > d1 $ echo 4 0.2 0.5 $ sound "bd sn" +-- +-- The above results in 4 echos, each one 50% quieter than the last, with 1/5th of a cycle between them. +-- +-- It is possible to reverse the echo: +-- +-- > d1 $ echo 4 (-0.2) 0.5 $ sound "bd sn" echo :: Pattern Integer -> Pattern Rational -> Pattern Double -> ControlPattern -> ControlPattern echo = patternify3' _echo _echo :: Integer -> Rational -> Double -> ControlPattern -> ControlPattern _echo count time feedback p = _echoWith count time (|* P.gain (pure $ feedback)) p -{- | - @echoWith@ is similar to 'echo', but instead of just decreasing volume to - produce echoes, @echoWith@ applies a function each step and overlays the - result delayed by the given time. - - > d1 $ echoWith 2 "1%3" (# vowel "{a e i o u}%2") $ sound "bd sn" - - In this case there are two _overlays_ delayed by 1/3 of a cycle, where each - has the 'vowel' filter applied. - - > d1 $ echoWith 4 (1/6) (|* speed "1.5") $ sound "arpy arpy:2" - - In the above, three versions are put on top, with each step getting higher in - pitch as @|* speed "1.5"@ is successively applied. --} +-- | +-- @echoWith@ is similar to 'echo', but instead of just decreasing volume to +-- produce echoes, @echoWith@ applies a function each step and overlays the +-- result delayed by the given time. +-- +-- > d1 $ echoWith 2 "1%3" (# vowel "{a e i o u}%2") $ sound "bd sn" +-- +-- In this case there are two _overlays_ delayed by 1/3 of a cycle, where each +-- has the 'vowel' filter applied. +-- +-- > d1 $ echoWith 4 (1/6) (|* speed "1.5") $ sound "arpy arpy:2" +-- +-- In the above, three versions are put on top, with each step getting higher in +-- pitch as @|* speed "1.5"@ is successively applied. echoWith :: Pattern Int -> Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a echoWith n t f p = innerJoin $ (\a b -> _echoWith a b f p) <$> n <* t _echoWith :: (Num n, Ord n) => n -> Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -_echoWith count time f p | count <= 1 = p - | otherwise = overlay (f (time `rotR` _echoWith (count-1) time f p)) p +_echoWith count time f p + | count <= 1 = p + | otherwise = overlay (f (time `rotR` _echoWith (count - 1) time f p)) p -- | DEPRECATED, use 'echo' instead stut :: Pattern Integer -> Pattern Double -> Pattern Rational -> ControlPattern -> ControlPattern 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)]) - where scalegain - = (+feedback) . (*(1-feedback)) . (/ fromIntegral count) . (fromIntegral count -) +_stut count feedback steptime p = stack (p : map (\x -> ((x % 1) * steptime) `rotR` (p |* P.gain (pure $ scalegain (fromIntegral x)))) [1 .. (count - 1)]) + where + scalegain = + (+ feedback) . (* (1 - feedback)) . (/ fromIntegral count) . (fromIntegral count -) -- | DEPRECATED, use 'echoWith' instead stutWith :: Pattern Int -> Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a stutWith n t f p = innerJoin $ (\a b -> _stutWith a b f p) <$> n <* t _stutWith :: (Num n, Ord n) => n -> Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -_stutWith count steptime f p | count <= 1 = p - | otherwise = overlay (f (steptime `rotR` _stutWith (count-1) steptime f p)) p +_stutWith count steptime f p + | count <= 1 = p + | otherwise = overlay (f (steptime `rotR` _stutWith (count - 1) steptime f p)) p -- | DEPRECATED, use 'echoWith' instead stut' :: Pattern Int -> Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a @@ -478,7 +467,7 @@ sec p = (realToFrac <$> cF 1 "_cps") *| p -- | Turns a pattern of milliseconds into a pattern of (rational) -- cycle durations, according to the current cps. msec :: Fractional a => Pattern a -> Pattern a -msec p = (realToFrac . (/1000) <$> cF 1 "_cps") *| p +msec p = (realToFrac . (/ 1000) <$> cF 1 "_cps") *| p -- | Align the start of a pattern with the time a pattern is evaluated, -- rather than the global start time. Because of this, the pattern will @@ -524,54 +513,56 @@ rtrigger = triggerWith $ (fromIntegral :: Int -> Rational) . round ftrigger :: Pattern a -> Pattern a ftrigger = triggerWith $ (fromIntegral :: Int -> Rational) . floor -{- | (Alias @__mt__@) Mod trigger. Aligns the start of a pattern to the - next cycle boundary where the cycle is evenly divisible by a given - number. 'qtrigger' is equivalent to @mtrigger 1@. - - In the following example, when activating the @d1@ pattern, it will start at the - same time as the next clap, even if it has to wait for 3 cycles. Once activated, - the @arpy@ sound will play on every cycle, just like any other pattern: - - > do - > resetCycles - > d2 $ every 4 (# s "clap") $ s "bd" - - > d1 $ mtrigger 4 $ filterWhen (>=0) $ s "arpy" --} +-- | (Alias @__mt__@) Mod trigger. Aligns the start of a pattern to the +-- next cycle boundary where the cycle is evenly divisible by a given +-- number. 'qtrigger' is equivalent to @mtrigger 1@. +-- +-- In the following example, when activating the @d1@ pattern, it will start at the +-- same time as the next clap, even if it has to wait for 3 cycles. Once activated, +-- the @arpy@ sound will play on every cycle, just like any other pattern: +-- +-- > do +-- > resetCycles +-- > d2 $ every 4 (# s "clap") $ s "bd" +-- +-- > d1 $ mtrigger 4 $ filterWhen (>=0) $ s "arpy" mtrigger :: Int -> Pattern a -> Pattern a mtrigger n = triggerWith $ fromIntegral . nextMod - where nextMod t = n * ceiling (t / (fromIntegral n)) + where + nextMod t = n * ceiling (t / (fromIntegral n)) -- | Alias for 'mtrigger'. mt :: Int -> Pattern a -> Pattern a mt = mtrigger -{- | This aligns the start of a pattern to some value relative to the - time the pattern is evaluated. The provided function maps the evaluation - time (on the global cycle clock) to a new time, and then @triggerWith@ - aligns the pattern's start to the time that's returned. - - This is a more flexible triggering function. In fact, all the other trigger - functions are defined based on @triggerWith@. For example, 'trigger' is just - @triggerWith id@. - - In the next example, use @d1@ as a metronome, and play with different values - (from 0 to 1) on the @const@ expression. You’ll notice how the @clap@ is - displaced from the beginning of each cycle to the end, as the number increases: - - > d1 $ s "bd hh!3" - > - > d2 $ triggerWith (const 0.1) $ s "clap" - - This last example is equivalent to this: - - > d2 $ rotR 0.1 $ s "clap" --} +-- | This aligns the start of a pattern to some value relative to the +-- time the pattern is evaluated. The provided function maps the evaluation +-- time (on the global cycle clock) to a new time, and then @triggerWith@ +-- aligns the pattern's start to the time that's returned. +-- +-- This is a more flexible triggering function. In fact, all the other trigger +-- functions are defined based on @triggerWith@. For example, 'trigger' is just +-- @triggerWith id@. +-- +-- In the next example, use @d1@ as a metronome, and play with different values +-- (from 0 to 1) on the @const@ expression. You’ll notice how the @clap@ is +-- displaced from the beginning of each cycle to the end, as the number increases: +-- +-- > d1 $ s "bd hh!3" +-- > +-- > d2 $ triggerWith (const 0.1) $ s "clap" +-- +-- This last example is equivalent to this: +-- +-- > d2 $ rotR 0.1 $ s "clap" triggerWith :: (Time -> Time) -> Pattern a -> Pattern a triggerWith f pat = pat {query = q} - where q st = query (rotR (offset st) pat) st - offset st = fromMaybe 0 $ f - <$> (Map.lookup patternTimeID (controls st) >>= getR) + where + q st = query (rotR (offset st) pat) st + offset st = + fromMaybe 0 $ + f + <$> (Map.lookup patternTimeID (controls st) >>= getR) splat :: Pattern Int -> ControlPattern -> ControlPattern -> ControlPattern splat slices epat pat = chop slices pat # bite 1 (const 0 <$> pat) epat diff --git a/src/Sound/Tidal/Core.hs b/src/Sound/Tidal/Core.hs index 7fbd10b0..6bbe234b 100644 --- a/src/Sound/Tidal/Core.hs +++ b/src/Sound/Tidal/Core.hs @@ -20,39 +20,40 @@ module Sound.Tidal.Core where -import Prelude hiding ((*>), (<*)) - -import Data.Fixed (mod') -import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe) -import Sound.Tidal.Pattern +import Data.Fixed (mod') +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Sound.Tidal.Pattern +import Prelude hiding ((*>), (<*)) -- ** Elemental patterns -{-| Takes a function of time to values, and turns it into a 'Pattern'. - Useful for creating continuous patterns such as 'sine' or 'perlin'. - - For example, 'saw' is defined as - - > saw = sig $ \t -> mod' (fromRational t) 1 --} +-- | Takes a function of time to values, and turns it into a 'Pattern'. +-- Useful for creating continuous patterns such as 'sine' or 'perlin'. +-- +-- For example, 'saw' is defined as +-- +-- > saw = sig $ \t -> mod' (fromRational t) 1 sig :: (Time -> a) -> Pattern a sig f = pattern q - where q (State (Arc s e) _) - | s > e = [] - | otherwise = [Event (Context []) Nothing (Arc s e) (f (s+((e-s)/2)))] + where + q (State (Arc s e) _) + | s > e = [] + | otherwise = [Event (Context []) Nothing (Arc s e) (f (s + ((e - s) / 2)))] -- | @sine@ - unipolar sinewave. A pattern of continuous values following a -- sinewave with frequency of one cycle, and amplitude from 0 to 1. sine :: Fractional a => Pattern a sine = sig $ \t -> (sin_rat ((pi :: Double) * 2 * fromRational t) + 1) / 2 - where sin_rat = fromRational . toRational . sin + where + sin_rat = fromRational . toRational . sin -- | @sine2@ - bipolar sinewave. A pattern of continuous values following a -- sinewave with frequency of one cycle, and amplitude from -1 to 1. sine2 :: Fractional a => Pattern a sine2 = sig $ \t -> sin_rat ((pi :: Double) * 2 * fromRational t) - where sin_rat = fromRational . toRational . sin + where + sin_rat = fromRational . toRational . sin -- | @cosine@ - unipolar cosine wave. A pattern of continuous values -- following a cosine with frequency of one cycle, and amplitude from @@ -80,11 +81,11 @@ saw2 = sig $ \t -> mod' (fromRational t) 1 * 2 - 1 -- | @isaw@ like @saw@, but a descending (inverse) sawtooth. isaw :: (Fractional a, Real a) => Pattern a -isaw = (1-) <$> saw +isaw = (1 -) <$> saw -- | @isaw2@ like @saw2@, but a descending (inverse) sawtooth. isaw2 :: (Fractional a, Real a) => Pattern a -isaw2 = (*(-1)) <$> saw2 +isaw2 = (* (-1)) <$> saw2 -- | @tri@ - unipolar triangle wave. A pattern of continuous values -- following a triangle wave with frequency of one cycle, and amplitude from @@ -104,14 +105,14 @@ tri2 = fastAppend saw2 isaw2 -- | @square@ is like 'sine', for square waves. square :: (Fractional a) => Pattern a square = sig $ - \t -> fromIntegral ((floor $ mod' (fromRational t :: Double) 1 * 2) :: Integer) + \t -> fromIntegral ((floor $ mod' (fromRational t :: Double) 1 * 2) :: Integer) -- | @square2@ - bipolar square wave. A pattern of continuous values -- following a square wave with frequency of one cycle, and amplitude from -- -1 to 1. square2 :: (Fractional a) => Pattern a square2 = sig $ - \t -> fromIntegral (floor (mod' (fromRational t :: Double) 1 * 2) * 2 - 1 :: Integer) + \t -> fromIntegral (floor (mod' (fromRational t :: Double) 1 * 2) * 2 - 1 :: Integer) -- | @envL@ is a 'Pattern' of continuous 'Double' values, representing -- a linear interpolation between 0 and 1 during the first cycle, then @@ -123,15 +124,15 @@ envL = sig $ \t -> max 0 $ min (fromRational t) 1 -- | like 'envL' but reversed. envLR :: Pattern Double -envLR = (1-) <$> envL +envLR = (1 -) <$> envL -- | 'Equal power' version of 'env', for gain-based transitions envEq :: Pattern Double -envEq = sig $ \t -> sqrt (sin (pi/2 * max 0 (min (fromRational (1-t)) 1))) +envEq = sig $ \t -> sqrt (sin (pi / 2 * max 0 (min (fromRational (1 - t)) 1))) -- | Equal power reversed envEqR :: Pattern Double -envEqR = sig $ \t -> sqrt (cos (pi/2 * max 0 (min (fromRational (1-t)) 1))) +envEqR = sig $ \t -> sqrt (cos (pi / 2 * max 0 (min (fromRational (1 - t)) 1))) -- ** Pattern algebra @@ -148,83 +149,109 @@ instance {-# OVERLAPPING #-} Unionable ValueMap where (|+|) :: (Applicative a, Num b) => a b -> a b -> a b a |+| b = (+) <$> a <*> b -(|+ ) :: Num a => Pattern a -> Pattern a -> Pattern a -a |+ b = (+) <$> a <* b -( +|) :: Num a => Pattern a -> Pattern a -> Pattern a -a +| b = (+) <$> a *> b + +(|+) :: Num a => Pattern a -> Pattern a -> Pattern a +a |+ b = (+) <$> a <* b + +(+|) :: Num a => Pattern a -> Pattern a -> Pattern a +a +| b = (+) <$> a *> b + (||+) :: Num a => Pattern a -> Pattern a -> Pattern a a ||+ b = (+) <$> a <<* b - (|++|) :: Applicative a => a String -> a String -> a String a |++| b = (++) <$> a <*> b -(|++ ) :: Pattern String -> Pattern String -> Pattern String -a |++ b = (++) <$> a <* b -( ++|) :: Pattern String -> Pattern String -> Pattern String -a ++| b = (++) <$> a *> b + +(|++) :: Pattern String -> Pattern String -> Pattern String +a |++ b = (++) <$> a <* b + +(++|) :: Pattern String -> Pattern String -> Pattern String +a ++| b = (++) <$> a *> b + (||++) :: Pattern String -> Pattern String -> Pattern String a ||++ b = (++) <$> a <<* b (|/|) :: (Applicative a, Fractional b) => a b -> a b -> a b a |/| b = (/) <$> a <*> b -(|/ ) :: Fractional a => Pattern a -> Pattern a -> Pattern a -a |/ b = (/) <$> a <* b -( /|) :: Fractional a => Pattern a -> Pattern a -> Pattern a -a /| b = (/) <$> a *> b + +(|/) :: Fractional a => Pattern a -> Pattern a -> Pattern a +a |/ b = (/) <$> a <* b + +(/|) :: Fractional a => Pattern a -> Pattern a -> Pattern a +a /| b = (/) <$> a *> b + (||/) :: Fractional a => Pattern a -> Pattern a -> Pattern a a ||/ b = (/) <$> a <<* b (|*|) :: (Applicative a, Num b) => a b -> a b -> a b a |*| b = (*) <$> a <*> b -(|* ) :: Num a => Pattern a -> Pattern a -> Pattern a -a |* b = (*) <$> a <* b -( *|) :: Num a => Pattern a -> Pattern a -> Pattern a -a *| b = (*) <$> a *> b + +(|*) :: Num a => Pattern a -> Pattern a -> Pattern a +a |* b = (*) <$> a <* b + +(*|) :: Num a => Pattern a -> Pattern a -> Pattern a +a *| b = (*) <$> a *> b + (||*) :: Num a => Pattern a -> Pattern a -> Pattern a a ||* b = (*) <$> a <<* b (|-|) :: (Applicative a, Num b) => a b -> a b -> a b a |-| b = (-) <$> a <*> b -(|- ) :: Num a => Pattern a -> Pattern a -> Pattern a -a |- b = (-) <$> a <* b -( -|) :: Num a => Pattern a -> Pattern a -> Pattern a -a -| b = (-) <$> a *> b + +(|-) :: Num a => Pattern a -> Pattern a -> Pattern a +a |- b = (-) <$> a <* b + +(-|) :: Num a => Pattern a -> Pattern a -> Pattern a +a -| b = (-) <$> a *> b + (||-) :: Num a => Pattern a -> Pattern a -> Pattern a a ||- b = (-) <$> a <<* b (|%|) :: (Applicative a, Moddable b) => a b -> a b -> a b a |%| b = gmod <$> a <*> b -(|% ) :: Moddable a => Pattern a -> Pattern a -> Pattern a -a |% b = gmod <$> a <* b -( %|) :: Moddable a => Pattern a -> Pattern a -> Pattern a -a %| b = gmod <$> a *> b + +(|%) :: Moddable a => Pattern a -> Pattern a -> Pattern a +a |% b = gmod <$> a <* b + +(%|) :: Moddable a => Pattern a -> Pattern a -> Pattern a +a %| b = gmod <$> a *> b + (||%) :: Moddable a => Pattern a -> Pattern a -> Pattern a a ||% b = gmod <$> a <<* b (|**|) :: (Applicative a, Floating b) => a b -> a b -> a b a |**| b = (**) <$> a <*> b -(|** ) :: Floating a => Pattern a -> Pattern a -> Pattern a -a |** b = (**) <$> a <* b -( **|) :: Floating a => Pattern a -> Pattern a -> Pattern a -a **| b = (**) <$> a *> b + +(|**) :: Floating a => Pattern a -> Pattern a -> Pattern a +a |** b = (**) <$> a <* b + +(**|) :: Floating a => Pattern a -> Pattern a -> Pattern a +a **| b = (**) <$> a *> b + (||**) :: Floating a => Pattern a -> Pattern a -> Pattern a a ||** b = (**) <$> a <<* b (|>|) :: (Applicative a, Unionable b) => a b -> a b -> a b a |>| b = flip union <$> a <*> b -(|> ) :: Unionable a => Pattern a -> Pattern a -> Pattern a -a |> b = flip union <$> a <* b -( >|) :: Unionable a => Pattern a -> Pattern a -> Pattern a -a >| b = flip union <$> a *> b + +(|>) :: Unionable a => Pattern a -> Pattern a -> Pattern a +a |> b = flip union <$> a <* b + +(>|) :: Unionable a => Pattern a -> Pattern a -> Pattern a +a >| b = flip union <$> a *> b + (||>) :: Unionable a => Pattern a -> Pattern a -> Pattern a a ||> b = flip union <$> a <<* b (|<|) :: (Applicative a, Unionable b) => a b -> a b -> a b a |<| b = union <$> a <*> b -(|< ) :: Unionable a => Pattern a -> Pattern a -> Pattern a -a |< b = union <$> a <* b -( <|) :: Unionable a => Pattern a -> Pattern a -> Pattern a -a <| b = union <$> a *> b + +(|<) :: Unionable a => Pattern a -> Pattern a -> Pattern a +a |< b = union <$> a <* b + +(<|) :: Unionable a => Pattern a -> Pattern a -> Pattern a +a <| b = union <$> a *> b + (||<) :: Unionable a => Pattern a -> Pattern a -> Pattern a a ||< b = union <$> a <<* b @@ -232,25 +259,21 @@ a ||< b = union <$> a <<* b (#) :: Unionable b => Pattern b -> Pattern b -> Pattern b (#) = (|>) - - -- ** Constructing patterns -{-| Turns a list of values into a pattern, playing one of them per cycle. - The following are equivalent: - - > d1 $ n (fromList [0, 1, 2]) # s "superpiano" - > d1 $ n "<0 1 2>" # s "superpiano" --} +-- | Turns a list of values into a pattern, playing one of them per cycle. +-- The following are equivalent: +-- +-- > d1 $ n (fromList [0, 1, 2]) # s "superpiano" +-- > d1 $ n "<0 1 2>" # s "superpiano" fromList :: [a] -> Pattern a fromList = cat . map pure -{-| Turns a list of values into a pattern, playing /all/ of them per cycle. - The following are equivalent: - - > d1 $ n (fastFromList [0, 1, 2]) # s "superpiano" - > d1 $ n "[0 1 2]" # s "superpiano" --} +-- | Turns a list of values into a pattern, playing /all/ of them per cycle. +-- The following are equivalent: +-- +-- > d1 $ n (fastFromList [0, 1, 2]) # s "superpiano" +-- > d1 $ n "[0 1 2]" # s "superpiano" fastFromList :: [a] -> Pattern a fastFromList = fastcat . map pure @@ -266,23 +289,23 @@ listToPat = fastFromList -- > d1 $ n "0 ~ 2" # s "superpiano" fromMaybes :: [Maybe a] -> Pattern a fromMaybes = fastcat . map f - where f Nothing = silence - f (Just x) = pure x - -{-| A pattern of whole numbers from 0 to the given number, in a single cycle. - Can be used used to @run@ through a folder of samples in order: - - > d1 $ n (run 8) # sound "amencutup" - - The first parameter to run can be given as a pattern: - - > d1 $ n (run "<4 8 4 6>") # sound "amencutup" --} + where + f Nothing = silence + f (Just x) = pure x + +-- | A pattern of whole numbers from 0 to the given number, in a single cycle. +-- Can be used used to @run@ through a folder of samples in order: +-- +-- > d1 $ n (run 8) # sound "amencutup" +-- +-- The first parameter to run can be given as a pattern: +-- +-- > d1 $ n (run "<4 8 4 6>") # sound "amencutup" run :: (Enum a, Num a) => Pattern a -> Pattern a run = (>>= _run) _run :: (Enum a, Num a) => a -> Pattern a -_run n = fastFromList [0 .. n-1] +_run n = fastFromList [0 .. n - 1] -- | Similar to 'run', but starts from @1@ for the first cycle, successively -- adds a number until it gets up to @n@. @@ -298,39 +321,42 @@ _scan n = slowcat $ map _run [1 .. n] -- | Alternate between cycles of the two given patterns -- > d1 $ append (sound "bd*2 sn") (sound "arpy jvbass*2") append :: Pattern a -> Pattern a -> Pattern a -append a b = cat [a,b] - -{- | - Like 'append', but for a list of patterns. Interlaces them, playing the - first cycle from each in turn, then the second cycle from each, and so on. It - concatenates a list of patterns into a new pattern; each pattern in the list - will maintain its original duration. For example: - - > d1 $ cat [sound "bd*2 sn", sound "arpy jvbass*2"] - > d1 $ cat [sound "bd*2 sn", sound "arpy jvbass*2", sound "drum*2"] - > d1 $ cat [sound "bd*2 sn", sound "jvbass*3", sound "drum*2", sound "ht mt"] --} +append a b = cat [a, b] + +-- | +-- Like 'append', but for a list of patterns. Interlaces them, playing the +-- first cycle from each in turn, then the second cycle from each, and so on. It +-- concatenates a list of patterns into a new pattern; each pattern in the list +-- will maintain its original duration. For example: +-- +-- > d1 $ cat [sound "bd*2 sn", sound "arpy jvbass*2"] +-- > d1 $ cat [sound "bd*2 sn", sound "arpy jvbass*2", sound "drum*2"] +-- > d1 $ cat [sound "bd*2 sn", sound "jvbass*3", sound "drum*2", sound "ht mt"] cat :: [Pattern a] -> Pattern a cat [] = silence -cat (p:[]) = p +cat (p : []) = p 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))} - where p = ps !! i - cyc = (floor $ start a) :: Int - i = cyc `mod` n - offset = (fromIntegral $ cyc - ((cyc - i) `div` n)) :: Time + 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))} + where + p = ps !! i + cyc = (floor $ start a) :: Int + i = cyc `mod` n + offset = (fromIntegral $ cyc - ((cyc - i) `div` n)) :: Time -- | Alias for 'cat' slowCat :: [Pattern a] -> Pattern a slowCat = cat + slowcat :: [Pattern a] -> Pattern a slowcat = slowCat -- | Alias for 'append' slowAppend :: Pattern a -> Pattern a -> Pattern a slowAppend = append + slowappend :: Pattern a -> Pattern a -> Pattern a slowappend = append @@ -338,93 +364,93 @@ slowappend = append -- > d1 $ fastAppend (sound "bd*2 sn") (sound "arpy jvbass*2") fastAppend :: Pattern a -> Pattern a -> Pattern a fastAppend a b = _fast 2 $ append a b + fastappend :: Pattern a -> Pattern a -> Pattern a fastappend = fastAppend -{-| The same as 'cat', but speeds up the result by the number of - patterns there are, so the cycles from each are squashed to fit a - single cycle. - - > d1 $ fastcat [sound "bd*2 sn", sound "arpy jvbass*2"] - > d1 $ fastcat [sound "bd*2 sn", sound "arpy jvbass*2", sound "drum*2"] - > d1 $ fastcat [sound "bd*2 sn", sound "jvbass*3", sound "drum*2", sound "ht mt"] --} +-- | The same as 'cat', but speeds up the result by the number of +-- patterns there are, so the cycles from each are squashed to fit a +-- single cycle. +-- +-- > d1 $ fastcat [sound "bd*2 sn", sound "arpy jvbass*2"] +-- > d1 $ fastcat [sound "bd*2 sn", sound "arpy jvbass*2", sound "drum*2"] +-- > d1 $ fastcat [sound "bd*2 sn", sound "jvbass*3", sound "drum*2", sound "ht mt"] fastCat :: [Pattern a] -> Pattern a -fastCat (p:[]) = p -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) +fastCat (p : []) = p +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 fastcat = fastCat -{- | Similar to @fastCat@, but each pattern is given a relative duration. - You provide proportionate sizes of the patterns to each other for when they’re - concatenated into one cycle. The larger the value in the list, the larger - relative size the pattern takes in the final loop. If all values are equal - then this is equivalent to fastcat (e.g. the following two code fragments are - equivalent). - - > d1 $ fastcat [s "bd*4", s "hh27*8", s "superpiano" # n 0] - - > d1 $ timeCat [ (1, s "bd*4") - > , (1, s "hh27*8") - > , (1, s "superpiano" # n 0) - > ] - --} +-- | Similar to @fastCat@, but each pattern is given a relative duration. +-- You provide proportionate sizes of the patterns to each other for when they’re +-- concatenated into one cycle. The larger the value in the list, the larger +-- relative size the pattern takes in the final loop. If all values are equal +-- then this is equivalent to fastcat (e.g. the following two code fragments are +-- equivalent). +-- +-- > d1 $ fastcat [s "bd*4", s "hh27*8", s "superpiano" # n 0] +-- +-- > d1 $ timeCat [ (1, s "bd*4") +-- > , (1, s "hh27*8") +-- > , (1, s "superpiano" # n 0) +-- > ] 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 $ filter (\(t, _) -> t > 0) $ tps - where total = sum $ map fst tps - arrange :: Time -> [(Time, Pattern a)] -> [(Time, Time, Pattern a)] - arrange _ [] = [] - arrange t ((t',p):tps') = (t,t+t',p) : arrange (t+t') tps' +timeCat ((_, p) : []) = p +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 _ [] = [] + arrange t ((t', p) : tps') = (t, t + t', p) : arrange (t + t') tps' -- | Alias for @timeCat@ timecat :: [(Time, Pattern a)] -> Pattern a timecat = timeCat -{- | @overlay@ combines two 'Pattern's into a new pattern, so that their events -are combined over time. For example, the following two lines are equivalent: - -> d1 $ sound (overlay "bd sn:2" "cp*3") -> d1 $ sound "[bd sn:2, cp*3]" - -@overlay@ is equal to '<>', - -> (<>) :: Semigroup a => a -> a -> a - -which can thus be used as an infix operator equivalent of 'overlay': - -> d1 $ sound ("bd sn:2" <> "cp*3") --} +-- | @overlay@ combines two 'Pattern's into a new pattern, so that their events +-- are combined over time. For example, the following two lines are equivalent: +-- +-- > d1 $ sound (overlay "bd sn:2" "cp*3") +-- > d1 $ sound "[bd sn:2, cp*3]" +-- +-- @overlay@ is equal to '<>', +-- +-- > (<>) :: Semigroup a => a -> a -> a +-- +-- which can thus be used as an infix operator equivalent of 'overlay': +-- +-- > d1 $ sound ("bd sn:2" <> "cp*3") overlay :: Pattern a -> Pattern a -> Pattern a overlay = (<>) -{- | 'stack' combines a list of 'Pattern's into a new pattern, so that their -events are combined over time, i.e., all of the patterns in the list are played -simultaneously. - -> d1 $ stack [ -> sound "bd bd*2", -> sound "hh*2 [sn cp] cp future*4", -> sound "arpy" +| n "0 .. 15" -> ] - -This is particularly useful if you want to apply a function or synth control -pattern to multiple patterns at once: - -> d1 $ whenmod 5 3 (striate 3) $ stack [ -> sound "bd bd*2", -> sound "hh*2 [sn cp] cp future*4", -> sound "arpy" +| n "0 .. 15" -> ] # speed "[[1 0.8], [1.5 2]*2]/3" --} +-- | 'stack' combines a list of 'Pattern's into a new pattern, so that their +-- events are combined over time, i.e., all of the patterns in the list are played +-- simultaneously. +-- +-- > d1 $ stack [ +-- > sound "bd bd*2", +-- > sound "hh*2 [sn cp] cp future*4", +-- > sound "arpy" +| n "0 .. 15" +-- > ] +-- +-- This is particularly useful if you want to apply a function or synth control +-- pattern to multiple patterns at once: +-- +-- > d1 $ whenmod 5 3 (striate 3) $ stack [ +-- > sound "bd bd*2", +-- > sound "hh*2 [sn cp] cp future*4", +-- > sound "arpy" +| n "0 .. 15" +-- > ] # speed "[[1 0.8], [1.5 2]*2]/3" stack :: [Pattern a] -> Pattern a stack pats = (foldr overlay silence pats) {tactus = t} - where t | length pats == 0 = Nothing - | otherwise = foldl1 lcmr <$> (sequence $ map tactus pats) + where + t + | length pats == 0 = Nothing + | otherwise = foldl1 lcmr <$> (sequence $ map tactus pats) -- ** Manipulating time @@ -436,28 +462,27 @@ stack pats = (foldr overlay silence pats) {tactus = t} (~>) :: Pattern Time -> Pattern a -> Pattern a (~>) = 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 - to 'fastSqueeze'. - - If the time pattern only has a single value in a cycle, @slowSqueeze@ becomes equivalent to slow. These are equivalent: - - > d1 $ slow "<2 4>" $ s "bd*8" - > d1 $ slowSqueeze "<2 4>" $ s "bd*8" - - When the time pattern has multiple values, however, the behavior is a little - different. Instead, a slowed version of the pattern will be made for each value - in the time pattern, and they’re all combined together in a cycle according to - the structure of the time pattern. For example, these are equivalent: - - > d1 $ slowSqueeze "2 4 8 16" $ s "bd*8" - > d1 $ s "bd*4 bd*2 bd bd/2" - - as are these: - - > d1 $ slowSqueeze "2 4 [8 16]" $ s "bd*8" - > d1 $ s "bd*4 bd*2 [bd bd/2]" --} +-- | 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 +-- to 'fastSqueeze'. +-- +-- If the time pattern only has a single value in a cycle, @slowSqueeze@ becomes equivalent to slow. These are equivalent: +-- +-- > d1 $ slow "<2 4>" $ s "bd*8" +-- > d1 $ slowSqueeze "<2 4>" $ s "bd*8" +-- +-- When the time pattern has multiple values, however, the behavior is a little +-- different. Instead, a slowed version of the pattern will be made for each value +-- in the time pattern, and they’re all combined together in a cycle according to +-- the structure of the time pattern. For example, these are equivalent: +-- +-- > d1 $ slowSqueeze "2 4 8 16" $ s "bd*8" +-- > d1 $ s "bd*4 bd*2 bd bd/2" +-- +-- as are these: +-- +-- > d1 $ slowSqueeze "2 4 [8 16]" $ s "bd*8" +-- > d1 $ s "bd*4 bd*2 [bd bd/2]" slowSqueeze :: Pattern Time -> Pattern a -> Pattern a slowSqueeze = patternifySqueeze _slow @@ -465,35 +490,37 @@ slowSqueeze = patternifySqueeze _slow sparsity :: Pattern Time -> Pattern a -> Pattern a sparsity = slow -{- | Plays a portion of a pattern, specified by a time arc (start and end time). - The new resulting pattern is played over the time period of the original pattern. - - > d1 $ zoom (0.25, 0.75) $ sound "bd*2 hh*3 [sn bd]*2 drum" - - In the pattern above, @zoom@ is used with an arc from 25% to 75%. It is - equivalent to: - - > d1 $ sound "hh*3 [sn bd]*2" - - Here’s an example of it being used with a conditional: - - > d1 $ every 4 (zoom (0.25, 0.75)) $ sound "bd*2 hh*3 [sn bd]*2 drum" --} +-- | Plays a portion of a pattern, specified by a time arc (start and end time). +-- The new resulting pattern is played over the time period of the original pattern. +-- +-- > d1 $ zoom (0.25, 0.75) $ sound "bd*2 hh*3 [sn bd]*2 drum" +-- +-- In the pattern above, @zoom@ is used with an arc from 25% to 75%. It is +-- equivalent to: +-- +-- > d1 $ sound "hh*3 [sn bd]*2" +-- +-- Here’s an example of it being used with a conditional: +-- +-- > d1 $ every 4 (zoom (0.25, 0.75)) $ sound "bd*2 hh*3 [sn bd]*2 drum" zoom :: (Time, Time) -> Pattern a -> Pattern a -zoom (s,e) = zoomArc (Arc s e) +zoom (s, e) = zoomArc (Arc s e) zoomArc :: Arc -> Pattern a -> Pattern a -zoomArc (Arc s e) p | s >= e = nothing - | otherwise = withTactus (*d) $ splitQueries $ - withResultArc (mapCycle ((/d) . subtract s)) $ withQueryArc (mapCycle ((+s) . (*d))) p - where d = e-s - -{-| @fastGap@ is similar to 'fast' but maintains its cyclic alignment, i.e., - rather than playing the pattern multiple times, it instead leaves a gap in - the remaining space of the cycle. For example, @fastGap 2 p@ would squash the - events in pattern @p@ into the first half of each cycle (and the second halves - would be empty). The factor should be at least 1. --} +zoomArc (Arc s e) p + | s >= e = nothing + | otherwise = + withTactus (* d) $ + splitQueries $ + withResultArc (mapCycle ((/ d) . subtract s)) $ withQueryArc (mapCycle ((+ s) . (* d))) p + where + d = e - s + +-- | @fastGap@ is similar to 'fast' but maintains its cyclic alignment, i.e., +-- rather than playing the pattern multiple times, it instead leaves a gap in +-- the remaining space of the cycle. For example, @fastGap 2 p@ would squash the +-- events in pattern @p@ into the first half of each cycle (and the second halves +-- would be empty). The factor should be at least 1. fastGap :: Pattern Time -> Pattern a -> Pattern a fastGap = patternify _fastGap @@ -501,29 +528,28 @@ fastGap = patternify _fastGap densityGap :: Pattern Time -> Pattern a -> Pattern a densityGap = fastGap -{-| - @compress@ takes a pattern and squeezes it within the specified time span (i.e. - the ‘arc’). The new resulting pattern is a sped up version of the original. - - > d1 $ compress (1/4, 3/4) $ s "[bd sn]!" - - In the above example, the pattern will play in an arc spanning from 25% to 75% - of the duration of a cycle. It is equivalent to: - - > d1 $ s "~ [bd sn]! ~" - - Another example, where all events are different: - - > d1 $ compress (1/4, 3/4) $ n (run 4) # s "arpy" - - It differs from 'zoom' in that it preserves the original pattern but it speeds - up its events so to match with the new time period. --} -compress :: (Time,Time) -> Pattern a -> Pattern a -compress (s,e) = compressArc (Arc s e) - -compressTo :: (Time,Time) -> Pattern a -> Pattern a -compressTo (s,e) = compressArcTo (Arc s e) +-- | +-- @compress@ takes a pattern and squeezes it within the specified time span (i.e. +-- the ‘arc’). The new resulting pattern is a sped up version of the original. +-- +-- > d1 $ compress (1/4, 3/4) $ s "[bd sn]!" +-- +-- In the above example, the pattern will play in an arc spanning from 25% to 75% +-- of the duration of a cycle. It is equivalent to: +-- +-- > d1 $ s "~ [bd sn]! ~" +-- +-- Another example, where all events are different: +-- +-- > d1 $ compress (1/4, 3/4) $ n (run 4) # s "arpy" +-- +-- It differs from 'zoom' in that it preserves the original pattern but it speeds +-- up its events so to match with the new time period. +compress :: (Time, Time) -> Pattern a -> Pattern a +compress (s, e) = compressArc (Arc s e) + +compressTo :: (Time, Time) -> Pattern a -> Pattern a +compressTo (s, e) = compressArcTo (Arc s e) repeatCycles :: Pattern Int -> Pattern a -> Pattern a repeatCycles = patternify _repeatCycles @@ -538,24 +564,23 @@ fastRepeatCycles n p = cat (replicate n p) -- | Functions which work on other functions (higher order functions) -{- | @every n f p@ applies the function @f@ to @p@, but only affects - every @n@ cycles. - - It takes three inputs: how often the function should be applied (e.g. 3 to - apply it every 3 cycles), the function to be applied, and the pattern you are - applying it to. For example: to reverse a pattern every three cycles (and for - the other two play it normally) - - > d1 $ every 3 rev $ n "0 1 [~ 2] 3" # sound "arpy" - - Note that if the function you’re applying requires additional parameters - itself (such as fast 2 to make a pattern twice as fast), then you’ll need to - wrap it in parenthesis, like so: - - > d1 $ every 3 (fast 2) $ n "0 1 [~ 2] 3" # sound "arpy" - - Otherwise, the every function will think it is being passed too many parameters. --} +-- | @every n f p@ applies the function @f@ to @p@, but only affects +-- every @n@ cycles. +-- +-- It takes three inputs: how often the function should be applied (e.g. 3 to +-- apply it every 3 cycles), the function to be applied, and the pattern you are +-- applying it to. For example: to reverse a pattern every three cycles (and for +-- the other two play it normally) +-- +-- > d1 $ every 3 rev $ n "0 1 [~ 2] 3" # sound "arpy" +-- +-- Note that if the function you’re applying requires additional parameters +-- itself (such as fast 2 to make a pattern twice as fast), then you’ll need to +-- wrap it in parenthesis, like so: +-- +-- > d1 $ every 3 (fast 2) $ n "0 1 [~ 2] 3" # sound "arpy" +-- +-- Otherwise, the every function will think it is being passed too many parameters. every :: Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a every tp f p = innerJoin $ (\t -> _every t f p) <$> tp @@ -563,76 +588,76 @@ _every :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a _every 0 _ p = p _every n f p = when ((== 0) . (`mod` n)) f p -{-| @every' n o f p@ is like @every n f p@ but with an offset of @o@ cycles. - - For example, @every' 3 0 (fast 2)@ will speed up the cycle on cycles 0,3,6,… - whereas @every' 3 1 (fast 2)@ will transform the pattern on cycles 1,4,7,…. - - With this in mind, setting the second argument of @every'@ to 0 gives the - equivalent every function. For example, every 3 is equivalent to every' 3 0. - - The @every@ functions can be used to silence a full cycle or part of a cycle - by using silent or mask "~". Mask provides additional flexibility to turn on/off - individual steps. - - > d1 $ every 3 silent $ n "2 9 11 2" # s "hh27" - > d1 $ every 3 (mask "~") $ n "2 9 10 2" # s "hh27" - > d1 $ every 3 (mask "0 0 0 0") $ n "2 9 11 2" # s "hh27" --} +-- | @every' n o f p@ is like @every n f p@ but with an offset of @o@ cycles. +-- +-- For example, @every' 3 0 (fast 2)@ will speed up the cycle on cycles 0,3,6,… +-- whereas @every' 3 1 (fast 2)@ will transform the pattern on cycles 1,4,7,…. +-- +-- With this in mind, setting the second argument of @every'@ to 0 gives the +-- equivalent every function. For example, every 3 is equivalent to every' 3 0. +-- +-- The @every@ functions can be used to silence a full cycle or part of a cycle +-- by using silent or mask "~". Mask provides additional flexibility to turn on/off +-- individual steps. +-- +-- > d1 $ every 3 silent $ n "2 9 11 2" # s "hh27" +-- > d1 $ every 3 (mask "~") $ n "2 9 10 2" # s "hh27" +-- > d1 $ every 3 (mask "0 0 0 0") $ n "2 9 11 2" # s "hh27" every' :: Pattern Int -> Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -every' np op f p = do { n <- np; o <- op; _every' n o f p } +every' np op f p = do n <- np; o <- op; _every' n o f p _every' :: Int -> Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a _every' n o = when ((== o) . (`mod` n)) -{- | @foldEvery ns f p@ applies the function @f@ to @p@, and is applied for - each cycle in @ns@. - - It is similar to chaining multiple @every@ functions together. It transforms - a pattern with a function, once per any of the given number of cycles. If a - particular cycle is the start of more than one of the given cycle periods, then - it it applied more than once. - - > d1 $ foldEvery [5,3] (|+ n 1) $ s "moog" # legato 1 - - The first moog samples are tuned to C2, C3 and C4. Note how on cycles that are - multiples of 3 or 5 the pitch is an octave higher, and on multiples of 15 the - pitch is two octaves higher, as the transformation is applied twice. --} +-- | @foldEvery ns f p@ applies the function @f@ to @p@, and is applied for +-- each cycle in @ns@. +-- +-- It is similar to chaining multiple @every@ functions together. It transforms +-- a pattern with a function, once per any of the given number of cycles. If a +-- particular cycle is the start of more than one of the given cycle periods, then +-- it it applied more than once. +-- +-- > d1 $ foldEvery [5,3] (|+ n 1) $ s "moog" # legato 1 +-- +-- The first moog samples are tuned to C2, C3 and C4. Note how on cycles that are +-- multiples of 3 or 5 the pitch is an octave higher, and on multiples of 15 the +-- pitch is two octaves higher, as the transformation is applied twice. foldEvery :: [Int] -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a foldEvery ns f p = foldr (`_every` f) p ns -{-| -The given pattern transformation is applied only @when@ the given test function -returns @True@. The test function will be called with the current cycle as -a number. - -> d1 $ when (elem '4' . show) -> (striate 4) -> $ sound "hh hc" - -The above will only apply @striate 4@ to the pattern if the current -cycle number contains the number 4. So the fourth cycle will be -striated and the fourteenth and so on. Expect lots of striates after -cycle number 399. --} -when :: (Int -> Bool) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +-- | +-- The given pattern transformation is applied only @when@ the given test function +-- returns @True@. The test function will be called with the current cycle as +-- a number. +-- +-- > d1 $ when (elem '4' . show) +-- > (striate 4) +-- > $ sound "hh hc" +-- +-- The above will only apply @striate 4@ to the pattern if the current +-- cycle number contains the number 4. So the fourth cycle will be +-- striated and the fourteenth and so on. Expect lots of striates after +-- cycle number 399. +when :: (Int -> Bool) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a when test f p = splitQueries $ p {query = apply} - where apply st | test (floor $ start $ arc st) = query (f p) st - | otherwise = query p st - -{- | Like 'when', but works on continuous time values rather than cycle numbers. - The following will apply @# speed 2@ only when the remainder of the current - @Time@ divided by 2 is less than 0.5: - - > d1 $ whenT ((< 0.5) . (flip Data.Fixed.mod' 2)) - > (# speed 2) - > $ sound "hh(4,8) hc(3,8)" --} -whenT :: (Time -> Bool) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a + where + apply st + | test (floor $ start $ arc st) = query (f p) st + | otherwise = query p st + +-- | Like 'when', but works on continuous time values rather than cycle numbers. +-- The following will apply @# speed 2@ only when the remainder of the current +-- @Time@ divided by 2 is less than 0.5: +-- +-- > d1 $ whenT ((< 0.5) . (flip Data.Fixed.mod' 2)) +-- > (# speed 2) +-- > $ sound "hh(4,8) hc(3,8)" +whenT :: (Time -> Bool) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a whenT test f p = splitQueries $ p {query = apply} - where apply st | test (start $ arc st) = query (f p) st - | otherwise = query p st + where + apply st + | test (start $ arc st) = query (f p) st + | otherwise = query p st _getP_ :: (Value -> Maybe a) -> Pattern Value -> Pattern a _getP_ f pat = filterJust $ f <$> pat @@ -648,307 +673,448 @@ _cX_ f s = pattern $ \(State a m) -> queryArc (maybe silence (_getP_ f . valueTo cF :: Double -> String -> Pattern Double cF d = _cX d getF + cF_ :: String -> Pattern Double cF_ = _cX_ getF + cF0 :: String -> Pattern Double cF0 = _cX 0 getF cN :: Note -> String -> Pattern Note cN d = _cX d getN + cN_ :: String -> Pattern Note cN_ = _cX_ getN + cN0 :: String -> Pattern Note cN0 = _cX (Note 0) getN cI :: Int -> String -> Pattern Int cI d = _cX d getI + cI_ :: String -> Pattern Int cI_ = _cX_ getI + cI0 :: String -> Pattern Int cI0 = _cX 0 getI cB :: Bool -> String -> Pattern Bool cB d = _cX d getB + cB_ :: String -> Pattern Bool cB_ = _cX_ getB + cB0 :: String -> Pattern Bool cB0 = _cX False getB cR :: Rational -> String -> Pattern Rational cR d = _cX d getR + cR_ :: String -> Pattern Rational cR_ = _cX_ getR + cR0 :: String -> Pattern Rational cR0 = _cX 0 getR cT :: Time -> String -> Pattern Time cT = cR + cT0 :: String -> Pattern Time cT0 = cR0 + cT_ :: String -> Pattern Time cT_ = cR_ cS :: String -> String -> Pattern String cS d = _cX d getS + cS_ :: String -> Pattern String cS_ = _cX_ getS + cS0 :: String -> Pattern String cS0 = _cX "" getS -- Default controller inputs (for MIDI) in0 :: Pattern Double in0 = cF 0 "0" + in1 :: Pattern Double in1 = cF 0 "1" + in2 :: Pattern Double in2 = cF 0 "2" + in3 :: Pattern Double in3 = cF 0 "3" + in4 :: Pattern Double in4 = cF 0 "4" + in5 :: Pattern Double in5 = cF 0 "5" + in6 :: Pattern Double in6 = cF 0 "6" + in7 :: Pattern Double in7 = cF 0 "7" + in8 :: Pattern Double in8 = cF 0 "8" + in9 :: Pattern Double in9 = cF 0 "9" + in10 :: Pattern Double in10 = cF 0 "10" + in11 :: Pattern Double in11 = cF 0 "11" + in12 :: Pattern Double in12 = cF 0 "12" + in13 :: Pattern Double in13 = cF 0 "13" + in14 :: Pattern Double in14 = cF 0 "14" + in15 :: Pattern Double in15 = cF 0 "15" + in16 :: Pattern Double in16 = cF 0 "16" + in17 :: Pattern Double in17 = cF 0 "17" + in18 :: Pattern Double in18 = cF 0 "18" + in19 :: Pattern Double in19 = cF 0 "19" + in20 :: Pattern Double in20 = cF 0 "20" + in21 :: Pattern Double in21 = cF 0 "21" + in22 :: Pattern Double in22 = cF 0 "22" + in23 :: Pattern Double in23 = cF 0 "23" + in24 :: Pattern Double in24 = cF 0 "24" + in25 :: Pattern Double in25 = cF 0 "25" + in26 :: Pattern Double in26 = cF 0 "26" + in27 :: Pattern Double in27 = cF 0 "27" + in28 :: Pattern Double in28 = cF 0 "28" + in29 :: Pattern Double in29 = cF 0 "29" + in30 :: Pattern Double in30 = cF 0 "30" + in31 :: Pattern Double in31 = cF 0 "31" + in32 :: Pattern Double in32 = cF 0 "32" + in33 :: Pattern Double in33 = cF 0 "33" + in34 :: Pattern Double in34 = cF 0 "34" + in35 :: Pattern Double in35 = cF 0 "35" + in36 :: Pattern Double in36 = cF 0 "36" + in37 :: Pattern Double in37 = cF 0 "37" + in38 :: Pattern Double in38 = cF 0 "38" + in39 :: Pattern Double in39 = cF 0 "39" + in40 :: Pattern Double in40 = cF 0 "40" + in41 :: Pattern Double in41 = cF 0 "41" + in42 :: Pattern Double in42 = cF 0 "42" + in43 :: Pattern Double in43 = cF 0 "43" + in44 :: Pattern Double in44 = cF 0 "44" + in45 :: Pattern Double in45 = cF 0 "45" + in46 :: Pattern Double in46 = cF 0 "46" + in47 :: Pattern Double in47 = cF 0 "47" + in48 :: Pattern Double in48 = cF 0 "48" + in49 :: Pattern Double in49 = cF 0 "49" + in50 :: Pattern Double in50 = cF 0 "50" + in51 :: Pattern Double in51 = cF 0 "51" + in52 :: Pattern Double in52 = cF 0 "52" + in53 :: Pattern Double in53 = cF 0 "53" + in54 :: Pattern Double in54 = cF 0 "54" + in55 :: Pattern Double in55 = cF 0 "55" + in56 :: Pattern Double in56 = cF 0 "56" + in57 :: Pattern Double in57 = cF 0 "57" + in58 :: Pattern Double in58 = cF 0 "58" + in59 :: Pattern Double in59 = cF 0 "59" + in60 :: Pattern Double in60 = cF 0 "60" + in61 :: Pattern Double in61 = cF 0 "61" + in62 :: Pattern Double in62 = cF 0 "62" + in63 :: Pattern Double in63 = cF 0 "63" + in64 :: Pattern Double in64 = cF 0 "64" + in65 :: Pattern Double in65 = cF 0 "65" + in66 :: Pattern Double in66 = cF 0 "66" + in67 :: Pattern Double in67 = cF 0 "67" + in68 :: Pattern Double in68 = cF 0 "68" + in69 :: Pattern Double in69 = cF 0 "69" + in70 :: Pattern Double in70 = cF 0 "70" + in71 :: Pattern Double in71 = cF 0 "71" + in72 :: Pattern Double in72 = cF 0 "72" + in73 :: Pattern Double in73 = cF 0 "73" + in74 :: Pattern Double in74 = cF 0 "74" + in75 :: Pattern Double in75 = cF 0 "75" + in76 :: Pattern Double in76 = cF 0 "76" + in77 :: Pattern Double in77 = cF 0 "77" + in78 :: Pattern Double in78 = cF 0 "78" + in79 :: Pattern Double in79 = cF 0 "79" + in80 :: Pattern Double in80 = cF 0 "80" + in81 :: Pattern Double in81 = cF 0 "81" + in82 :: Pattern Double in82 = cF 0 "82" + in83 :: Pattern Double in83 = cF 0 "83" + in84 :: Pattern Double in84 = cF 0 "84" + in85 :: Pattern Double in85 = cF 0 "85" + in86 :: Pattern Double in86 = cF 0 "86" + in87 :: Pattern Double in87 = cF 0 "87" + in88 :: Pattern Double in88 = cF 0 "88" + in89 :: Pattern Double in89 = cF 0 "89" + in90 :: Pattern Double in90 = cF 0 "90" + in91 :: Pattern Double in91 = cF 0 "91" + in92 :: Pattern Double in92 = cF 0 "92" + in93 :: Pattern Double in93 = cF 0 "93" + in94 :: Pattern Double in94 = cF 0 "94" + in95 :: Pattern Double in95 = cF 0 "95" + in96 :: Pattern Double in96 = cF 0 "96" + in97 :: Pattern Double in97 = cF 0 "97" + in98 :: Pattern Double in98 = cF 0 "98" + in99 :: Pattern Double in99 = cF 0 "99" + in100 :: Pattern Double in100 = cF 0 "100" + in101 :: Pattern Double in101 = cF 0 "101" + in102 :: Pattern Double in102 = cF 0 "102" + in103 :: Pattern Double in103 = cF 0 "103" + in104 :: Pattern Double in104 = cF 0 "104" + in105 :: Pattern Double in105 = cF 0 "105" + in106 :: Pattern Double in106 = cF 0 "106" + in107 :: Pattern Double in107 = cF 0 "107" + in108 :: Pattern Double in108 = cF 0 "108" + in109 :: Pattern Double in109 = cF 0 "109" + in110 :: Pattern Double in110 = cF 0 "110" + in111 :: Pattern Double in111 = cF 0 "111" + in112 :: Pattern Double in112 = cF 0 "112" + in113 :: Pattern Double in113 = cF 0 "113" + in114 :: Pattern Double in114 = cF 0 "114" + in115 :: Pattern Double in115 = cF 0 "115" + in116 :: Pattern Double in116 = cF 0 "116" + in117 :: Pattern Double in117 = cF 0 "117" + in118 :: Pattern Double in118 = cF 0 "118" + in119 :: Pattern Double in119 = cF 0 "119" + in120 :: Pattern Double in120 = cF 0 "120" + in121 :: Pattern Double in121 = cF 0 "121" + in122 :: Pattern Double in122 = cF 0 "122" + in123 :: Pattern Double in123 = cF 0 "123" + in124 :: Pattern Double in124 = cF 0 "124" + in125 :: Pattern Double in125 = cF 0 "125" + in126 :: Pattern Double in126 = cF 0 "126" + in127 :: Pattern Double in127 = cF 0 "127" diff --git a/src/Sound/Tidal/ID.hs b/src/Sound/Tidal/ID.hs index 99827f73..ee31a156 100644 --- a/src/Sound/Tidal/ID.hs +++ b/src/Sound/Tidal/ID.hs @@ -1,4 +1,4 @@ -module Sound.Tidal.ID (ID(..)) where +module Sound.Tidal.ID (ID (..)) where {- ID.hs - Polymorphic pattern identifiers @@ -18,13 +18,12 @@ module Sound.Tidal.ID (ID(..)) where along with this library. If not, see . -} -import GHC.Exts ( IsString(..) ) +import GHC.Exts (IsString (..)) -- | Wrapper for literals that can be coerced to a string and used as an identifier. -- | Similar to Show typeclass, but constrained to strings and integers and designed -- | so that similar cases (such as 1 and "1") convert to the same value. -newtype ID = ID { fromID :: String } deriving (Eq, Show, Ord, Read) - +newtype ID = ID {fromID :: String} deriving (Eq, Show, Ord, Read) noOv :: String -> a noOv meth = error $ meth ++ ": not supported for ids" diff --git a/src/Sound/Tidal/Listener.hs b/src/Sound/Tidal/Listener.hs index ece3e50c..2a9cab17 100644 --- a/src/Sound/Tidal/Listener.hs +++ b/src/Sound/Tidal/Listener.hs @@ -5,15 +5,15 @@ import Sound.OSC.FD as O listenPort = 6011 listen :: IO () -listen = do udp <- udpServer "127.0.0.1" listenPort - loop udp - where - loop udp = - do m <- recvMessage udp - act udp m - loop udp - +listen = do + udp <- udpServer "127.0.0.1" listenPort + loop udp + where + loop udp = + do + m <- recvMessage udp + act udp m + loop udp act :: UDP -> Maybe O.Message -> IO () act _ _ = putStrLn "aha" - diff --git a/src/Sound/Tidal/Params.hs b/src/Sound/Tidal/Params.hs index ce443cfb..e820c91b 100644 --- a/src/Sound/Tidal/Params.hs +++ b/src/Sound/Tidal/Params.hs @@ -22,30 +22,32 @@ module Sound.Tidal.Params where along with this library. If not, see . -} +import Data.Fixed (mod') import qualified Data.Map.Strict as Map - -import Sound.Tidal.Pattern -import Sound.Tidal.Core ((#)) -import Sound.Tidal.Utils import Data.Maybe (fromMaybe) import Data.Word (Word8) -import Data.Fixed (mod') +import Sound.Tidal.Core ((#)) +import Sound.Tidal.Pattern +import Sound.Tidal.Utils -- | Group multiple params into one. grp :: [String -> ValueMap] -> Pattern String -> ControlPattern grp [] _ = empty grp fs p = splitby <$> p - where splitby name = Map.unions $ map (\(v, f) -> f v) $ zip (split name) fs - split :: String -> [String] - split = wordsBy (==':') + where + splitby name = Map.unions $ map (\(v, f) -> f v) $ zip (split name) fs + split :: String -> [String] + split = wordsBy (== ':') mF :: String -> String -> ValueMap -mF name v = fromMaybe Map.empty $ do f <- readMaybe v - return $ Map.singleton name (VF f) +mF name v = fromMaybe Map.empty $ do + f <- readMaybe v + return $ Map.singleton name (VF f) mI :: String -> String -> ValueMap -mI name v = fromMaybe Map.empty $ do i <- readMaybe v - return $ Map.singleton name (VI i) +mI name v = fromMaybe Map.empty $ do + i <- readMaybe v + return $ Map.singleton name (VI i) mS :: String -> String -> ValueMap mS name v = Map.singleton name (VS v) @@ -60,7 +62,7 @@ pI name = fmap (Map.singleton name . VI) pB :: String -> Pattern Bool -> ControlPattern pB name = fmap (Map.singleton name . VB) - + pR :: String -> Pattern Rational -> ControlPattern pR name = fmap (Map.singleton name . VR) @@ -74,40 +76,56 @@ pX :: String -> Pattern [Word8] -> ControlPattern pX name = fmap (Map.singleton name . VX) pStateF :: - String -> -- ^ A parameter, e.g. `note`; a + -- | A parameter, e.g. `note`; a -- `String` recognizable by a `ValueMap`. - String -> -- ^ Identifies the cycling state pattern. + String -> + -- | Identifies the cycling state pattern. -- Can be anything the user wants. + String -> (Maybe Double -> Double) -> ControlPattern pStateF name sName update = pure $ Map.singleton name $ VState statef - where statef :: ValueMap -> (ValueMap, Value) - statef sMap = (Map.insert sName v sMap, v) - where v = VF $ update - $ Map.lookup sName sMap >>= getF + where + statef :: ValueMap -> (ValueMap, Value) + statef sMap = (Map.insert sName v sMap, v) + where + v = + VF $ + update $ + Map.lookup sName sMap >>= getF -- | `pStateList` is made with cyclic lists in mind, -- but it can even "cycle" through infinite lists. pStateList :: - String -> -- ^ A parameter, e.g. `note`; a + -- | A parameter, e.g. `note`; a -- `String` recognizable by a `ValueMap`. - String -> -- ^ Identifies the cycling state pattern. + String -> + -- | Identifies the cycling state pattern. -- Can be anything the user wants. - [Value] -> -- ^ The list to cycle through. + String -> + -- | The list to cycle through. + [Value] -> ControlPattern pStateList name sName xs = pure $ Map.singleton name $ VState statef where statef :: ValueMap -> (ValueMap, Value) - statef sMap = ( Map.insert sName - (VList $ tail looped) sMap - , head looped) - where xs' = fromMaybe xs - $ Map.lookup sName sMap >>= getList - -- do this instead of a cycle, so it can get updated with the a list - looped | null xs' = xs - | otherwise = xs' + statef sMap = + ( Map.insert + sName + (VList $ tail looped) + sMap, + head looped + ) + where + xs' = + fromMaybe xs $ + Map.lookup sName sMap >>= getList + -- do this instead of a cycle, so it can get updated with the a list + looped + | null xs' = xs + | otherwise = xs' -- | A wrapper for `pStateList` that accepts a `[Double]` -- rather than a `[Value]`. @@ -139,13 +157,12 @@ nrpnn = pI "nrpn" nrpnv :: Pattern Int -> ControlPattern nrpnv = pI "val" -{-| @grain'@ is a shortcut to join a @begin@ and @end@ - - These are equivalent: - - > d1 $ slow 2 $ s "bev" # grain' "0.2:0.3" # legato 1 - > d1 $ slow 2 $ s "bev" # begin 0.2 # end 0.3 # legato 1 --} +-- | @grain'@ is a shortcut to join a @begin@ and @end@ +-- +-- These are equivalent: +-- +-- > d1 $ slow 2 $ s "bev" # grain' "0.2:0.3" # legato 1 +-- > d1 $ slow 2 $ s "bev" # begin 0.2 # end 0.3 # legato 1 grain' :: Pattern String -> ControlPattern grain' = grp [mF "begin", mF "end"] @@ -221,121 +238,141 @@ drumN _ = 0 -- * Generated params -{- | A pattern of numbers that speed up (or slow down) samples while they play. - - In the following example, the sound starts at the original pitch and gets - higher as it plays: - - > d1 $ s "arpy" # accelerate 2 - - You can use a negative number to make the sound get lower. In this example, a - different acceleration is applied to each played note using state values: - - > d1 $ arp "up" $ note "c'maj'4" # s "arpy" # accelerateTake "susan" [0.2,1,-1] --} +-- | A pattern of numbers that speed up (or slow down) samples while they play. +-- +-- In the following example, the sound starts at the original pitch and gets +-- higher as it plays: +-- +-- > d1 $ s "arpy" # accelerate 2 +-- +-- You can use a negative number to make the sound get lower. In this example, a +-- different acceleration is applied to each played note using state values: +-- +-- > d1 $ arp "up" $ note "c'maj'4" # s "arpy" # accelerateTake "susan" [0.2,1,-1] accelerate :: Pattern Double -> ControlPattern accelerate = pF "accelerate" accelerateTake :: String -> [Double] -> ControlPattern accelerateTake name xs = pStateListF "accelerate" name xs + accelerateCount :: String -> ControlPattern -accelerateCount name = pStateF "accelerate" name (maybe 0 (+1)) +accelerateCount name = pStateF "accelerate" name (maybe 0 (+ 1)) + accelerateCountTo :: String -> Pattern Double -> Pattern ValueMap -accelerateCountTo name ipat = innerJoin $ (\i -> pStateF "accelerate" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +accelerateCountTo name ipat = innerJoin $ (\i -> pStateF "accelerate" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat acceleratebus :: Pattern Int -> Pattern Double -> ControlPattern acceleratebus _ _ = error $ "Control parameter 'accelerate' can't be sent to a bus." -{-| Controls the amplitude (volume) of the sound. Like 'gain', but linear. - Default value is 0.4. - - > d1 $ s "arpy" # amp "<0.4 0.8 0.2>" --} +-- | Controls the amplitude (volume) of the sound. Like 'gain', but linear. +-- Default value is 0.4. +-- +-- > d1 $ s "arpy" # amp "<0.4 0.8 0.2>" amp :: Pattern Double -> ControlPattern amp = pF "amp" + ampTake :: String -> [Double] -> ControlPattern ampTake name xs = pStateListF "amp" name xs + ampCount :: String -> ControlPattern -ampCount name = pStateF "amp" name (maybe 0 (+1)) +ampCount name = pStateF "amp" name (maybe 0 (+ 1)) + ampCountTo :: String -> Pattern Double -> Pattern ValueMap -ampCountTo name ipat = innerJoin $ (\i -> pStateF "amp" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +ampCountTo name ipat = innerJoin $ (\i -> pStateF "amp" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat ampbus :: Pattern Int -> Pattern Double -> ControlPattern ampbus busid pat = (pF "amp" pat) # (pI "^amp" busid) + amprecv :: Pattern Int -> ControlPattern amprecv busid = pI "^amp" busid --- | +-- | array :: Pattern [Word8] -> ControlPattern array = pX "array" + arrayTake :: String -> [Double] -> ControlPattern arrayTake name xs = pStateListF "array" name xs + arraybus :: Pattern Int -> Pattern [Word8] -> ControlPattern arraybus _ _ = error $ "Control parameter 'array' can't be sent to a bus." -- | a pattern of numbers to specify the attack time (in seconds) of an envelope applied to each sample. attack :: Pattern Double -> ControlPattern attack = pF "attack" + attackTake :: String -> [Double] -> ControlPattern attackTake name xs = pStateListF "attack" name xs + attackCount :: String -> ControlPattern -attackCount name = pStateF "attack" name (maybe 0 (+1)) +attackCount name = pStateF "attack" name (maybe 0 (+ 1)) + attackCountTo :: String -> Pattern Double -> Pattern ValueMap -attackCountTo name ipat = innerJoin $ (\i -> pStateF "attack" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +attackCountTo name ipat = innerJoin $ (\i -> pStateF "attack" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat attackbus :: Pattern Int -> Pattern Double -> ControlPattern attackbus busid pat = (pF "attack" pat) # (pI "^attack" busid) + attackrecv :: Pattern Int -> ControlPattern attackrecv busid = pI "^attack" busid -- | a pattern of numbers from 0 to 1. Sets the center frequency of the band-pass filter. bandf :: Pattern Double -> ControlPattern bandf = pF "bandf" + bandfTake :: String -> [Double] -> ControlPattern bandfTake name xs = pStateListF "bandf" name xs + bandfCount :: String -> ControlPattern -bandfCount name = pStateF "bandf" name (maybe 0 (+1)) +bandfCount name = pStateF "bandf" name (maybe 0 (+ 1)) + bandfCountTo :: String -> Pattern Double -> Pattern ValueMap -bandfCountTo name ipat = innerJoin $ (\i -> pStateF "bandf" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +bandfCountTo name ipat = innerJoin $ (\i -> pStateF "bandf" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat bandfbus :: Pattern Int -> Pattern Double -> ControlPattern bandfbus busid pat = (pF "bandf" pat) # (pI "^bandf" busid) + bandfrecv :: Pattern Int -> ControlPattern bandfrecv busid = pI "^bandf" busid -- | a pattern of anumbers from 0 to 1. Sets the q-factor of the band-pass filter. bandq :: Pattern Double -> ControlPattern bandq = pF "bandq" + bandqTake :: String -> [Double] -> ControlPattern bandqTake name xs = pStateListF "bandq" name xs + bandqCount :: String -> ControlPattern -bandqCount name = pStateF "bandq" name (maybe 0 (+1)) +bandqCount name = pStateF "bandq" name (maybe 0 (+ 1)) + bandqCountTo :: String -> Pattern Double -> Pattern ValueMap -bandqCountTo name ipat = innerJoin $ (\i -> pStateF "bandq" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +bandqCountTo name ipat = innerJoin $ (\i -> pStateF "bandq" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat bandqbus :: Pattern Int -> Pattern Double -> ControlPattern bandqbus busid pat = (pF "bandq" pat) # (pI "^bandq" busid) + bandqrecv :: Pattern Int -> ControlPattern bandqrecv busid = pI "^bandq" busid -{- | @begin@ receives a pattern of numbers from 0 to 1 and skips the beginning -of each sample by the indicated proportion. I.e., 0 would play the sample from -the start, 1 would skip the whole sample, and 0.25 would cut off the first -quarter. - -In this example, the first 3 @ade@ samples are played on every cycle, but the -start point from which they are played changes on each cycle: - -> d1 $ n "0 1 2" # s "ade" # begin "<0 0.25 0.5 0.75>" # legato 1 --} +-- | @begin@ receives a pattern of numbers from 0 to 1 and skips the beginning +-- of each sample by the indicated proportion. I.e., 0 would play the sample from +-- the start, 1 would skip the whole sample, and 0.25 would cut off the first +-- quarter. +-- +-- In this example, the first 3 @ade@ samples are played on every cycle, but the +-- start point from which they are played changes on each cycle: +-- +-- > d1 $ n "0 1 2" # s "ade" # begin "<0 0.25 0.5 0.75>" # legato 1 begin :: Pattern Double -> ControlPattern begin = pF "begin" + beginTake :: String -> [Double] -> ControlPattern beginTake name xs = pStateListF "begin" name xs + beginCount :: String -> ControlPattern -beginCount name = pStateF "begin" name (maybe 0 (+1)) +beginCount name = pStateF "begin" name (maybe 0 (+ 1)) + beginCountTo :: String -> Pattern Double -> Pattern ValueMap -beginCountTo name ipat = innerJoin $ (\i -> pStateF "begin" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +beginCountTo name ipat = innerJoin $ (\i -> pStateF "begin" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat beginbus :: Pattern Int -> Pattern Double -> ControlPattern beginbus _ _ = error $ "Control parameter 'begin' can't be sent to a bus." @@ -343,280 +380,354 @@ beginbus _ _ = error $ "Control parameter 'begin' can't be sent to a bus." -- | Spectral binshift binshift :: Pattern Double -> ControlPattern binshift = pF "binshift" + binshiftTake :: String -> [Double] -> ControlPattern binshiftTake name xs = pStateListF "binshift" name xs + binshiftCount :: String -> ControlPattern -binshiftCount name = pStateF "binshift" name (maybe 0 (+1)) +binshiftCount name = pStateF "binshift" name (maybe 0 (+ 1)) + binshiftCountTo :: String -> Pattern Double -> Pattern ValueMap -binshiftCountTo name ipat = innerJoin $ (\i -> pStateF "binshift" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +binshiftCountTo name ipat = innerJoin $ (\i -> pStateF "binshift" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat binshiftbus :: Pattern Int -> Pattern Double -> ControlPattern binshiftbus busid pat = (pF "binshift" pat) # (pI "^binshift" busid) + binshiftrecv :: Pattern Int -> ControlPattern binshiftrecv busid = pI "^binshift" busid --- | +-- | button0 :: Pattern Double -> ControlPattern button0 = pF "button0" + button0Take :: String -> [Double] -> ControlPattern button0Take name xs = pStateListF "button0" name xs + button0Count :: String -> ControlPattern -button0Count name = pStateF "button0" name (maybe 0 (+1)) +button0Count name = pStateF "button0" name (maybe 0 (+ 1)) + button0CountTo :: String -> Pattern Double -> Pattern ValueMap -button0CountTo name ipat = innerJoin $ (\i -> pStateF "button0" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +button0CountTo name ipat = innerJoin $ (\i -> pStateF "button0" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat button0bus :: Pattern Int -> Pattern Double -> ControlPattern button0bus busid pat = (pF "button0" pat) # (pI "^button0" busid) + button0recv :: Pattern Int -> ControlPattern button0recv busid = pI "^button0" busid --- | +-- | button1 :: Pattern Double -> ControlPattern button1 = pF "button1" + button1Take :: String -> [Double] -> ControlPattern button1Take name xs = pStateListF "button1" name xs + button1Count :: String -> ControlPattern -button1Count name = pStateF "button1" name (maybe 0 (+1)) +button1Count name = pStateF "button1" name (maybe 0 (+ 1)) + button1CountTo :: String -> Pattern Double -> Pattern ValueMap -button1CountTo name ipat = innerJoin $ (\i -> pStateF "button1" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +button1CountTo name ipat = innerJoin $ (\i -> pStateF "button1" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat button1bus :: Pattern Int -> Pattern Double -> ControlPattern button1bus busid pat = (pF "button1" pat) # (pI "^button1" busid) + button1recv :: Pattern Int -> ControlPattern button1recv busid = pI "^button1" busid --- | +-- | button10 :: Pattern Double -> ControlPattern button10 = pF "button10" + button10Take :: String -> [Double] -> ControlPattern button10Take name xs = pStateListF "button10" name xs + button10Count :: String -> ControlPattern -button10Count name = pStateF "button10" name (maybe 0 (+1)) +button10Count name = pStateF "button10" name (maybe 0 (+ 1)) + button10CountTo :: String -> Pattern Double -> Pattern ValueMap -button10CountTo name ipat = innerJoin $ (\i -> pStateF "button10" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +button10CountTo name ipat = innerJoin $ (\i -> pStateF "button10" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat button10bus :: Pattern Int -> Pattern Double -> ControlPattern button10bus busid pat = (pF "button10" pat) # (pI "^button10" busid) + button10recv :: Pattern Int -> ControlPattern button10recv busid = pI "^button10" busid --- | +-- | button11 :: Pattern Double -> ControlPattern button11 = pF "button11" + button11Take :: String -> [Double] -> ControlPattern button11Take name xs = pStateListF "button11" name xs + button11Count :: String -> ControlPattern -button11Count name = pStateF "button11" name (maybe 0 (+1)) +button11Count name = pStateF "button11" name (maybe 0 (+ 1)) + button11CountTo :: String -> Pattern Double -> Pattern ValueMap -button11CountTo name ipat = innerJoin $ (\i -> pStateF "button11" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +button11CountTo name ipat = innerJoin $ (\i -> pStateF "button11" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat button11bus :: Pattern Int -> Pattern Double -> ControlPattern button11bus busid pat = (pF "button11" pat) # (pI "^button11" busid) + button11recv :: Pattern Int -> ControlPattern button11recv busid = pI "^button11" busid --- | +-- | button12 :: Pattern Double -> ControlPattern button12 = pF "button12" + button12Take :: String -> [Double] -> ControlPattern button12Take name xs = pStateListF "button12" name xs + button12Count :: String -> ControlPattern -button12Count name = pStateF "button12" name (maybe 0 (+1)) +button12Count name = pStateF "button12" name (maybe 0 (+ 1)) + button12CountTo :: String -> Pattern Double -> Pattern ValueMap -button12CountTo name ipat = innerJoin $ (\i -> pStateF "button12" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +button12CountTo name ipat = innerJoin $ (\i -> pStateF "button12" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat button12bus :: Pattern Int -> Pattern Double -> ControlPattern button12bus busid pat = (pF "button12" pat) # (pI "^button12" busid) + button12recv :: Pattern Int -> ControlPattern button12recv busid = pI "^button12" busid --- | +-- | button13 :: Pattern Double -> ControlPattern button13 = pF "button13" + button13Take :: String -> [Double] -> ControlPattern button13Take name xs = pStateListF "button13" name xs + button13Count :: String -> ControlPattern -button13Count name = pStateF "button13" name (maybe 0 (+1)) +button13Count name = pStateF "button13" name (maybe 0 (+ 1)) + button13CountTo :: String -> Pattern Double -> Pattern ValueMap -button13CountTo name ipat = innerJoin $ (\i -> pStateF "button13" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +button13CountTo name ipat = innerJoin $ (\i -> pStateF "button13" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat button13bus :: Pattern Int -> Pattern Double -> ControlPattern button13bus busid pat = (pF "button13" pat) # (pI "^button13" busid) + button13recv :: Pattern Int -> ControlPattern button13recv busid = pI "^button13" busid --- | +-- | button14 :: Pattern Double -> ControlPattern button14 = pF "button14" + button14Take :: String -> [Double] -> ControlPattern button14Take name xs = pStateListF "button14" name xs + button14Count :: String -> ControlPattern -button14Count name = pStateF "button14" name (maybe 0 (+1)) +button14Count name = pStateF "button14" name (maybe 0 (+ 1)) + button14CountTo :: String -> Pattern Double -> Pattern ValueMap -button14CountTo name ipat = innerJoin $ (\i -> pStateF "button14" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +button14CountTo name ipat = innerJoin $ (\i -> pStateF "button14" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat button14bus :: Pattern Int -> Pattern Double -> ControlPattern button14bus busid pat = (pF "button14" pat) # (pI "^button14" busid) + button14recv :: Pattern Int -> ControlPattern button14recv busid = pI "^button14" busid --- | +-- | button15 :: Pattern Double -> ControlPattern button15 = pF "button15" + button15Take :: String -> [Double] -> ControlPattern button15Take name xs = pStateListF "button15" name xs + button15Count :: String -> ControlPattern -button15Count name = pStateF "button15" name (maybe 0 (+1)) +button15Count name = pStateF "button15" name (maybe 0 (+ 1)) + button15CountTo :: String -> Pattern Double -> Pattern ValueMap -button15CountTo name ipat = innerJoin $ (\i -> pStateF "button15" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +button15CountTo name ipat = innerJoin $ (\i -> pStateF "button15" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat button15bus :: Pattern Int -> Pattern Double -> ControlPattern button15bus busid pat = (pF "button15" pat) # (pI "^button15" busid) + button15recv :: Pattern Int -> ControlPattern button15recv busid = pI "^button15" busid --- | +-- | button2 :: Pattern Double -> ControlPattern button2 = pF "button2" + button2Take :: String -> [Double] -> ControlPattern button2Take name xs = pStateListF "button2" name xs + button2Count :: String -> ControlPattern -button2Count name = pStateF "button2" name (maybe 0 (+1)) +button2Count name = pStateF "button2" name (maybe 0 (+ 1)) + button2CountTo :: String -> Pattern Double -> Pattern ValueMap -button2CountTo name ipat = innerJoin $ (\i -> pStateF "button2" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +button2CountTo name ipat = innerJoin $ (\i -> pStateF "button2" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat button2bus :: Pattern Int -> Pattern Double -> ControlPattern button2bus busid pat = (pF "button2" pat) # (pI "^button2" busid) + button2recv :: Pattern Int -> ControlPattern button2recv busid = pI "^button2" busid --- | +-- | button3 :: Pattern Double -> ControlPattern button3 = pF "button3" + button3Take :: String -> [Double] -> ControlPattern button3Take name xs = pStateListF "button3" name xs + button3Count :: String -> ControlPattern -button3Count name = pStateF "button3" name (maybe 0 (+1)) +button3Count name = pStateF "button3" name (maybe 0 (+ 1)) + button3CountTo :: String -> Pattern Double -> Pattern ValueMap -button3CountTo name ipat = innerJoin $ (\i -> pStateF "button3" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +button3CountTo name ipat = innerJoin $ (\i -> pStateF "button3" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat button3bus :: Pattern Int -> Pattern Double -> ControlPattern button3bus busid pat = (pF "button3" pat) # (pI "^button3" busid) + button3recv :: Pattern Int -> ControlPattern button3recv busid = pI "^button3" busid --- | +-- | button4 :: Pattern Double -> ControlPattern button4 = pF "button4" + button4Take :: String -> [Double] -> ControlPattern button4Take name xs = pStateListF "button4" name xs + button4Count :: String -> ControlPattern -button4Count name = pStateF "button4" name (maybe 0 (+1)) +button4Count name = pStateF "button4" name (maybe 0 (+ 1)) + button4CountTo :: String -> Pattern Double -> Pattern ValueMap -button4CountTo name ipat = innerJoin $ (\i -> pStateF "button4" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +button4CountTo name ipat = innerJoin $ (\i -> pStateF "button4" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat button4bus :: Pattern Int -> Pattern Double -> ControlPattern button4bus busid pat = (pF "button4" pat) # (pI "^button4" busid) + button4recv :: Pattern Int -> ControlPattern button4recv busid = pI "^button4" busid --- | +-- | button5 :: Pattern Double -> ControlPattern button5 = pF "button5" + button5Take :: String -> [Double] -> ControlPattern button5Take name xs = pStateListF "button5" name xs + button5Count :: String -> ControlPattern -button5Count name = pStateF "button5" name (maybe 0 (+1)) +button5Count name = pStateF "button5" name (maybe 0 (+ 1)) + button5CountTo :: String -> Pattern Double -> Pattern ValueMap -button5CountTo name ipat = innerJoin $ (\i -> pStateF "button5" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +button5CountTo name ipat = innerJoin $ (\i -> pStateF "button5" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat button5bus :: Pattern Int -> Pattern Double -> ControlPattern button5bus busid pat = (pF "button5" pat) # (pI "^button5" busid) + button5recv :: Pattern Int -> ControlPattern button5recv busid = pI "^button5" busid --- | +-- | button6 :: Pattern Double -> ControlPattern button6 = pF "button6" + button6Take :: String -> [Double] -> ControlPattern button6Take name xs = pStateListF "button6" name xs + button6Count :: String -> ControlPattern -button6Count name = pStateF "button6" name (maybe 0 (+1)) +button6Count name = pStateF "button6" name (maybe 0 (+ 1)) + button6CountTo :: String -> Pattern Double -> Pattern ValueMap -button6CountTo name ipat = innerJoin $ (\i -> pStateF "button6" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +button6CountTo name ipat = innerJoin $ (\i -> pStateF "button6" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat button6bus :: Pattern Int -> Pattern Double -> ControlPattern button6bus busid pat = (pF "button6" pat) # (pI "^button6" busid) + button6recv :: Pattern Int -> ControlPattern button6recv busid = pI "^button6" busid --- | +-- | button7 :: Pattern Double -> ControlPattern button7 = pF "button7" + button7Take :: String -> [Double] -> ControlPattern button7Take name xs = pStateListF "button7" name xs + button7Count :: String -> ControlPattern -button7Count name = pStateF "button7" name (maybe 0 (+1)) +button7Count name = pStateF "button7" name (maybe 0 (+ 1)) + button7CountTo :: String -> Pattern Double -> Pattern ValueMap -button7CountTo name ipat = innerJoin $ (\i -> pStateF "button7" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +button7CountTo name ipat = innerJoin $ (\i -> pStateF "button7" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat button7bus :: Pattern Int -> Pattern Double -> ControlPattern button7bus busid pat = (pF "button7" pat) # (pI "^button7" busid) + button7recv :: Pattern Int -> ControlPattern button7recv busid = pI "^button7" busid --- | +-- | button8 :: Pattern Double -> ControlPattern button8 = pF "button8" + button8Take :: String -> [Double] -> ControlPattern button8Take name xs = pStateListF "button8" name xs + button8Count :: String -> ControlPattern -button8Count name = pStateF "button8" name (maybe 0 (+1)) +button8Count name = pStateF "button8" name (maybe 0 (+ 1)) + button8CountTo :: String -> Pattern Double -> Pattern ValueMap -button8CountTo name ipat = innerJoin $ (\i -> pStateF "button8" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +button8CountTo name ipat = innerJoin $ (\i -> pStateF "button8" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat button8bus :: Pattern Int -> Pattern Double -> ControlPattern button8bus busid pat = (pF "button8" pat) # (pI "^button8" busid) + button8recv :: Pattern Int -> ControlPattern button8recv busid = pI "^button8" busid --- | +-- | button9 :: Pattern Double -> ControlPattern button9 = pF "button9" + button9Take :: String -> [Double] -> ControlPattern button9Take name xs = pStateListF "button9" name xs + button9Count :: String -> ControlPattern -button9Count name = pStateF "button9" name (maybe 0 (+1)) +button9Count name = pStateF "button9" name (maybe 0 (+ 1)) + button9CountTo :: String -> Pattern Double -> Pattern ValueMap -button9CountTo name ipat = innerJoin $ (\i -> pStateF "button9" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +button9CountTo name ipat = innerJoin $ (\i -> pStateF "button9" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat button9bus :: Pattern Int -> Pattern Double -> ControlPattern button9bus busid pat = (pF "button9" pat) # (pI "^button9" busid) + button9recv :: Pattern Int -> ControlPattern button9recv busid = pI "^button9" busid --- | +-- | ccn :: Pattern Double -> ControlPattern ccn = pF "ccn" + ccnTake :: String -> [Double] -> ControlPattern ccnTake name xs = pStateListF "ccn" name xs + ccnCount :: String -> ControlPattern -ccnCount name = pStateF "ccn" name (maybe 0 (+1)) +ccnCount name = pStateF "ccn" name (maybe 0 (+ 1)) + ccnCountTo :: String -> Pattern Double -> Pattern ValueMap -ccnCountTo name ipat = innerJoin $ (\i -> pStateF "ccn" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +ccnCountTo name ipat = innerJoin $ (\i -> pStateF "ccn" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat ccnbus :: Pattern Int -> Pattern Double -> ControlPattern ccnbus _ _ = error $ "Control parameter 'ccn' can't be sent to a bus." --- | +-- | ccv :: Pattern Double -> ControlPattern ccv = pF "ccv" + ccvTake :: String -> [Double] -> ControlPattern ccvTake name xs = pStateListF "ccv" name xs + ccvCount :: String -> ControlPattern -ccvCount name = pStateF "ccv" name (maybe 0 (+1)) +ccvCount name = pStateF "ccv" name (maybe 0 (+ 1)) + ccvCountTo :: String -> Pattern Double -> Pattern ValueMap -ccvCountTo name ipat = innerJoin $ (\i -> pStateF "ccv" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +ccvCountTo name ipat = innerJoin $ (\i -> pStateF "ccv" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat ccvbus :: Pattern Int -> Pattern Double -> ControlPattern ccvbus _ _ = error $ "Control parameter 'ccv' can't be sent to a bus." @@ -624,349 +735,435 @@ ccvbus _ _ = error $ "Control parameter 'ccv' can't be sent to a bus." -- | choose the channel the pattern is sent to in superdirt channel :: Pattern Int -> ControlPattern channel = pI "channel" + channelTake :: String -> [Double] -> ControlPattern channelTake name xs = pStateListF "channel" name xs + channelCount :: String -> ControlPattern -channelCount name = pStateF "channel" name (maybe 0 (+1)) +channelCount name = pStateF "channel" name (maybe 0 (+ 1)) + channelCountTo :: String -> Pattern Double -> Pattern ValueMap -channelCountTo name ipat = innerJoin $ (\i -> pStateF "channel" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +channelCountTo name ipat = innerJoin $ (\i -> pStateF "channel" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat channelbus :: Pattern Int -> Pattern Int -> ControlPattern channelbus _ _ = error $ "Control parameter 'channel' can't be sent to a bus." --- | +-- | clhatdecay :: Pattern Double -> ControlPattern clhatdecay = pF "clhatdecay" + clhatdecayTake :: String -> [Double] -> ControlPattern clhatdecayTake name xs = pStateListF "clhatdecay" name xs + clhatdecayCount :: String -> ControlPattern -clhatdecayCount name = pStateF "clhatdecay" name (maybe 0 (+1)) +clhatdecayCount name = pStateF "clhatdecay" name (maybe 0 (+ 1)) + clhatdecayCountTo :: String -> Pattern Double -> Pattern ValueMap -clhatdecayCountTo name ipat = innerJoin $ (\i -> pStateF "clhatdecay" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +clhatdecayCountTo name ipat = innerJoin $ (\i -> pStateF "clhatdecay" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat clhatdecaybus :: Pattern Int -> Pattern Double -> ControlPattern clhatdecaybus busid pat = (pF "clhatdecay" pat) # (pI "^clhatdecay" busid) + clhatdecayrecv :: Pattern Int -> ControlPattern clhatdecayrecv busid = pI "^clhatdecay" busid -- | fake-resampling, a pattern of numbers for lowering the sample rate, i.e. 1 for original 2 for half, 3 for a third and so on. coarse :: Pattern Double -> ControlPattern coarse = pF "coarse" + coarseTake :: String -> [Double] -> ControlPattern coarseTake name xs = pStateListF "coarse" name xs + coarseCount :: String -> ControlPattern -coarseCount name = pStateF "coarse" name (maybe 0 (+1)) +coarseCount name = pStateF "coarse" name (maybe 0 (+ 1)) + coarseCountTo :: String -> Pattern Double -> Pattern ValueMap -coarseCountTo name ipat = innerJoin $ (\i -> pStateF "coarse" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +coarseCountTo name ipat = innerJoin $ (\i -> pStateF "coarse" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat coarsebus :: Pattern Int -> Pattern Double -> ControlPattern coarsebus busid pat = (pF "coarse" pat) # (pI "^coarse" busid) + coarserecv :: Pattern Int -> ControlPattern coarserecv busid = pI "^coarse" busid -- | Spectral comb comb :: Pattern Double -> ControlPattern comb = pF "comb" + combTake :: String -> [Double] -> ControlPattern combTake name xs = pStateListF "comb" name xs + combCount :: String -> ControlPattern -combCount name = pStateF "comb" name (maybe 0 (+1)) +combCount name = pStateF "comb" name (maybe 0 (+ 1)) + combCountTo :: String -> Pattern Double -> Pattern ValueMap -combCountTo name ipat = innerJoin $ (\i -> pStateF "comb" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +combCountTo name ipat = innerJoin $ (\i -> pStateF "comb" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat combbus :: Pattern Int -> Pattern Double -> ControlPattern combbus busid pat = (pF "comb" pat) # (pI "^comb" busid) + combrecv :: Pattern Int -> ControlPattern combrecv busid = pI "^comb" busid --- | +-- | control :: Pattern Double -> ControlPattern control = pF "control" + controlTake :: String -> [Double] -> ControlPattern controlTake name xs = pStateListF "control" name xs + controlCount :: String -> ControlPattern -controlCount name = pStateF "control" name (maybe 0 (+1)) +controlCount name = pStateF "control" name (maybe 0 (+ 1)) + controlCountTo :: String -> Pattern Double -> Pattern ValueMap -controlCountTo name ipat = innerJoin $ (\i -> pStateF "control" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +controlCountTo name ipat = innerJoin $ (\i -> pStateF "control" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat controlbus :: Pattern Int -> Pattern Double -> ControlPattern controlbus _ _ = error $ "Control parameter 'control' can't be sent to a bus." -{-| A control pattern; 'setcps' is the standalone function. - - Patterns don’t (yet) have independent tempos though, if you change it on one - pattern, it changes on all of them. - - > p "cpsfun" $ s "bd sd(3,8)" # cps (slow 8 $ 0.5 + saw) --} +-- | A control pattern; 'setcps' is the standalone function. +-- +-- Patterns don’t (yet) have independent tempos though, if you change it on one +-- pattern, it changes on all of them. +-- +-- > p "cpsfun" $ s "bd sd(3,8)" # cps (slow 8 $ 0.5 + saw) cps :: Pattern Double -> ControlPattern cps = pF "cps" + cpsTake :: String -> [Double] -> ControlPattern cpsTake name xs = pStateListF "cps" name xs + cpsCount :: String -> ControlPattern -cpsCount name = pStateF "cps" name (maybe 0 (+1)) +cpsCount name = pStateF "cps" name (maybe 0 (+ 1)) + cpsCountTo :: String -> Pattern Double -> Pattern ValueMap -cpsCountTo name ipat = innerJoin $ (\i -> pStateF "cps" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +cpsCountTo name ipat = innerJoin $ (\i -> pStateF "cps" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat cpsbus :: Pattern Int -> Pattern Double -> ControlPattern cpsbus busid pat = (pF "cps" pat) # (pI "^cps" busid) + cpsrecv :: Pattern Int -> ControlPattern cpsrecv busid = pI "^cps" busid -- | bit crushing, a pattern of numbers from 1 (for drastic reduction in bit-depth) to 16 (for barely no reduction). crush :: Pattern Double -> ControlPattern crush = pF "crush" + crushTake :: String -> [Double] -> ControlPattern crushTake name xs = pStateListF "crush" name xs + crushCount :: String -> ControlPattern -crushCount name = pStateF "crush" name (maybe 0 (+1)) +crushCount name = pStateF "crush" name (maybe 0 (+ 1)) + crushCountTo :: String -> Pattern Double -> Pattern ValueMap -crushCountTo name ipat = innerJoin $ (\i -> pStateF "crush" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +crushCountTo name ipat = innerJoin $ (\i -> pStateF "crush" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat crushbus :: Pattern Int -> Pattern Double -> ControlPattern crushbus busid pat = (pF "crush" pat) # (pI "^crush" busid) + crushrecv :: Pattern Int -> ControlPattern crushrecv busid = pI "^crush" busid --- | +-- | ctlNum :: Pattern Double -> ControlPattern ctlNum = pF "ctlNum" + ctlNumTake :: String -> [Double] -> ControlPattern ctlNumTake name xs = pStateListF "ctlNum" name xs + ctlNumCount :: String -> ControlPattern -ctlNumCount name = pStateF "ctlNum" name (maybe 0 (+1)) +ctlNumCount name = pStateF "ctlNum" name (maybe 0 (+ 1)) + ctlNumCountTo :: String -> Pattern Double -> Pattern ValueMap -ctlNumCountTo name ipat = innerJoin $ (\i -> pStateF "ctlNum" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +ctlNumCountTo name ipat = innerJoin $ (\i -> pStateF "ctlNum" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat ctlNumbus :: Pattern Int -> Pattern Double -> ControlPattern ctlNumbus _ _ = error $ "Control parameter 'ctlNum' can't be sent to a bus." --- | +-- | ctranspose :: Pattern Double -> ControlPattern ctranspose = pF "ctranspose" + ctransposeTake :: String -> [Double] -> ControlPattern ctransposeTake name xs = pStateListF "ctranspose" name xs + ctransposeCount :: String -> ControlPattern -ctransposeCount name = pStateF "ctranspose" name (maybe 0 (+1)) +ctransposeCount name = pStateF "ctranspose" name (maybe 0 (+ 1)) + ctransposeCountTo :: String -> Pattern Double -> Pattern ValueMap -ctransposeCountTo name ipat = innerJoin $ (\i -> pStateF "ctranspose" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +ctransposeCountTo name ipat = innerJoin $ (\i -> pStateF "ctranspose" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat ctransposebus :: Pattern Int -> Pattern Double -> ControlPattern ctransposebus busid pat = (pF "ctranspose" pat) # (pI "^ctranspose" busid) + ctransposerecv :: Pattern Int -> ControlPattern ctransposerecv busid = pI "^ctranspose" busid -- | In the style of classic drum-machines, `cut` will stop a playing sample as soon as another samples with in same cutgroup is to be played. An example would be an open hi-hat followed by a closed one, essentially muting the open. cut :: Pattern Int -> ControlPattern cut = pI "cut" + cutTake :: String -> [Double] -> ControlPattern cutTake name xs = pStateListF "cut" name xs + cutCount :: String -> ControlPattern -cutCount name = pStateF "cut" name (maybe 0 (+1)) +cutCount name = pStateF "cut" name (maybe 0 (+ 1)) + cutCountTo :: String -> Pattern Double -> Pattern ValueMap -cutCountTo name ipat = innerJoin $ (\i -> pStateF "cut" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +cutCountTo name ipat = innerJoin $ (\i -> pStateF "cut" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat cutbus :: Pattern Int -> Pattern Int -> ControlPattern cutbus busid pat = (pI "cut" pat) # (pI "^cut" busid) + cutrecv :: Pattern Int -> ControlPattern cutrecv busid = pI "^cut" busid -- | a pattern of numbers from 0 to 1. Applies the cutoff frequency of the low-pass filter. cutoff :: Pattern Double -> ControlPattern cutoff = pF "cutoff" + cutoffTake :: String -> [Double] -> ControlPattern cutoffTake name xs = pStateListF "cutoff" name xs + cutoffCount :: String -> ControlPattern -cutoffCount name = pStateF "cutoff" name (maybe 0 (+1)) +cutoffCount name = pStateF "cutoff" name (maybe 0 (+ 1)) + cutoffCountTo :: String -> Pattern Double -> Pattern ValueMap -cutoffCountTo name ipat = innerJoin $ (\i -> pStateF "cutoff" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +cutoffCountTo name ipat = innerJoin $ (\i -> pStateF "cutoff" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat cutoffbus :: Pattern Int -> Pattern Double -> ControlPattern cutoffbus busid pat = (pF "cutoff" pat) # (pI "^cutoff" busid) + cutoffrecv :: Pattern Int -> ControlPattern cutoffrecv busid = pI "^cutoff" busid --- | +-- | cutoffegint :: Pattern Double -> ControlPattern cutoffegint = pF "cutoffegint" + cutoffegintTake :: String -> [Double] -> ControlPattern cutoffegintTake name xs = pStateListF "cutoffegint" name xs + cutoffegintCount :: String -> ControlPattern -cutoffegintCount name = pStateF "cutoffegint" name (maybe 0 (+1)) +cutoffegintCount name = pStateF "cutoffegint" name (maybe 0 (+ 1)) + cutoffegintCountTo :: String -> Pattern Double -> Pattern ValueMap -cutoffegintCountTo name ipat = innerJoin $ (\i -> pStateF "cutoffegint" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +cutoffegintCountTo name ipat = innerJoin $ (\i -> pStateF "cutoffegint" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat cutoffegintbus :: Pattern Int -> Pattern Double -> ControlPattern cutoffegintbus busid pat = (pF "cutoffegint" pat) # (pI "^cutoffegint" busid) + cutoffegintrecv :: Pattern Int -> ControlPattern cutoffegintrecv busid = pI "^cutoffegint" busid --- | +-- | decay :: Pattern Double -> ControlPattern decay = pF "decay" + decayTake :: String -> [Double] -> ControlPattern decayTake name xs = pStateListF "decay" name xs + decayCount :: String -> ControlPattern -decayCount name = pStateF "decay" name (maybe 0 (+1)) +decayCount name = pStateF "decay" name (maybe 0 (+ 1)) + decayCountTo :: String -> Pattern Double -> Pattern ValueMap -decayCountTo name ipat = innerJoin $ (\i -> pStateF "decay" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +decayCountTo name ipat = innerJoin $ (\i -> pStateF "decay" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat decaybus :: Pattern Int -> Pattern Double -> ControlPattern decaybus busid pat = (pF "decay" pat) # (pI "^decay" busid) + decayrecv :: Pattern Int -> ControlPattern decayrecv busid = pI "^decay" busid --- | +-- | degree :: Pattern Double -> ControlPattern degree = pF "degree" + degreeTake :: String -> [Double] -> ControlPattern degreeTake name xs = pStateListF "degree" name xs + degreeCount :: String -> ControlPattern -degreeCount name = pStateF "degree" name (maybe 0 (+1)) +degreeCount name = pStateF "degree" name (maybe 0 (+ 1)) + degreeCountTo :: String -> Pattern Double -> Pattern ValueMap -degreeCountTo name ipat = innerJoin $ (\i -> pStateF "degree" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +degreeCountTo name ipat = innerJoin $ (\i -> pStateF "degree" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat degreebus :: Pattern Int -> Pattern Double -> ControlPattern degreebus busid pat = (pF "degree" pat) # (pI "^degree" busid) + degreerecv :: Pattern Int -> ControlPattern degreerecv busid = pI "^degree" busid -- | a pattern of numbers from 0 to 1. Sets the level of the delay signal. delay :: Pattern Double -> ControlPattern delay = pF "delay" + delayTake :: String -> [Double] -> ControlPattern delayTake name xs = pStateListF "delay" name xs + delayCount :: String -> ControlPattern -delayCount name = pStateF "delay" name (maybe 0 (+1)) +delayCount name = pStateF "delay" name (maybe 0 (+ 1)) + delayCountTo :: String -> Pattern Double -> Pattern ValueMap -delayCountTo name ipat = innerJoin $ (\i -> pStateF "delay" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +delayCountTo name ipat = innerJoin $ (\i -> pStateF "delay" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat delaybus :: Pattern Int -> Pattern Double -> ControlPattern delaybus busid pat = (pF "delay" pat) # (pI "^delay" busid) + delayrecv :: Pattern Int -> ControlPattern delayrecv busid = pI "^delay" busid -- | a pattern of numbers from 0 to 1. Sets the amount of delay feedback. delayfeedback :: Pattern Double -> ControlPattern delayfeedback = pF "delayfeedback" + delayfeedbackTake :: String -> [Double] -> ControlPattern delayfeedbackTake name xs = pStateListF "delayfeedback" name xs + delayfeedbackCount :: String -> ControlPattern -delayfeedbackCount name = pStateF "delayfeedback" name (maybe 0 (+1)) +delayfeedbackCount name = pStateF "delayfeedback" name (maybe 0 (+ 1)) + delayfeedbackCountTo :: String -> Pattern Double -> Pattern ValueMap -delayfeedbackCountTo name ipat = innerJoin $ (\i -> pStateF "delayfeedback" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +delayfeedbackCountTo name ipat = innerJoin $ (\i -> pStateF "delayfeedback" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat delayfeedbackbus :: Pattern Int -> Pattern Double -> ControlPattern delayfeedbackbus busid pat = (pF "delayfeedback" pat) # (pI "^delayfeedback" busid) + delayfeedbackrecv :: Pattern Int -> ControlPattern delayfeedbackrecv busid = pI "^delayfeedback" busid -- | a pattern of numbers from 0 to 1. Sets the length of the delay. delaytime :: Pattern Double -> ControlPattern delaytime = pF "delaytime" + delaytimeTake :: String -> [Double] -> ControlPattern delaytimeTake name xs = pStateListF "delaytime" name xs + delaytimeCount :: String -> ControlPattern -delaytimeCount name = pStateF "delaytime" name (maybe 0 (+1)) +delaytimeCount name = pStateF "delaytime" name (maybe 0 (+ 1)) + delaytimeCountTo :: String -> Pattern Double -> Pattern ValueMap -delaytimeCountTo name ipat = innerJoin $ (\i -> pStateF "delaytime" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +delaytimeCountTo name ipat = innerJoin $ (\i -> pStateF "delaytime" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat delaytimebus :: Pattern Int -> Pattern Double -> ControlPattern delaytimebus busid pat = (pF "delaytime" pat) # (pI "^delaytime" busid) + delaytimerecv :: Pattern Int -> ControlPattern delaytimerecv busid = pI "^delaytime" busid --- | +-- | detune :: Pattern Double -> ControlPattern detune = pF "detune" + detuneTake :: String -> [Double] -> ControlPattern detuneTake name xs = pStateListF "detune" name xs + detuneCount :: String -> ControlPattern -detuneCount name = pStateF "detune" name (maybe 0 (+1)) +detuneCount name = pStateF "detune" name (maybe 0 (+ 1)) + detuneCountTo :: String -> Pattern Double -> Pattern ValueMap -detuneCountTo name ipat = innerJoin $ (\i -> pStateF "detune" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +detuneCountTo name ipat = innerJoin $ (\i -> pStateF "detune" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat detunebus :: Pattern Int -> Pattern Double -> ControlPattern detunebus busid pat = (pF "detune" pat) # (pI "^detune" busid) + detunerecv :: Pattern Int -> ControlPattern detunerecv busid = pI "^detune" busid -- | noisy fuzzy distortion distort :: Pattern Double -> ControlPattern distort = pF "distort" + distortTake :: String -> [Double] -> ControlPattern distortTake name xs = pStateListF "distort" name xs + distortCount :: String -> ControlPattern -distortCount name = pStateF "distort" name (maybe 0 (+1)) +distortCount name = pStateF "distort" name (maybe 0 (+ 1)) + distortCountTo :: String -> Pattern Double -> Pattern ValueMap -distortCountTo name ipat = innerJoin $ (\i -> pStateF "distort" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +distortCountTo name ipat = innerJoin $ (\i -> pStateF "distort" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat distortbus :: Pattern Int -> Pattern Double -> ControlPattern distortbus busid pat = (pF "distort" pat) # (pI "^distort" busid) + distortrecv :: Pattern Int -> ControlPattern distortrecv busid = pI "^distort" busid -- | DJ filter, below 0.5 is low pass filter, above is high pass filter. djf :: Pattern Double -> ControlPattern djf = pF "djf" + djfTake :: String -> [Double] -> ControlPattern djfTake name xs = pStateListF "djf" name xs + djfCount :: String -> ControlPattern -djfCount name = pStateF "djf" name (maybe 0 (+1)) +djfCount name = pStateF "djf" name (maybe 0 (+ 1)) + djfCountTo :: String -> Pattern Double -> Pattern ValueMap -djfCountTo name ipat = innerJoin $ (\i -> pStateF "djf" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +djfCountTo name ipat = innerJoin $ (\i -> pStateF "djf" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat djfbus :: Pattern Int -> Pattern Double -> ControlPattern djfbus busid pat = (pF "djf" pat) # (pI "^djf" busid) + djfrecv :: Pattern Int -> ControlPattern djfrecv busid = pI "^djf" busid -- | when set to `1` will disable all reverb for this pattern. See `room` and `size` for more information about reverb. dry :: Pattern Double -> ControlPattern dry = pF "dry" + dryTake :: String -> [Double] -> ControlPattern dryTake name xs = pStateListF "dry" name xs + dryCount :: String -> ControlPattern -dryCount name = pStateF "dry" name (maybe 0 (+1)) +dryCount name = pStateF "dry" name (maybe 0 (+ 1)) + dryCountTo :: String -> Pattern Double -> Pattern ValueMap -dryCountTo name ipat = innerJoin $ (\i -> pStateF "dry" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +dryCountTo name ipat = innerJoin $ (\i -> pStateF "dry" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat drybus :: Pattern Int -> Pattern Double -> ControlPattern drybus busid pat = (pF "dry" pat) # (pI "^dry" busid) + dryrecv :: Pattern Int -> ControlPattern dryrecv busid = pI "^dry" busid --- | +-- | dur :: Pattern Double -> ControlPattern dur = pF "dur" + durTake :: String -> [Double] -> ControlPattern durTake name xs = pStateListF "dur" name xs + durCount :: String -> ControlPattern -durCount name = pStateF "dur" name (maybe 0 (+1)) +durCount name = pStateF "dur" name (maybe 0 (+ 1)) + durCountTo :: String -> Pattern Double -> Pattern ValueMap -durCountTo name ipat = innerJoin $ (\i -> pStateF "dur" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +durCountTo name ipat = innerJoin $ (\i -> pStateF "dur" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat durbus :: Pattern Int -> Pattern Double -> ControlPattern durbus busid pat = (pF "dur" pat) # (pI "^dur" busid) + durrecv :: Pattern Int -> ControlPattern durrecv busid = pI "^dur" busid -{- | Similar to `begin`, but cuts the end off samples, shortening them; e.g. - 0.75 to cut off the last quarter of each sample. - - > d1 $ s "bev" >| begin 0.5 >| end "[0.65 0.55]" - - The example above will play the sample two times for cycle, but the second time - will play a shorter segment than the first time, creating a kind of canon effect. --} +-- | Similar to `begin`, but cuts the end off samples, shortening them; e.g. +-- 0.75 to cut off the last quarter of each sample. +-- +-- > d1 $ s "bev" >| begin 0.5 >| end "[0.65 0.55]" +-- +-- The example above will play the sample two times for cycle, but the second time +-- will play a shorter segment than the first time, creating a kind of canon effect. end :: Pattern Double -> ControlPattern end = pF "end" + endTake :: String -> [Double] -> ControlPattern endTake name xs = pStateListF "end" name xs + endCount :: String -> ControlPattern -endCount name = pStateF "end" name (maybe 0 (+1)) +endCount name = pStateF "end" name (maybe 0 (+ 1)) + endCountTo :: String -> Pattern Double -> Pattern ValueMap -endCountTo name ipat = innerJoin $ (\i -> pStateF "end" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +endCountTo name ipat = innerJoin $ (\i -> pStateF "end" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat endbus :: Pattern Int -> Pattern Double -> ControlPattern endbus _ _ = error $ "Control parameter 'end' can't be sent to a bus." @@ -974,42 +1171,53 @@ endbus _ _ = error $ "Control parameter 'end' can't be sent to a bus." -- | Spectral enhance enhance :: Pattern Double -> ControlPattern enhance = pF "enhance" + enhanceTake :: String -> [Double] -> ControlPattern enhanceTake name xs = pStateListF "enhance" name xs + enhanceCount :: String -> ControlPattern -enhanceCount name = pStateF "enhance" name (maybe 0 (+1)) +enhanceCount name = pStateF "enhance" name (maybe 0 (+ 1)) + enhanceCountTo :: String -> Pattern Double -> Pattern ValueMap -enhanceCountTo name ipat = innerJoin $ (\i -> pStateF "enhance" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +enhanceCountTo name ipat = innerJoin $ (\i -> pStateF "enhance" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat enhancebus :: Pattern Int -> Pattern Double -> ControlPattern enhancebus busid pat = (pF "enhance" pat) # (pI "^enhance" busid) + enhancerecv :: Pattern Int -> ControlPattern enhancerecv busid = pI "^enhance" busid --- | +-- | expression :: Pattern Double -> ControlPattern expression = pF "expression" + expressionTake :: String -> [Double] -> ControlPattern expressionTake name xs = pStateListF "expression" name xs + expressionCount :: String -> ControlPattern -expressionCount name = pStateF "expression" name (maybe 0 (+1)) +expressionCount name = pStateF "expression" name (maybe 0 (+ 1)) + expressionCountTo :: String -> Pattern Double -> Pattern ValueMap -expressionCountTo name ipat = innerJoin $ (\i -> pStateF "expression" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +expressionCountTo name ipat = innerJoin $ (\i -> pStateF "expression" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat expressionbus :: Pattern Int -> Pattern Double -> ControlPattern expressionbus busid pat = (pF "expression" pat) # (pI "^expression" busid) + expressionrecv :: Pattern Int -> ControlPattern expressionrecv busid = pI "^expression" busid -- | As with fadeTime, but controls the fade in time of the grain envelope. Not used if the grain begins at position 0 in the sample. fadeInTime :: Pattern Double -> ControlPattern fadeInTime = pF "fadeInTime" + fadeInTimeTake :: String -> [Double] -> ControlPattern fadeInTimeTake name xs = pStateListF "fadeInTime" name xs + fadeInTimeCount :: String -> ControlPattern -fadeInTimeCount name = pStateF "fadeInTime" name (maybe 0 (+1)) +fadeInTimeCount name = pStateF "fadeInTime" name (maybe 0 (+ 1)) + fadeInTimeCountTo :: String -> Pattern Double -> Pattern ValueMap -fadeInTimeCountTo name ipat = innerJoin $ (\i -> pStateF "fadeInTime" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +fadeInTimeCountTo name ipat = innerJoin $ (\i -> pStateF "fadeInTime" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat fadeInTimebus :: Pattern Int -> Pattern Double -> ControlPattern fadeInTimebus _ _ = error $ "Control parameter 'fadeInTime' can't be sent to a bus." @@ -1017,38 +1225,47 @@ fadeInTimebus _ _ = error $ "Control parameter 'fadeInTime' can't be sent to a b -- | Used when using begin/end or chop/striate and friends, to change the fade out time of the 'grain' envelope. fadeTime :: Pattern Double -> ControlPattern fadeTime = pF "fadeTime" + fadeTimeTake :: String -> [Double] -> ControlPattern fadeTimeTake name xs = pStateListF "fadeTime" name xs + fadeTimeCount :: String -> ControlPattern -fadeTimeCount name = pStateF "fadeTime" name (maybe 0 (+1)) +fadeTimeCount name = pStateF "fadeTime" name (maybe 0 (+ 1)) + fadeTimeCountTo :: String -> Pattern Double -> Pattern ValueMap -fadeTimeCountTo name ipat = innerJoin $ (\i -> pStateF "fadeTime" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +fadeTimeCountTo name ipat = innerJoin $ (\i -> pStateF "fadeTime" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat fadeTimebus :: Pattern Int -> Pattern Double -> ControlPattern fadeTimebus _ _ = error $ "Control parameter 'fadeTime' can't be sent to a bus." --- | +-- | frameRate :: Pattern Double -> ControlPattern frameRate = pF "frameRate" + frameRateTake :: String -> [Double] -> ControlPattern frameRateTake name xs = pStateListF "frameRate" name xs + frameRateCount :: String -> ControlPattern -frameRateCount name = pStateF "frameRate" name (maybe 0 (+1)) +frameRateCount name = pStateF "frameRate" name (maybe 0 (+ 1)) + frameRateCountTo :: String -> Pattern Double -> Pattern ValueMap -frameRateCountTo name ipat = innerJoin $ (\i -> pStateF "frameRate" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +frameRateCountTo name ipat = innerJoin $ (\i -> pStateF "frameRate" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat frameRatebus :: Pattern Int -> Pattern Double -> ControlPattern frameRatebus _ _ = error $ "Control parameter 'frameRate' can't be sent to a bus." --- | +-- | frames :: Pattern Double -> ControlPattern frames = pF "frames" + framesTake :: String -> [Double] -> ControlPattern framesTake name xs = pStateListF "frames" name xs + framesCount :: String -> ControlPattern -framesCount name = pStateF "frames" name (maybe 0 (+1)) +framesCount name = pStateF "frames" name (maybe 0 (+ 1)) + framesCountTo :: String -> Pattern Double -> Pattern ValueMap -framesCountTo name ipat = innerJoin $ (\i -> pStateF "frames" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +framesCountTo name ipat = innerJoin $ (\i -> pStateF "frames" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat framesbus :: Pattern Int -> Pattern Double -> ControlPattern framesbus _ _ = error $ "Control parameter 'frames' can't be sent to a bus." @@ -1056,222 +1273,275 @@ framesbus _ _ = error $ "Control parameter 'frames' can't be sent to a bus." -- | Spectral freeze freeze :: Pattern Double -> ControlPattern freeze = pF "freeze" + freezeTake :: String -> [Double] -> ControlPattern freezeTake name xs = pStateListF "freeze" name xs + freezeCount :: String -> ControlPattern -freezeCount name = pStateF "freeze" name (maybe 0 (+1)) +freezeCount name = pStateF "freeze" name (maybe 0 (+ 1)) + freezeCountTo :: String -> Pattern Double -> Pattern ValueMap -freezeCountTo name ipat = innerJoin $ (\i -> pStateF "freeze" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +freezeCountTo name ipat = innerJoin $ (\i -> pStateF "freeze" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat freezebus :: Pattern Int -> Pattern Double -> ControlPattern freezebus busid pat = (pF "freeze" pat) # (pI "^freeze" busid) + freezerecv :: Pattern Int -> ControlPattern freezerecv busid = pI "^freeze" busid --- | +-- | freq :: Pattern Double -> ControlPattern freq = pF "freq" + freqTake :: String -> [Double] -> ControlPattern freqTake name xs = pStateListF "freq" name xs + freqCount :: String -> ControlPattern -freqCount name = pStateF "freq" name (maybe 0 (+1)) +freqCount name = pStateF "freq" name (maybe 0 (+ 1)) + freqCountTo :: String -> Pattern Double -> Pattern ValueMap -freqCountTo name ipat = innerJoin $ (\i -> pStateF "freq" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +freqCountTo name ipat = innerJoin $ (\i -> pStateF "freq" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat freqbus :: Pattern Int -> Pattern Double -> ControlPattern freqbus busid pat = (pF "freq" pat) # (pI "^freq" busid) + freqrecv :: Pattern Int -> ControlPattern freqrecv busid = pI "^freq" busid -- | for internal sound routing from :: Pattern Double -> ControlPattern from = pF "from" + fromTake :: String -> [Double] -> ControlPattern fromTake name xs = pStateListF "from" name xs + fromCount :: String -> ControlPattern -fromCount name = pStateF "from" name (maybe 0 (+1)) +fromCount name = pStateF "from" name (maybe 0 (+ 1)) + fromCountTo :: String -> Pattern Double -> Pattern ValueMap -fromCountTo name ipat = innerJoin $ (\i -> pStateF "from" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +fromCountTo name ipat = innerJoin $ (\i -> pStateF "from" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat frombus :: Pattern Int -> Pattern Double -> ControlPattern frombus busid pat = (pF "from" pat) # (pI "^from" busid) + fromrecv :: Pattern Int -> ControlPattern fromrecv busid = pI "^from" busid -- | frequency shifter fshift :: Pattern Double -> ControlPattern fshift = pF "fshift" + fshiftTake :: String -> [Double] -> ControlPattern fshiftTake name xs = pStateListF "fshift" name xs + fshiftCount :: String -> ControlPattern -fshiftCount name = pStateF "fshift" name (maybe 0 (+1)) +fshiftCount name = pStateF "fshift" name (maybe 0 (+ 1)) + fshiftCountTo :: String -> Pattern Double -> Pattern ValueMap -fshiftCountTo name ipat = innerJoin $ (\i -> pStateF "fshift" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +fshiftCountTo name ipat = innerJoin $ (\i -> pStateF "fshift" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat fshiftbus :: Pattern Int -> Pattern Double -> ControlPattern fshiftbus busid pat = (pF "fshift" pat) # (pI "^fshift" busid) + fshiftrecv :: Pattern Int -> ControlPattern fshiftrecv busid = pI "^fshift" busid -- | frequency shifter fshiftnote :: Pattern Double -> ControlPattern fshiftnote = pF "fshiftnote" + fshiftnoteTake :: String -> [Double] -> ControlPattern fshiftnoteTake name xs = pStateListF "fshiftnote" name xs + fshiftnoteCount :: String -> ControlPattern -fshiftnoteCount name = pStateF "fshiftnote" name (maybe 0 (+1)) +fshiftnoteCount name = pStateF "fshiftnote" name (maybe 0 (+ 1)) + fshiftnoteCountTo :: String -> Pattern Double -> Pattern ValueMap -fshiftnoteCountTo name ipat = innerJoin $ (\i -> pStateF "fshiftnote" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +fshiftnoteCountTo name ipat = innerJoin $ (\i -> pStateF "fshiftnote" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat fshiftnotebus :: Pattern Int -> Pattern Double -> ControlPattern fshiftnotebus busid pat = (pF "fshiftnote" pat) # (pI "^fshiftnote" busid) + fshiftnoterecv :: Pattern Int -> ControlPattern fshiftnoterecv busid = pI "^fshiftnote" busid -- | frequency shifter fshiftphase :: Pattern Double -> ControlPattern fshiftphase = pF "fshiftphase" + fshiftphaseTake :: String -> [Double] -> ControlPattern fshiftphaseTake name xs = pStateListF "fshiftphase" name xs + fshiftphaseCount :: String -> ControlPattern -fshiftphaseCount name = pStateF "fshiftphase" name (maybe 0 (+1)) +fshiftphaseCount name = pStateF "fshiftphase" name (maybe 0 (+ 1)) + fshiftphaseCountTo :: String -> Pattern Double -> Pattern ValueMap -fshiftphaseCountTo name ipat = innerJoin $ (\i -> pStateF "fshiftphase" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +fshiftphaseCountTo name ipat = innerJoin $ (\i -> pStateF "fshiftphase" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat fshiftphasebus :: Pattern Int -> Pattern Double -> ControlPattern fshiftphasebus busid pat = (pF "fshiftphase" pat) # (pI "^fshiftphase" busid) + fshiftphaserecv :: Pattern Int -> ControlPattern fshiftphaserecv busid = pI "^fshiftphase" busid -{- | Used to control the amplitude (volume) of the sound. Values less than 1 -make the sound quieter and values greater than 1 make the sound louder. - -@gain@ uses a power function, so the volume change around 1 is subtle, but it -gets more noticeable as it increases or decreases. Typical values for @gain@ are -between 0 and 1.5. - -For the linear equivalent, see 'amp'. - -> d1 $ s "arpy" # gain 0.8 - -This plays the first arpy sample at a quieter level than the default. - -> d1 $ s "ab*16" # gain (range 0.8 1.3 $ sine) - -This plays a hihat sound, 16 times per cycle, with a @gain@ moving from 0.8 to 1.3 -following a sine wave. --} +-- | Used to control the amplitude (volume) of the sound. Values less than 1 +-- make the sound quieter and values greater than 1 make the sound louder. +-- +-- @gain@ uses a power function, so the volume change around 1 is subtle, but it +-- gets more noticeable as it increases or decreases. Typical values for @gain@ are +-- between 0 and 1.5. +-- +-- For the linear equivalent, see 'amp'. +-- +-- > d1 $ s "arpy" # gain 0.8 +-- +-- This plays the first arpy sample at a quieter level than the default. +-- +-- > d1 $ s "ab*16" # gain (range 0.8 1.3 $ sine) +-- +-- This plays a hihat sound, 16 times per cycle, with a @gain@ moving from 0.8 to 1.3 +-- following a sine wave. gain :: Pattern Double -> ControlPattern gain = pF "gain" + gainTake :: String -> [Double] -> ControlPattern gainTake name xs = pStateListF "gain" name xs + gainCount :: String -> ControlPattern -gainCount name = pStateF "gain" name (maybe 0 (+1)) +gainCount name = pStateF "gain" name (maybe 0 (+ 1)) + gainCountTo :: String -> Pattern Double -> Pattern ValueMap -gainCountTo name ipat = innerJoin $ (\i -> pStateF "gain" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +gainCountTo name ipat = innerJoin $ (\i -> pStateF "gain" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat gainbus :: Pattern Int -> Pattern Double -> ControlPattern gainbus _ _ = error $ "Control parameter 'gain' can't be sent to a bus." --- | +-- | gate :: Pattern Double -> ControlPattern gate = pF "gate" + gateTake :: String -> [Double] -> ControlPattern gateTake name xs = pStateListF "gate" name xs + gateCount :: String -> ControlPattern -gateCount name = pStateF "gate" name (maybe 0 (+1)) +gateCount name = pStateF "gate" name (maybe 0 (+ 1)) + gateCountTo :: String -> Pattern Double -> Pattern ValueMap -gateCountTo name ipat = innerJoin $ (\i -> pStateF "gate" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +gateCountTo name ipat = innerJoin $ (\i -> pStateF "gate" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat gatebus :: Pattern Int -> Pattern Double -> ControlPattern gatebus busid pat = (pF "gate" pat) # (pI "^gate" busid) + gaterecv :: Pattern Int -> ControlPattern gaterecv busid = pI "^gate" busid --- | +-- | harmonic :: Pattern Double -> ControlPattern harmonic = pF "harmonic" + harmonicTake :: String -> [Double] -> ControlPattern harmonicTake name xs = pStateListF "harmonic" name xs + harmonicCount :: String -> ControlPattern -harmonicCount name = pStateF "harmonic" name (maybe 0 (+1)) +harmonicCount name = pStateF "harmonic" name (maybe 0 (+ 1)) + harmonicCountTo :: String -> Pattern Double -> Pattern ValueMap -harmonicCountTo name ipat = innerJoin $ (\i -> pStateF "harmonic" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +harmonicCountTo name ipat = innerJoin $ (\i -> pStateF "harmonic" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat harmonicbus :: Pattern Int -> Pattern Double -> ControlPattern harmonicbus busid pat = (pF "harmonic" pat) # (pI "^harmonic" busid) + harmonicrecv :: Pattern Int -> ControlPattern harmonicrecv busid = pI "^harmonic" busid --- | +-- | hatgrain :: Pattern Double -> ControlPattern hatgrain = pF "hatgrain" + hatgrainTake :: String -> [Double] -> ControlPattern hatgrainTake name xs = pStateListF "hatgrain" name xs + hatgrainCount :: String -> ControlPattern -hatgrainCount name = pStateF "hatgrain" name (maybe 0 (+1)) +hatgrainCount name = pStateF "hatgrain" name (maybe 0 (+ 1)) + hatgrainCountTo :: String -> Pattern Double -> Pattern ValueMap -hatgrainCountTo name ipat = innerJoin $ (\i -> pStateF "hatgrain" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +hatgrainCountTo name ipat = innerJoin $ (\i -> pStateF "hatgrain" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat hatgrainbus :: Pattern Int -> Pattern Double -> ControlPattern hatgrainbus busid pat = (pF "hatgrain" pat) # (pI "^hatgrain" busid) + hatgrainrecv :: Pattern Int -> ControlPattern hatgrainrecv busid = pI "^hatgrain" busid -- | High pass sort of spectral filter hbrick :: Pattern Double -> ControlPattern hbrick = pF "hbrick" + hbrickTake :: String -> [Double] -> ControlPattern hbrickTake name xs = pStateListF "hbrick" name xs + hbrickCount :: String -> ControlPattern -hbrickCount name = pStateF "hbrick" name (maybe 0 (+1)) +hbrickCount name = pStateF "hbrick" name (maybe 0 (+ 1)) + hbrickCountTo :: String -> Pattern Double -> Pattern ValueMap -hbrickCountTo name ipat = innerJoin $ (\i -> pStateF "hbrick" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +hbrickCountTo name ipat = innerJoin $ (\i -> pStateF "hbrick" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat hbrickbus :: Pattern Int -> Pattern Double -> ControlPattern hbrickbus busid pat = (pF "hbrick" pat) # (pI "^hbrick" busid) + hbrickrecv :: Pattern Int -> ControlPattern hbrickrecv busid = pI "^hbrick" busid -- | a pattern of numbers from 0 to 1. Applies the cutoff frequency of the high-pass filter. Also has alias @hpf@ hcutoff :: Pattern Double -> ControlPattern hcutoff = pF "hcutoff" + hcutoffTake :: String -> [Double] -> ControlPattern hcutoffTake name xs = pStateListF "hcutoff" name xs + hcutoffCount :: String -> ControlPattern -hcutoffCount name = pStateF "hcutoff" name (maybe 0 (+1)) +hcutoffCount name = pStateF "hcutoff" name (maybe 0 (+ 1)) + hcutoffCountTo :: String -> Pattern Double -> Pattern ValueMap -hcutoffCountTo name ipat = innerJoin $ (\i -> pStateF "hcutoff" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +hcutoffCountTo name ipat = innerJoin $ (\i -> pStateF "hcutoff" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat hcutoffbus :: Pattern Int -> Pattern Double -> ControlPattern hcutoffbus busid pat = (pF "hcutoff" pat) # (pI "^hcutoff" busid) + hcutoffrecv :: Pattern Int -> ControlPattern hcutoffrecv busid = pI "^hcutoff" busid -- | a pattern of numbers to specify the hold time (in seconds) of an envelope applied to each sample. Only takes effect if `attack` and `release` are also specified. hold :: Pattern Double -> ControlPattern hold = pF "hold" + holdTake :: String -> [Double] -> ControlPattern holdTake name xs = pStateListF "hold" name xs + holdCount :: String -> ControlPattern -holdCount name = pStateF "hold" name (maybe 0 (+1)) +holdCount name = pStateF "hold" name (maybe 0 (+ 1)) + holdCountTo :: String -> Pattern Double -> Pattern ValueMap -holdCountTo name ipat = innerJoin $ (\i -> pStateF "hold" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +holdCountTo name ipat = innerJoin $ (\i -> pStateF "hold" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat holdbus :: Pattern Int -> Pattern Double -> ControlPattern holdbus busid pat = (pF "hold" pat) # (pI "^hold" busid) + holdrecv :: Pattern Int -> ControlPattern holdrecv busid = pI "^hold" busid --- | +-- | hours :: Pattern Double -> ControlPattern hours = pF "hours" + hoursTake :: String -> [Double] -> ControlPattern hoursTake name xs = pStateListF "hours" name xs + hoursCount :: String -> ControlPattern -hoursCount name = pStateF "hours" name (maybe 0 (+1)) +hoursCount name = pStateF "hours" name (maybe 0 (+ 1)) + hoursCountTo :: String -> Pattern Double -> Pattern ValueMap -hoursCountTo name ipat = innerJoin $ (\i -> pStateF "hours" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +hoursCountTo name ipat = innerJoin $ (\i -> pStateF "hours" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat hoursbus :: Pattern Int -> Pattern Double -> ControlPattern hoursbus _ _ = error $ "Control parameter 'hours' can't be sent to a bus." @@ -1279,533 +1549,672 @@ hoursbus _ _ = error $ "Control parameter 'hours' can't be sent to a bus." -- | a pattern of numbers from 0 to 1. Applies the resonance of the high-pass filter. Has alias @hpq@ hresonance :: Pattern Double -> ControlPattern hresonance = pF "hresonance" + hresonanceTake :: String -> [Double] -> ControlPattern hresonanceTake name xs = pStateListF "hresonance" name xs + hresonanceCount :: String -> ControlPattern -hresonanceCount name = pStateF "hresonance" name (maybe 0 (+1)) +hresonanceCount name = pStateF "hresonance" name (maybe 0 (+ 1)) + hresonanceCountTo :: String -> Pattern Double -> Pattern ValueMap -hresonanceCountTo name ipat = innerJoin $ (\i -> pStateF "hresonance" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +hresonanceCountTo name ipat = innerJoin $ (\i -> pStateF "hresonance" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat hresonancebus :: Pattern Int -> Pattern Double -> ControlPattern hresonancebus busid pat = (pF "hresonance" pat) # (pI "^hresonance" busid) + hresonancerecv :: Pattern Int -> ControlPattern hresonancerecv busid = pI "^hresonance" busid --- | +-- | imag :: Pattern Double -> ControlPattern imag = pF "imag" + imagTake :: String -> [Double] -> ControlPattern imagTake name xs = pStateListF "imag" name xs + imagCount :: String -> ControlPattern -imagCount name = pStateF "imag" name (maybe 0 (+1)) +imagCount name = pStateF "imag" name (maybe 0 (+ 1)) + imagCountTo :: String -> Pattern Double -> Pattern ValueMap -imagCountTo name ipat = innerJoin $ (\i -> pStateF "imag" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +imagCountTo name ipat = innerJoin $ (\i -> pStateF "imag" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat imagbus :: Pattern Int -> Pattern Double -> ControlPattern imagbus busid pat = (pF "imag" pat) # (pI "^imag" busid) + imagrecv :: Pattern Int -> ControlPattern imagrecv busid = pI "^imag" busid --- | +-- | kcutoff :: Pattern Double -> ControlPattern kcutoff = pF "kcutoff" + kcutoffTake :: String -> [Double] -> ControlPattern kcutoffTake name xs = pStateListF "kcutoff" name xs + kcutoffCount :: String -> ControlPattern -kcutoffCount name = pStateF "kcutoff" name (maybe 0 (+1)) +kcutoffCount name = pStateF "kcutoff" name (maybe 0 (+ 1)) + kcutoffCountTo :: String -> Pattern Double -> Pattern ValueMap -kcutoffCountTo name ipat = innerJoin $ (\i -> pStateF "kcutoff" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +kcutoffCountTo name ipat = innerJoin $ (\i -> pStateF "kcutoff" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat kcutoffbus :: Pattern Int -> Pattern Double -> ControlPattern kcutoffbus busid pat = (pF "kcutoff" pat) # (pI "^kcutoff" busid) + kcutoffrecv :: Pattern Int -> ControlPattern kcutoffrecv busid = pI "^kcutoff" busid -- | shape/bass enhancer krush :: Pattern Double -> ControlPattern krush = pF "krush" + krushTake :: String -> [Double] -> ControlPattern krushTake name xs = pStateListF "krush" name xs + krushCount :: String -> ControlPattern -krushCount name = pStateF "krush" name (maybe 0 (+1)) +krushCount name = pStateF "krush" name (maybe 0 (+ 1)) + krushCountTo :: String -> Pattern Double -> Pattern ValueMap -krushCountTo name ipat = innerJoin $ (\i -> pStateF "krush" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +krushCountTo name ipat = innerJoin $ (\i -> pStateF "krush" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat krushbus :: Pattern Int -> Pattern Double -> ControlPattern krushbus busid pat = (pF "krush" pat) # (pI "^krush" busid) + krushrecv :: Pattern Int -> ControlPattern krushrecv busid = pI "^krush" busid --- | +-- | lagogo :: Pattern Double -> ControlPattern lagogo = pF "lagogo" + lagogoTake :: String -> [Double] -> ControlPattern lagogoTake name xs = pStateListF "lagogo" name xs + lagogoCount :: String -> ControlPattern -lagogoCount name = pStateF "lagogo" name (maybe 0 (+1)) +lagogoCount name = pStateF "lagogo" name (maybe 0 (+ 1)) + lagogoCountTo :: String -> Pattern Double -> Pattern ValueMap -lagogoCountTo name ipat = innerJoin $ (\i -> pStateF "lagogo" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +lagogoCountTo name ipat = innerJoin $ (\i -> pStateF "lagogo" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat lagogobus :: Pattern Int -> Pattern Double -> ControlPattern lagogobus busid pat = (pF "lagogo" pat) # (pI "^lagogo" busid) + lagogorecv :: Pattern Int -> ControlPattern lagogorecv busid = pI "^lagogo" busid -- | Low pass sort of spectral filter lbrick :: Pattern Double -> ControlPattern lbrick = pF "lbrick" + lbrickTake :: String -> [Double] -> ControlPattern lbrickTake name xs = pStateListF "lbrick" name xs + lbrickCount :: String -> ControlPattern -lbrickCount name = pStateF "lbrick" name (maybe 0 (+1)) +lbrickCount name = pStateF "lbrick" name (maybe 0 (+ 1)) + lbrickCountTo :: String -> Pattern Double -> Pattern ValueMap -lbrickCountTo name ipat = innerJoin $ (\i -> pStateF "lbrick" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +lbrickCountTo name ipat = innerJoin $ (\i -> pStateF "lbrick" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat lbrickbus :: Pattern Int -> Pattern Double -> ControlPattern lbrickbus busid pat = (pF "lbrick" pat) # (pI "^lbrick" busid) + lbrickrecv :: Pattern Int -> ControlPattern lbrickrecv busid = pI "^lbrick" busid --- | +-- | lclap :: Pattern Double -> ControlPattern lclap = pF "lclap" + lclapTake :: String -> [Double] -> ControlPattern lclapTake name xs = pStateListF "lclap" name xs + lclapCount :: String -> ControlPattern -lclapCount name = pStateF "lclap" name (maybe 0 (+1)) +lclapCount name = pStateF "lclap" name (maybe 0 (+ 1)) + lclapCountTo :: String -> Pattern Double -> Pattern ValueMap -lclapCountTo name ipat = innerJoin $ (\i -> pStateF "lclap" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +lclapCountTo name ipat = innerJoin $ (\i -> pStateF "lclap" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat lclapbus :: Pattern Int -> Pattern Double -> ControlPattern lclapbus busid pat = (pF "lclap" pat) # (pI "^lclap" busid) + lclaprecv :: Pattern Int -> ControlPattern lclaprecv busid = pI "^lclap" busid --- | +-- | lclaves :: Pattern Double -> ControlPattern lclaves = pF "lclaves" + lclavesTake :: String -> [Double] -> ControlPattern lclavesTake name xs = pStateListF "lclaves" name xs + lclavesCount :: String -> ControlPattern -lclavesCount name = pStateF "lclaves" name (maybe 0 (+1)) +lclavesCount name = pStateF "lclaves" name (maybe 0 (+ 1)) + lclavesCountTo :: String -> Pattern Double -> Pattern ValueMap -lclavesCountTo name ipat = innerJoin $ (\i -> pStateF "lclaves" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +lclavesCountTo name ipat = innerJoin $ (\i -> pStateF "lclaves" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat lclavesbus :: Pattern Int -> Pattern Double -> ControlPattern lclavesbus busid pat = (pF "lclaves" pat) # (pI "^lclaves" busid) + lclavesrecv :: Pattern Int -> ControlPattern lclavesrecv busid = pI "^lclaves" busid --- | +-- | lclhat :: Pattern Double -> ControlPattern lclhat = pF "lclhat" + lclhatTake :: String -> [Double] -> ControlPattern lclhatTake name xs = pStateListF "lclhat" name xs + lclhatCount :: String -> ControlPattern -lclhatCount name = pStateF "lclhat" name (maybe 0 (+1)) +lclhatCount name = pStateF "lclhat" name (maybe 0 (+ 1)) + lclhatCountTo :: String -> Pattern Double -> Pattern ValueMap -lclhatCountTo name ipat = innerJoin $ (\i -> pStateF "lclhat" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +lclhatCountTo name ipat = innerJoin $ (\i -> pStateF "lclhat" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat lclhatbus :: Pattern Int -> Pattern Double -> ControlPattern lclhatbus busid pat = (pF "lclhat" pat) # (pI "^lclhat" busid) + lclhatrecv :: Pattern Int -> ControlPattern lclhatrecv busid = pI "^lclhat" busid --- | +-- | lcrash :: Pattern Double -> ControlPattern lcrash = pF "lcrash" + lcrashTake :: String -> [Double] -> ControlPattern lcrashTake name xs = pStateListF "lcrash" name xs + lcrashCount :: String -> ControlPattern -lcrashCount name = pStateF "lcrash" name (maybe 0 (+1)) +lcrashCount name = pStateF "lcrash" name (maybe 0 (+ 1)) + lcrashCountTo :: String -> Pattern Double -> Pattern ValueMap -lcrashCountTo name ipat = innerJoin $ (\i -> pStateF "lcrash" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +lcrashCountTo name ipat = innerJoin $ (\i -> pStateF "lcrash" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat lcrashbus :: Pattern Int -> Pattern Double -> ControlPattern lcrashbus busid pat = (pF "lcrash" pat) # (pI "^lcrash" busid) + lcrashrecv :: Pattern Int -> ControlPattern lcrashrecv busid = pI "^lcrash" busid -- | controls the amount of overlap between two adjacent sounds legato :: Pattern Double -> ControlPattern legato = pF "legato" + legatoTake :: String -> [Double] -> ControlPattern legatoTake name xs = pStateListF "legato" name xs + legatoCount :: String -> ControlPattern -legatoCount name = pStateF "legato" name (maybe 0 (+1)) +legatoCount name = pStateF "legato" name (maybe 0 (+ 1)) + legatoCountTo :: String -> Pattern Double -> Pattern ValueMap -legatoCountTo name ipat = innerJoin $ (\i -> pStateF "legato" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +legatoCountTo name ipat = innerJoin $ (\i -> pStateF "legato" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat legatobus :: Pattern Int -> Pattern Double -> ControlPattern legatobus _ _ = error $ "Control parameter 'legato' can't be sent to a bus." --- | +-- | leslie :: Pattern Double -> ControlPattern leslie = pF "leslie" + leslieTake :: String -> [Double] -> ControlPattern leslieTake name xs = pStateListF "leslie" name xs + leslieCount :: String -> ControlPattern -leslieCount name = pStateF "leslie" name (maybe 0 (+1)) +leslieCount name = pStateF "leslie" name (maybe 0 (+ 1)) + leslieCountTo :: String -> Pattern Double -> Pattern ValueMap -leslieCountTo name ipat = innerJoin $ (\i -> pStateF "leslie" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +leslieCountTo name ipat = innerJoin $ (\i -> pStateF "leslie" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat lesliebus :: Pattern Int -> Pattern Double -> ControlPattern lesliebus busid pat = (pF "leslie" pat) # (pI "^leslie" busid) + leslierecv :: Pattern Int -> ControlPattern leslierecv busid = pI "^leslie" busid --- | +-- | lfo :: Pattern Double -> ControlPattern lfo = pF "lfo" + lfoTake :: String -> [Double] -> ControlPattern lfoTake name xs = pStateListF "lfo" name xs + lfoCount :: String -> ControlPattern -lfoCount name = pStateF "lfo" name (maybe 0 (+1)) +lfoCount name = pStateF "lfo" name (maybe 0 (+ 1)) + lfoCountTo :: String -> Pattern Double -> Pattern ValueMap -lfoCountTo name ipat = innerJoin $ (\i -> pStateF "lfo" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +lfoCountTo name ipat = innerJoin $ (\i -> pStateF "lfo" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat lfobus :: Pattern Int -> Pattern Double -> ControlPattern lfobus busid pat = (pF "lfo" pat) # (pI "^lfo" busid) + lforecv :: Pattern Int -> ControlPattern lforecv busid = pI "^lfo" busid --- | +-- | lfocutoffint :: Pattern Double -> ControlPattern lfocutoffint = pF "lfocutoffint" + lfocutoffintTake :: String -> [Double] -> ControlPattern lfocutoffintTake name xs = pStateListF "lfocutoffint" name xs + lfocutoffintCount :: String -> ControlPattern -lfocutoffintCount name = pStateF "lfocutoffint" name (maybe 0 (+1)) +lfocutoffintCount name = pStateF "lfocutoffint" name (maybe 0 (+ 1)) + lfocutoffintCountTo :: String -> Pattern Double -> Pattern ValueMap -lfocutoffintCountTo name ipat = innerJoin $ (\i -> pStateF "lfocutoffint" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +lfocutoffintCountTo name ipat = innerJoin $ (\i -> pStateF "lfocutoffint" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat lfocutoffintbus :: Pattern Int -> Pattern Double -> ControlPattern lfocutoffintbus busid pat = (pF "lfocutoffint" pat) # (pI "^lfocutoffint" busid) + lfocutoffintrecv :: Pattern Int -> ControlPattern lfocutoffintrecv busid = pI "^lfocutoffint" busid --- | +-- | lfodelay :: Pattern Double -> ControlPattern lfodelay = pF "lfodelay" + lfodelayTake :: String -> [Double] -> ControlPattern lfodelayTake name xs = pStateListF "lfodelay" name xs + lfodelayCount :: String -> ControlPattern -lfodelayCount name = pStateF "lfodelay" name (maybe 0 (+1)) +lfodelayCount name = pStateF "lfodelay" name (maybe 0 (+ 1)) + lfodelayCountTo :: String -> Pattern Double -> Pattern ValueMap -lfodelayCountTo name ipat = innerJoin $ (\i -> pStateF "lfodelay" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +lfodelayCountTo name ipat = innerJoin $ (\i -> pStateF "lfodelay" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat lfodelaybus :: Pattern Int -> Pattern Double -> ControlPattern lfodelaybus busid pat = (pF "lfodelay" pat) # (pI "^lfodelay" busid) + lfodelayrecv :: Pattern Int -> ControlPattern lfodelayrecv busid = pI "^lfodelay" busid --- | +-- | lfoint :: Pattern Double -> ControlPattern lfoint = pF "lfoint" + lfointTake :: String -> [Double] -> ControlPattern lfointTake name xs = pStateListF "lfoint" name xs + lfointCount :: String -> ControlPattern -lfointCount name = pStateF "lfoint" name (maybe 0 (+1)) +lfointCount name = pStateF "lfoint" name (maybe 0 (+ 1)) + lfointCountTo :: String -> Pattern Double -> Pattern ValueMap -lfointCountTo name ipat = innerJoin $ (\i -> pStateF "lfoint" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +lfointCountTo name ipat = innerJoin $ (\i -> pStateF "lfoint" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat lfointbus :: Pattern Int -> Pattern Double -> ControlPattern lfointbus busid pat = (pF "lfoint" pat) # (pI "^lfoint" busid) + lfointrecv :: Pattern Int -> ControlPattern lfointrecv busid = pI "^lfoint" busid --- | +-- | lfopitchint :: Pattern Double -> ControlPattern lfopitchint = pF "lfopitchint" + lfopitchintTake :: String -> [Double] -> ControlPattern lfopitchintTake name xs = pStateListF "lfopitchint" name xs + lfopitchintCount :: String -> ControlPattern -lfopitchintCount name = pStateF "lfopitchint" name (maybe 0 (+1)) +lfopitchintCount name = pStateF "lfopitchint" name (maybe 0 (+ 1)) + lfopitchintCountTo :: String -> Pattern Double -> Pattern ValueMap -lfopitchintCountTo name ipat = innerJoin $ (\i -> pStateF "lfopitchint" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +lfopitchintCountTo name ipat = innerJoin $ (\i -> pStateF "lfopitchint" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat lfopitchintbus :: Pattern Int -> Pattern Double -> ControlPattern lfopitchintbus busid pat = (pF "lfopitchint" pat) # (pI "^lfopitchint" busid) + lfopitchintrecv :: Pattern Int -> ControlPattern lfopitchintrecv busid = pI "^lfopitchint" busid --- | +-- | lfoshape :: Pattern Double -> ControlPattern lfoshape = pF "lfoshape" + lfoshapeTake :: String -> [Double] -> ControlPattern lfoshapeTake name xs = pStateListF "lfoshape" name xs + lfoshapeCount :: String -> ControlPattern -lfoshapeCount name = pStateF "lfoshape" name (maybe 0 (+1)) +lfoshapeCount name = pStateF "lfoshape" name (maybe 0 (+ 1)) + lfoshapeCountTo :: String -> Pattern Double -> Pattern ValueMap -lfoshapeCountTo name ipat = innerJoin $ (\i -> pStateF "lfoshape" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +lfoshapeCountTo name ipat = innerJoin $ (\i -> pStateF "lfoshape" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat lfoshapebus :: Pattern Int -> Pattern Double -> ControlPattern lfoshapebus busid pat = (pF "lfoshape" pat) # (pI "^lfoshape" busid) + lfoshaperecv :: Pattern Int -> ControlPattern lfoshaperecv busid = pI "^lfoshape" busid --- | +-- | lfosync :: Pattern Double -> ControlPattern lfosync = pF "lfosync" + lfosyncTake :: String -> [Double] -> ControlPattern lfosyncTake name xs = pStateListF "lfosync" name xs + lfosyncCount :: String -> ControlPattern -lfosyncCount name = pStateF "lfosync" name (maybe 0 (+1)) +lfosyncCount name = pStateF "lfosync" name (maybe 0 (+ 1)) + lfosyncCountTo :: String -> Pattern Double -> Pattern ValueMap -lfosyncCountTo name ipat = innerJoin $ (\i -> pStateF "lfosync" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +lfosyncCountTo name ipat = innerJoin $ (\i -> pStateF "lfosync" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat lfosyncbus :: Pattern Int -> Pattern Double -> ControlPattern lfosyncbus busid pat = (pF "lfosync" pat) # (pI "^lfosync" busid) + lfosyncrecv :: Pattern Int -> ControlPattern lfosyncrecv busid = pI "^lfosync" busid --- | +-- | lhitom :: Pattern Double -> ControlPattern lhitom = pF "lhitom" + lhitomTake :: String -> [Double] -> ControlPattern lhitomTake name xs = pStateListF "lhitom" name xs + lhitomCount :: String -> ControlPattern -lhitomCount name = pStateF "lhitom" name (maybe 0 (+1)) +lhitomCount name = pStateF "lhitom" name (maybe 0 (+ 1)) + lhitomCountTo :: String -> Pattern Double -> Pattern ValueMap -lhitomCountTo name ipat = innerJoin $ (\i -> pStateF "lhitom" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +lhitomCountTo name ipat = innerJoin $ (\i -> pStateF "lhitom" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat lhitombus :: Pattern Int -> Pattern Double -> ControlPattern lhitombus busid pat = (pF "lhitom" pat) # (pI "^lhitom" busid) + lhitomrecv :: Pattern Int -> ControlPattern lhitomrecv busid = pI "^lhitom" busid --- | +-- | lkick :: Pattern Double -> ControlPattern lkick = pF "lkick" + lkickTake :: String -> [Double] -> ControlPattern lkickTake name xs = pStateListF "lkick" name xs + lkickCount :: String -> ControlPattern -lkickCount name = pStateF "lkick" name (maybe 0 (+1)) +lkickCount name = pStateF "lkick" name (maybe 0 (+ 1)) + lkickCountTo :: String -> Pattern Double -> Pattern ValueMap -lkickCountTo name ipat = innerJoin $ (\i -> pStateF "lkick" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +lkickCountTo name ipat = innerJoin $ (\i -> pStateF "lkick" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat lkickbus :: Pattern Int -> Pattern Double -> ControlPattern lkickbus busid pat = (pF "lkick" pat) # (pI "^lkick" busid) + lkickrecv :: Pattern Int -> ControlPattern lkickrecv busid = pI "^lkick" busid --- | +-- | llotom :: Pattern Double -> ControlPattern llotom = pF "llotom" + llotomTake :: String -> [Double] -> ControlPattern llotomTake name xs = pStateListF "llotom" name xs + llotomCount :: String -> ControlPattern -llotomCount name = pStateF "llotom" name (maybe 0 (+1)) +llotomCount name = pStateF "llotom" name (maybe 0 (+ 1)) + llotomCountTo :: String -> Pattern Double -> Pattern ValueMap -llotomCountTo name ipat = innerJoin $ (\i -> pStateF "llotom" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +llotomCountTo name ipat = innerJoin $ (\i -> pStateF "llotom" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat llotombus :: Pattern Int -> Pattern Double -> ControlPattern llotombus busid pat = (pF "llotom" pat) # (pI "^llotom" busid) + llotomrecv :: Pattern Int -> ControlPattern llotomrecv busid = pI "^llotom" busid -- | A pattern of numbers. Specifies whether delaytime is calculated relative to cps. When set to 1, delaytime is a direct multiple of a cycle. lock :: Pattern Double -> ControlPattern lock = pF "lock" + lockTake :: String -> [Double] -> ControlPattern lockTake name xs = pStateListF "lock" name xs + lockCount :: String -> ControlPattern -lockCount name = pStateF "lock" name (maybe 0 (+1)) +lockCount name = pStateF "lock" name (maybe 0 (+ 1)) + lockCountTo :: String -> Pattern Double -> Pattern ValueMap -lockCountTo name ipat = innerJoin $ (\i -> pStateF "lock" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +lockCountTo name ipat = innerJoin $ (\i -> pStateF "lock" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat lockbus :: Pattern Int -> Pattern Double -> ControlPattern lockbus busid pat = (pF "lock" pat) # (pI "^lock" busid) + lockrecv :: Pattern Int -> ControlPattern lockrecv busid = pI "^lock" busid -- | loops the sample (from `begin` to `end`) the specified number of times. loop :: Pattern Double -> ControlPattern loop = pF "loop" + loopTake :: String -> [Double] -> ControlPattern loopTake name xs = pStateListF "loop" name xs + loopCount :: String -> ControlPattern -loopCount name = pStateF "loop" name (maybe 0 (+1)) +loopCount name = pStateF "loop" name (maybe 0 (+ 1)) + loopCountTo :: String -> Pattern Double -> Pattern ValueMap -loopCountTo name ipat = innerJoin $ (\i -> pStateF "loop" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +loopCountTo name ipat = innerJoin $ (\i -> pStateF "loop" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat loopbus :: Pattern Int -> Pattern Double -> ControlPattern loopbus _ _ = error $ "Control parameter 'loop' can't be sent to a bus." --- | +-- | lophat :: Pattern Double -> ControlPattern lophat = pF "lophat" + lophatTake :: String -> [Double] -> ControlPattern lophatTake name xs = pStateListF "lophat" name xs + lophatCount :: String -> ControlPattern -lophatCount name = pStateF "lophat" name (maybe 0 (+1)) +lophatCount name = pStateF "lophat" name (maybe 0 (+ 1)) + lophatCountTo :: String -> Pattern Double -> Pattern ValueMap -lophatCountTo name ipat = innerJoin $ (\i -> pStateF "lophat" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +lophatCountTo name ipat = innerJoin $ (\i -> pStateF "lophat" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat lophatbus :: Pattern Int -> Pattern Double -> ControlPattern lophatbus busid pat = (pF "lophat" pat) # (pI "^lophat" busid) + lophatrecv :: Pattern Int -> ControlPattern lophatrecv busid = pI "^lophat" busid --- | +-- | lrate :: Pattern Double -> ControlPattern lrate = pF "lrate" + lrateTake :: String -> [Double] -> ControlPattern lrateTake name xs = pStateListF "lrate" name xs + lrateCount :: String -> ControlPattern -lrateCount name = pStateF "lrate" name (maybe 0 (+1)) +lrateCount name = pStateF "lrate" name (maybe 0 (+ 1)) + lrateCountTo :: String -> Pattern Double -> Pattern ValueMap -lrateCountTo name ipat = innerJoin $ (\i -> pStateF "lrate" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +lrateCountTo name ipat = innerJoin $ (\i -> pStateF "lrate" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat lratebus :: Pattern Int -> Pattern Double -> ControlPattern lratebus busid pat = (pF "lrate" pat) # (pI "^lrate" busid) + lraterecv :: Pattern Int -> ControlPattern lraterecv busid = pI "^lrate" busid --- | +-- | lsize :: Pattern Double -> ControlPattern lsize = pF "lsize" + lsizeTake :: String -> [Double] -> ControlPattern lsizeTake name xs = pStateListF "lsize" name xs + lsizeCount :: String -> ControlPattern -lsizeCount name = pStateF "lsize" name (maybe 0 (+1)) +lsizeCount name = pStateF "lsize" name (maybe 0 (+ 1)) + lsizeCountTo :: String -> Pattern Double -> Pattern ValueMap -lsizeCountTo name ipat = innerJoin $ (\i -> pStateF "lsize" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +lsizeCountTo name ipat = innerJoin $ (\i -> pStateF "lsize" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat lsizebus :: Pattern Int -> Pattern Double -> ControlPattern lsizebus busid pat = (pF "lsize" pat) # (pI "^lsize" busid) + lsizerecv :: Pattern Int -> ControlPattern lsizerecv busid = pI "^lsize" busid --- | +-- | lsnare :: Pattern Double -> ControlPattern lsnare = pF "lsnare" + lsnareTake :: String -> [Double] -> ControlPattern lsnareTake name xs = pStateListF "lsnare" name xs + lsnareCount :: String -> ControlPattern -lsnareCount name = pStateF "lsnare" name (maybe 0 (+1)) +lsnareCount name = pStateF "lsnare" name (maybe 0 (+ 1)) + lsnareCountTo :: String -> Pattern Double -> Pattern ValueMap -lsnareCountTo name ipat = innerJoin $ (\i -> pStateF "lsnare" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +lsnareCountTo name ipat = innerJoin $ (\i -> pStateF "lsnare" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat lsnarebus :: Pattern Int -> Pattern Double -> ControlPattern lsnarebus busid pat = (pF "lsnare" pat) # (pI "^lsnare" busid) + lsnarerecv :: Pattern Int -> ControlPattern lsnarerecv busid = pI "^lsnare" busid -- | A pattern of numbers. Specifies whether the pitch of played samples should be tuned relative to their pitch metadata, if it exists. When set to 1, pitch metadata is applied. When set to 0, pitch metadata is ignored. metatune :: Pattern Double -> ControlPattern metatune = pF "metatune" + metatuneTake :: String -> [Double] -> ControlPattern metatuneTake name xs = pStateListF "metatune" name xs + metatuneCount :: String -> ControlPattern -metatuneCount name = pStateF "metatune" name (maybe 0 (+1)) +metatuneCount name = pStateF "metatune" name (maybe 0 (+ 1)) + metatuneCountTo :: String -> Pattern Double -> Pattern ValueMap -metatuneCountTo name ipat = innerJoin $ (\i -> pStateF "metatune" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +metatuneCountTo name ipat = innerJoin $ (\i -> pStateF "metatune" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat metatunebus :: Pattern Int -> Pattern Double -> ControlPattern metatunebus busid pat = (pF "metatune" pat) # (pI "^metatune" busid) + metatunerecv :: Pattern Int -> ControlPattern metatunerecv busid = pI "^metatune" busid --- | +-- | midibend :: Pattern Double -> ControlPattern midibend = pF "midibend" + midibendTake :: String -> [Double] -> ControlPattern midibendTake name xs = pStateListF "midibend" name xs + midibendCount :: String -> ControlPattern -midibendCount name = pStateF "midibend" name (maybe 0 (+1)) +midibendCount name = pStateF "midibend" name (maybe 0 (+ 1)) + midibendCountTo :: String -> Pattern Double -> Pattern ValueMap -midibendCountTo name ipat = innerJoin $ (\i -> pStateF "midibend" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +midibendCountTo name ipat = innerJoin $ (\i -> pStateF "midibend" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat midibendbus :: Pattern Int -> Pattern Double -> ControlPattern midibendbus _ _ = error $ "Control parameter 'midibend' can't be sent to a bus." --- | +-- | midichan :: Pattern Double -> ControlPattern midichan = pF "midichan" + midichanTake :: String -> [Double] -> ControlPattern midichanTake name xs = pStateListF "midichan" name xs + midichanCount :: String -> ControlPattern -midichanCount name = pStateF "midichan" name (maybe 0 (+1)) +midichanCount name = pStateF "midichan" name (maybe 0 (+ 1)) + midichanCountTo :: String -> Pattern Double -> Pattern ValueMap -midichanCountTo name ipat = innerJoin $ (\i -> pStateF "midichan" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +midichanCountTo name ipat = innerJoin $ (\i -> pStateF "midichan" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat midichanbus :: Pattern Int -> Pattern Double -> ControlPattern midichanbus _ _ = error $ "Control parameter 'midichan' can't be sent to a bus." --- | +-- | midicmd :: Pattern String -> ControlPattern midicmd = pS "midicmd" + midicmdTake :: String -> [Double] -> ControlPattern midicmdTake name xs = pStateListF "midicmd" name xs + midicmdbus :: Pattern Int -> Pattern String -> ControlPattern midicmdbus _ _ = error $ "Control parameter 'midicmd' can't be sent to a bus." --- | +-- | miditouch :: Pattern Double -> ControlPattern miditouch = pF "miditouch" + miditouchTake :: String -> [Double] -> ControlPattern miditouchTake name xs = pStateListF "miditouch" name xs + miditouchCount :: String -> ControlPattern -miditouchCount name = pStateF "miditouch" name (maybe 0 (+1)) +miditouchCount name = pStateF "miditouch" name (maybe 0 (+ 1)) + miditouchCountTo :: String -> Pattern Double -> Pattern ValueMap -miditouchCountTo name ipat = innerJoin $ (\i -> pStateF "miditouch" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +miditouchCountTo name ipat = innerJoin $ (\i -> pStateF "miditouch" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat miditouchbus :: Pattern Int -> Pattern Double -> ControlPattern miditouchbus _ _ = error $ "Control parameter 'miditouch' can't be sent to a bus." --- | +-- | minutes :: Pattern Double -> ControlPattern minutes = pF "minutes" + minutesTake :: String -> [Double] -> ControlPattern minutesTake name xs = pStateListF "minutes" name xs + minutesCount :: String -> ControlPattern -minutesCount name = pStateF "minutes" name (maybe 0 (+1)) +minutesCount name = pStateF "minutes" name (maybe 0 (+ 1)) + minutesCountTo :: String -> Pattern Double -> Pattern ValueMap -minutesCountTo name ipat = innerJoin $ (\i -> pStateF "minutes" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +minutesCountTo name ipat = innerJoin $ (\i -> pStateF "minutes" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat minutesbus :: Pattern Int -> Pattern Double -> ControlPattern minutesbus _ _ = error $ "Control parameter 'minutes' can't be sent to a bus." --- | +-- | modwheel :: Pattern Double -> ControlPattern modwheel = pF "modwheel" + modwheelTake :: String -> [Double] -> ControlPattern modwheelTake name xs = pStateListF "modwheel" name xs + modwheelCount :: String -> ControlPattern -modwheelCount name = pStateF "modwheel" name (maybe 0 (+1)) +modwheelCount name = pStateF "modwheel" name (maybe 0 (+ 1)) + modwheelCountTo :: String -> Pattern Double -> Pattern ValueMap -modwheelCountTo name ipat = innerJoin $ (\i -> pStateF "modwheel" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +modwheelCountTo name ipat = innerJoin $ (\i -> pStateF "modwheel" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat modwheelbus :: Pattern Int -> Pattern Double -> ControlPattern modwheelbus busid pat = (pF "modwheel" pat) # (pI "^modwheel" busid) + modwheelrecv :: Pattern Int -> ControlPattern modwheelrecv busid = pI "^modwheel" busid --- | +-- | mtranspose :: Pattern Double -> ControlPattern mtranspose = pF "mtranspose" + mtransposeTake :: String -> [Double] -> ControlPattern mtransposeTake name xs = pStateListF "mtranspose" name xs + mtransposeCount :: String -> ControlPattern -mtransposeCount name = pStateF "mtranspose" name (maybe 0 (+1)) +mtransposeCount name = pStateF "mtranspose" name (maybe 0 (+ 1)) + mtransposeCountTo :: String -> Pattern Double -> Pattern ValueMap -mtransposeCountTo name ipat = innerJoin $ (\i -> pStateF "mtranspose" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +mtransposeCountTo name ipat = innerJoin $ (\i -> pStateF "mtranspose" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat mtransposebus :: Pattern Int -> Pattern Double -> ControlPattern mtransposebus busid pat = (pF "mtranspose" pat) # (pI "^mtranspose" busid) + mtransposerecv :: Pattern Int -> ControlPattern mtransposerecv busid = pI "^mtranspose" busid -- | The note or sample number to choose for a synth or sampleset n :: Pattern Note -> ControlPattern n = pN "n" + nTake :: String -> [Double] -> ControlPattern nTake name xs = pStateListF "n" name xs + nCount :: String -> ControlPattern -nCount name = pStateF "n" name (maybe 0 (+1)) +nCount name = pStateF "n" name (maybe 0 (+ 1)) + nCountTo :: String -> Pattern Double -> Pattern ValueMap -nCountTo name ipat = innerJoin $ (\i -> pStateF "n" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +nCountTo name ipat = innerJoin $ (\i -> pStateF "n" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat nbus :: Pattern Int -> Pattern Note -> ControlPattern nbus _ _ = error $ "Control parameter 'n' can't be sent to a bus." @@ -1813,12 +2222,15 @@ nbus _ _ = error $ "Control parameter 'n' can't be sent to a bus." -- | The note or pitch to play a sound or synth with note :: Pattern Note -> ControlPattern note = pN "note" + noteTake :: String -> [Double] -> ControlPattern noteTake name xs = pStateListF "note" name xs + noteCount :: String -> ControlPattern -noteCount name = pStateF "note" name (maybe 0 (+1)) +noteCount name = pStateF "note" name (maybe 0 (+ 1)) + noteCountTo :: String -> Pattern Double -> Pattern ValueMap -noteCountTo name ipat = innerJoin $ (\i -> pStateF "note" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +noteCountTo name ipat = innerJoin $ (\i -> pStateF "note" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat notebus :: Pattern Int -> Pattern Note -> ControlPattern notebus _ _ = error $ "Control parameter 'note' can't be sent to a bus." @@ -1826,364 +2238,459 @@ notebus _ _ = error $ "Control parameter 'note' can't be sent to a bus." -- | Nudges events into the future by the specified number of seconds. Negative numbers work up to a point as well (due to internal latency) nudge :: Pattern Double -> ControlPattern nudge = pF "nudge" + nudgeTake :: String -> [Double] -> ControlPattern nudgeTake name xs = pStateListF "nudge" name xs + nudgeCount :: String -> ControlPattern -nudgeCount name = pStateF "nudge" name (maybe 0 (+1)) +nudgeCount name = pStateF "nudge" name (maybe 0 (+ 1)) + nudgeCountTo :: String -> Pattern Double -> Pattern ValueMap -nudgeCountTo name ipat = innerJoin $ (\i -> pStateF "nudge" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +nudgeCountTo name ipat = innerJoin $ (\i -> pStateF "nudge" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat nudgebus :: Pattern Int -> Pattern Double -> ControlPattern nudgebus busid pat = (pF "nudge" pat) # (pI "^nudge" busid) + nudgerecv :: Pattern Int -> ControlPattern nudgerecv busid = pI "^nudge" busid --- | +-- | octave :: Pattern Int -> ControlPattern octave = pI "octave" + octaveTake :: String -> [Double] -> ControlPattern octaveTake name xs = pStateListF "octave" name xs + octaveCount :: String -> ControlPattern -octaveCount name = pStateF "octave" name (maybe 0 (+1)) +octaveCount name = pStateF "octave" name (maybe 0 (+ 1)) + octaveCountTo :: String -> Pattern Double -> Pattern ValueMap -octaveCountTo name ipat = innerJoin $ (\i -> pStateF "octave" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +octaveCountTo name ipat = innerJoin $ (\i -> pStateF "octave" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat octavebus :: Pattern Int -> Pattern Int -> ControlPattern octavebus _ _ = error $ "Control parameter 'octave' can't be sent to a bus." --- | +-- | octaveR :: Pattern Double -> ControlPattern octaveR = pF "octaveR" + octaveRTake :: String -> [Double] -> ControlPattern octaveRTake name xs = pStateListF "octaveR" name xs + octaveRCount :: String -> ControlPattern -octaveRCount name = pStateF "octaveR" name (maybe 0 (+1)) +octaveRCount name = pStateF "octaveR" name (maybe 0 (+ 1)) + octaveRCountTo :: String -> Pattern Double -> Pattern ValueMap -octaveRCountTo name ipat = innerJoin $ (\i -> pStateF "octaveR" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +octaveRCountTo name ipat = innerJoin $ (\i -> pStateF "octaveR" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat octaveRbus :: Pattern Int -> Pattern Double -> ControlPattern octaveRbus busid pat = (pF "octaveR" pat) # (pI "^octaveR" busid) + octaveRrecv :: Pattern Int -> ControlPattern octaveRrecv busid = pI "^octaveR" busid -- | octaver effect octer :: Pattern Double -> ControlPattern octer = pF "octer" + octerTake :: String -> [Double] -> ControlPattern octerTake name xs = pStateListF "octer" name xs + octerCount :: String -> ControlPattern -octerCount name = pStateF "octer" name (maybe 0 (+1)) +octerCount name = pStateF "octer" name (maybe 0 (+ 1)) + octerCountTo :: String -> Pattern Double -> Pattern ValueMap -octerCountTo name ipat = innerJoin $ (\i -> pStateF "octer" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +octerCountTo name ipat = innerJoin $ (\i -> pStateF "octer" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat octerbus :: Pattern Int -> Pattern Double -> ControlPattern octerbus busid pat = (pF "octer" pat) # (pI "^octer" busid) + octerrecv :: Pattern Int -> ControlPattern octerrecv busid = pI "^octer" busid -- | octaver effect octersub :: Pattern Double -> ControlPattern octersub = pF "octersub" + octersubTake :: String -> [Double] -> ControlPattern octersubTake name xs = pStateListF "octersub" name xs + octersubCount :: String -> ControlPattern -octersubCount name = pStateF "octersub" name (maybe 0 (+1)) +octersubCount name = pStateF "octersub" name (maybe 0 (+ 1)) + octersubCountTo :: String -> Pattern Double -> Pattern ValueMap -octersubCountTo name ipat = innerJoin $ (\i -> pStateF "octersub" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +octersubCountTo name ipat = innerJoin $ (\i -> pStateF "octersub" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat octersubbus :: Pattern Int -> Pattern Double -> ControlPattern octersubbus busid pat = (pF "octersub" pat) # (pI "^octersub" busid) + octersubrecv :: Pattern Int -> ControlPattern octersubrecv busid = pI "^octersub" busid -- | octaver effect octersubsub :: Pattern Double -> ControlPattern octersubsub = pF "octersubsub" + octersubsubTake :: String -> [Double] -> ControlPattern octersubsubTake name xs = pStateListF "octersubsub" name xs + octersubsubCount :: String -> ControlPattern -octersubsubCount name = pStateF "octersubsub" name (maybe 0 (+1)) +octersubsubCount name = pStateF "octersubsub" name (maybe 0 (+ 1)) + octersubsubCountTo :: String -> Pattern Double -> Pattern ValueMap -octersubsubCountTo name ipat = innerJoin $ (\i -> pStateF "octersubsub" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +octersubsubCountTo name ipat = innerJoin $ (\i -> pStateF "octersubsub" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat octersubsubbus :: Pattern Int -> Pattern Double -> ControlPattern octersubsubbus busid pat = (pF "octersubsub" pat) # (pI "^octersubsub" busid) + octersubsubrecv :: Pattern Int -> ControlPattern octersubsubrecv busid = pI "^octersubsub" busid --- | +-- | offset :: Pattern Double -> ControlPattern offset = pF "offset" + offsetTake :: String -> [Double] -> ControlPattern offsetTake name xs = pStateListF "offset" name xs + offsetCount :: String -> ControlPattern -offsetCount name = pStateF "offset" name (maybe 0 (+1)) +offsetCount name = pStateF "offset" name (maybe 0 (+ 1)) + offsetCountTo :: String -> Pattern Double -> Pattern ValueMap -offsetCountTo name ipat = innerJoin $ (\i -> pStateF "offset" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +offsetCountTo name ipat = innerJoin $ (\i -> pStateF "offset" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat offsetbus :: Pattern Int -> Pattern Double -> ControlPattern offsetbus _ _ = error $ "Control parameter 'offset' can't be sent to a bus." --- | +-- | ophatdecay :: Pattern Double -> ControlPattern ophatdecay = pF "ophatdecay" + ophatdecayTake :: String -> [Double] -> ControlPattern ophatdecayTake name xs = pStateListF "ophatdecay" name xs + ophatdecayCount :: String -> ControlPattern -ophatdecayCount name = pStateF "ophatdecay" name (maybe 0 (+1)) +ophatdecayCount name = pStateF "ophatdecay" name (maybe 0 (+ 1)) + ophatdecayCountTo :: String -> Pattern Double -> Pattern ValueMap -ophatdecayCountTo name ipat = innerJoin $ (\i -> pStateF "ophatdecay" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +ophatdecayCountTo name ipat = innerJoin $ (\i -> pStateF "ophatdecay" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat ophatdecaybus :: Pattern Int -> Pattern Double -> ControlPattern ophatdecaybus busid pat = (pF "ophatdecay" pat) # (pI "^ophatdecay" busid) + ophatdecayrecv :: Pattern Int -> ControlPattern ophatdecayrecv busid = pI "^ophatdecay" busid -- | a pattern of numbers. An "orbit" is a global parameter context for patterns. Patterns with the same orbit will share hardware output bus offset and global effects, e.g. reverb and delay. The maximum number of orbits is specified in the superdirt startup, numbers higher than maximum will wrap around. orbit :: Pattern Int -> ControlPattern orbit = pI "orbit" + orbitTake :: String -> [Double] -> ControlPattern orbitTake name xs = pStateListF "orbit" name xs + orbitCount :: String -> ControlPattern -orbitCount name = pStateF "orbit" name (maybe 0 (+1)) +orbitCount name = pStateF "orbit" name (maybe 0 (+ 1)) + orbitCountTo :: String -> Pattern Double -> Pattern ValueMap -orbitCountTo name ipat = innerJoin $ (\i -> pStateF "orbit" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +orbitCountTo name ipat = innerJoin $ (\i -> pStateF "orbit" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat orbitbus :: Pattern Int -> Pattern Int -> ControlPattern orbitbus busid pat = (pI "orbit" pat) # (pI "^orbit" busid) + orbitrecv :: Pattern Int -> ControlPattern orbitrecv busid = pI "^orbit" busid --- | +-- | overgain :: Pattern Double -> ControlPattern overgain = pF "overgain" + overgainTake :: String -> [Double] -> ControlPattern overgainTake name xs = pStateListF "overgain" name xs + overgainCount :: String -> ControlPattern -overgainCount name = pStateF "overgain" name (maybe 0 (+1)) +overgainCount name = pStateF "overgain" name (maybe 0 (+ 1)) + overgainCountTo :: String -> Pattern Double -> Pattern ValueMap -overgainCountTo name ipat = innerJoin $ (\i -> pStateF "overgain" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +overgainCountTo name ipat = innerJoin $ (\i -> pStateF "overgain" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat overgainbus :: Pattern Int -> Pattern Double -> ControlPattern overgainbus _ _ = error $ "Control parameter 'overgain' can't be sent to a bus." --- | +-- | overshape :: Pattern Double -> ControlPattern overshape = pF "overshape" + overshapeTake :: String -> [Double] -> ControlPattern overshapeTake name xs = pStateListF "overshape" name xs + overshapeCount :: String -> ControlPattern -overshapeCount name = pStateF "overshape" name (maybe 0 (+1)) +overshapeCount name = pStateF "overshape" name (maybe 0 (+ 1)) + overshapeCountTo :: String -> Pattern Double -> Pattern ValueMap -overshapeCountTo name ipat = innerJoin $ (\i -> pStateF "overshape" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +overshapeCountTo name ipat = innerJoin $ (\i -> pStateF "overshape" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat overshapebus :: Pattern Int -> Pattern Double -> ControlPattern overshapebus busid pat = (pF "overshape" pat) # (pI "^overshape" busid) + overshaperecv :: Pattern Int -> ControlPattern overshaperecv busid = pI "^overshape" busid -- | a pattern of numbers between 0 and 1, from left to right (assuming stereo), once round a circle (assuming multichannel) pan :: Pattern Double -> ControlPattern pan = pF "pan" + panTake :: String -> [Double] -> ControlPattern panTake name xs = pStateListF "pan" name xs + panCount :: String -> ControlPattern -panCount name = pStateF "pan" name (maybe 0 (+1)) +panCount name = pStateF "pan" name (maybe 0 (+ 1)) + panCountTo :: String -> Pattern Double -> Pattern ValueMap -panCountTo name ipat = innerJoin $ (\i -> pStateF "pan" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +panCountTo name ipat = innerJoin $ (\i -> pStateF "pan" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat panbus :: Pattern Int -> Pattern Double -> ControlPattern panbus busid pat = (pF "pan" pat) # (pI "^pan" busid) + panrecv :: Pattern Int -> ControlPattern panrecv busid = pI "^pan" busid -- | a pattern of numbers between -1.0 and 1.0, which controls the relative position of the centre pan in a pair of adjacent speakers (multichannel only) panorient :: Pattern Double -> ControlPattern panorient = pF "panorient" + panorientTake :: String -> [Double] -> ControlPattern panorientTake name xs = pStateListF "panorient" name xs + panorientCount :: String -> ControlPattern -panorientCount name = pStateF "panorient" name (maybe 0 (+1)) +panorientCount name = pStateF "panorient" name (maybe 0 (+ 1)) + panorientCountTo :: String -> Pattern Double -> Pattern ValueMap -panorientCountTo name ipat = innerJoin $ (\i -> pStateF "panorient" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +panorientCountTo name ipat = innerJoin $ (\i -> pStateF "panorient" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat panorientbus :: Pattern Int -> Pattern Double -> ControlPattern panorientbus busid pat = (pF "panorient" pat) # (pI "^panorient" busid) + panorientrecv :: Pattern Int -> ControlPattern panorientrecv busid = pI "^panorient" busid -- | a pattern of numbers between -inf and inf, which controls how much multichannel output is fanned out (negative is backwards ordering) panspan :: Pattern Double -> ControlPattern panspan = pF "panspan" + panspanTake :: String -> [Double] -> ControlPattern panspanTake name xs = pStateListF "panspan" name xs + panspanCount :: String -> ControlPattern -panspanCount name = pStateF "panspan" name (maybe 0 (+1)) +panspanCount name = pStateF "panspan" name (maybe 0 (+ 1)) + panspanCountTo :: String -> Pattern Double -> Pattern ValueMap -panspanCountTo name ipat = innerJoin $ (\i -> pStateF "panspan" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +panspanCountTo name ipat = innerJoin $ (\i -> pStateF "panspan" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat panspanbus :: Pattern Int -> Pattern Double -> ControlPattern panspanbus busid pat = (pF "panspan" pat) # (pI "^panspan" busid) + panspanrecv :: Pattern Int -> ControlPattern panspanrecv busid = pI "^panspan" busid -- | a pattern of numbers between 0.0 and 1.0, which controls the multichannel spread range (multichannel only) pansplay :: Pattern Double -> ControlPattern pansplay = pF "pansplay" + pansplayTake :: String -> [Double] -> ControlPattern pansplayTake name xs = pStateListF "pansplay" name xs + pansplayCount :: String -> ControlPattern -pansplayCount name = pStateF "pansplay" name (maybe 0 (+1)) +pansplayCount name = pStateF "pansplay" name (maybe 0 (+ 1)) + pansplayCountTo :: String -> Pattern Double -> Pattern ValueMap -pansplayCountTo name ipat = innerJoin $ (\i -> pStateF "pansplay" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +pansplayCountTo name ipat = innerJoin $ (\i -> pStateF "pansplay" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat pansplaybus :: Pattern Int -> Pattern Double -> ControlPattern pansplaybus busid pat = (pF "pansplay" pat) # (pI "^pansplay" busid) + pansplayrecv :: Pattern Int -> ControlPattern pansplayrecv busid = pI "^pansplay" busid -- | a pattern of numbers between 0.0 and inf, which controls how much each channel is distributed over neighbours (multichannel only) panwidth :: Pattern Double -> ControlPattern panwidth = pF "panwidth" + panwidthTake :: String -> [Double] -> ControlPattern panwidthTake name xs = pStateListF "panwidth" name xs + panwidthCount :: String -> ControlPattern -panwidthCount name = pStateF "panwidth" name (maybe 0 (+1)) +panwidthCount name = pStateF "panwidth" name (maybe 0 (+ 1)) + panwidthCountTo :: String -> Pattern Double -> Pattern ValueMap -panwidthCountTo name ipat = innerJoin $ (\i -> pStateF "panwidth" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +panwidthCountTo name ipat = innerJoin $ (\i -> pStateF "panwidth" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat panwidthbus :: Pattern Int -> Pattern Double -> ControlPattern panwidthbus busid pat = (pF "panwidth" pat) # (pI "^panwidth" busid) + panwidthrecv :: Pattern Int -> ControlPattern panwidthrecv busid = pI "^panwidth" busid --- | +-- | partials :: Pattern Double -> ControlPattern partials = pF "partials" + partialsTake :: String -> [Double] -> ControlPattern partialsTake name xs = pStateListF "partials" name xs + partialsCount :: String -> ControlPattern -partialsCount name = pStateF "partials" name (maybe 0 (+1)) +partialsCount name = pStateF "partials" name (maybe 0 (+ 1)) + partialsCountTo :: String -> Pattern Double -> Pattern ValueMap -partialsCountTo name ipat = innerJoin $ (\i -> pStateF "partials" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +partialsCountTo name ipat = innerJoin $ (\i -> pStateF "partials" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat partialsbus :: Pattern Int -> Pattern Double -> ControlPattern partialsbus busid pat = (pF "partials" pat) # (pI "^partials" busid) + partialsrecv :: Pattern Int -> ControlPattern partialsrecv busid = pI "^partials" busid -- | Phaser Audio DSP effect | params are 'phaserrate' and 'phaserdepth' phaserdepth :: Pattern Double -> ControlPattern phaserdepth = pF "phaserdepth" + phaserdepthTake :: String -> [Double] -> ControlPattern phaserdepthTake name xs = pStateListF "phaserdepth" name xs + phaserdepthCount :: String -> ControlPattern -phaserdepthCount name = pStateF "phaserdepth" name (maybe 0 (+1)) +phaserdepthCount name = pStateF "phaserdepth" name (maybe 0 (+ 1)) + phaserdepthCountTo :: String -> Pattern Double -> Pattern ValueMap -phaserdepthCountTo name ipat = innerJoin $ (\i -> pStateF "phaserdepth" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +phaserdepthCountTo name ipat = innerJoin $ (\i -> pStateF "phaserdepth" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat phaserdepthbus :: Pattern Int -> Pattern Double -> ControlPattern phaserdepthbus busid pat = (pF "phaserdepth" pat) # (pI "^phaserdepth" busid) + phaserdepthrecv :: Pattern Int -> ControlPattern phaserdepthrecv busid = pI "^phaserdepth" busid -- | Phaser Audio DSP effect | params are 'phaserrate' and 'phaserdepth' phaserrate :: Pattern Double -> ControlPattern phaserrate = pF "phaserrate" + phaserrateTake :: String -> [Double] -> ControlPattern phaserrateTake name xs = pStateListF "phaserrate" name xs + phaserrateCount :: String -> ControlPattern -phaserrateCount name = pStateF "phaserrate" name (maybe 0 (+1)) +phaserrateCount name = pStateF "phaserrate" name (maybe 0 (+ 1)) + phaserrateCountTo :: String -> Pattern Double -> Pattern ValueMap -phaserrateCountTo name ipat = innerJoin $ (\i -> pStateF "phaserrate" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +phaserrateCountTo name ipat = innerJoin $ (\i -> pStateF "phaserrate" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat phaserratebus :: Pattern Int -> Pattern Double -> ControlPattern phaserratebus busid pat = (pF "phaserrate" pat) # (pI "^phaserrate" busid) + phaserraterecv :: Pattern Int -> ControlPattern phaserraterecv busid = pI "^phaserrate" busid --- | +-- | pitch1 :: Pattern Double -> ControlPattern pitch1 = pF "pitch1" + pitch1Take :: String -> [Double] -> ControlPattern pitch1Take name xs = pStateListF "pitch1" name xs + pitch1Count :: String -> ControlPattern -pitch1Count name = pStateF "pitch1" name (maybe 0 (+1)) +pitch1Count name = pStateF "pitch1" name (maybe 0 (+ 1)) + pitch1CountTo :: String -> Pattern Double -> Pattern ValueMap -pitch1CountTo name ipat = innerJoin $ (\i -> pStateF "pitch1" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +pitch1CountTo name ipat = innerJoin $ (\i -> pStateF "pitch1" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat pitch1bus :: Pattern Int -> Pattern Double -> ControlPattern pitch1bus busid pat = (pF "pitch1" pat) # (pI "^pitch1" busid) + pitch1recv :: Pattern Int -> ControlPattern pitch1recv busid = pI "^pitch1" busid --- | +-- | pitch2 :: Pattern Double -> ControlPattern pitch2 = pF "pitch2" + pitch2Take :: String -> [Double] -> ControlPattern pitch2Take name xs = pStateListF "pitch2" name xs + pitch2Count :: String -> ControlPattern -pitch2Count name = pStateF "pitch2" name (maybe 0 (+1)) +pitch2Count name = pStateF "pitch2" name (maybe 0 (+ 1)) + pitch2CountTo :: String -> Pattern Double -> Pattern ValueMap -pitch2CountTo name ipat = innerJoin $ (\i -> pStateF "pitch2" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +pitch2CountTo name ipat = innerJoin $ (\i -> pStateF "pitch2" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat pitch2bus :: Pattern Int -> Pattern Double -> ControlPattern pitch2bus busid pat = (pF "pitch2" pat) # (pI "^pitch2" busid) + pitch2recv :: Pattern Int -> ControlPattern pitch2recv busid = pI "^pitch2" busid --- | +-- | pitch3 :: Pattern Double -> ControlPattern pitch3 = pF "pitch3" + pitch3Take :: String -> [Double] -> ControlPattern pitch3Take name xs = pStateListF "pitch3" name xs + pitch3Count :: String -> ControlPattern -pitch3Count name = pStateF "pitch3" name (maybe 0 (+1)) +pitch3Count name = pStateF "pitch3" name (maybe 0 (+ 1)) + pitch3CountTo :: String -> Pattern Double -> Pattern ValueMap -pitch3CountTo name ipat = innerJoin $ (\i -> pStateF "pitch3" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +pitch3CountTo name ipat = innerJoin $ (\i -> pStateF "pitch3" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat pitch3bus :: Pattern Int -> Pattern Double -> ControlPattern pitch3bus busid pat = (pF "pitch3" pat) # (pI "^pitch3" busid) + pitch3recv :: Pattern Int -> ControlPattern pitch3recv busid = pI "^pitch3" busid --- | +-- | polyTouch :: Pattern Double -> ControlPattern polyTouch = pF "polyTouch" + polyTouchTake :: String -> [Double] -> ControlPattern polyTouchTake name xs = pStateListF "polyTouch" name xs + polyTouchCount :: String -> ControlPattern -polyTouchCount name = pStateF "polyTouch" name (maybe 0 (+1)) +polyTouchCount name = pStateF "polyTouch" name (maybe 0 (+ 1)) + polyTouchCountTo :: String -> Pattern Double -> Pattern ValueMap -polyTouchCountTo name ipat = innerJoin $ (\i -> pStateF "polyTouch" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +polyTouchCountTo name ipat = innerJoin $ (\i -> pStateF "polyTouch" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat polyTouchbus :: Pattern Int -> Pattern Double -> ControlPattern polyTouchbus _ _ = error $ "Control parameter 'polyTouch' can't be sent to a bus." --- | +-- | portamento :: Pattern Double -> ControlPattern portamento = pF "portamento" + portamentoTake :: String -> [Double] -> ControlPattern portamentoTake name xs = pStateListF "portamento" name xs + portamentoCount :: String -> ControlPattern -portamentoCount name = pStateF "portamento" name (maybe 0 (+1)) +portamentoCount name = pStateF "portamento" name (maybe 0 (+ 1)) + portamentoCountTo :: String -> Pattern Double -> Pattern ValueMap -portamentoCountTo name ipat = innerJoin $ (\i -> pStateF "portamento" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +portamentoCountTo name ipat = innerJoin $ (\i -> pStateF "portamento" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat portamentobus :: Pattern Int -> Pattern Double -> ControlPattern portamentobus busid pat = (pF "portamento" pat) # (pI "^portamento" busid) + portamentorecv :: Pattern Int -> ControlPattern portamentorecv busid = pI "^portamento" busid --- | +-- | progNum :: Pattern Double -> ControlPattern progNum = pF "progNum" + progNumTake :: String -> [Double] -> ControlPattern progNumTake name xs = pStateListF "progNum" name xs + progNumCount :: String -> ControlPattern -progNumCount name = pStateF "progNum" name (maybe 0 (+1)) +progNumCount name = pStateF "progNum" name (maybe 0 (+ 1)) + progNumCountTo :: String -> Pattern Double -> Pattern ValueMap -progNumCountTo name ipat = innerJoin $ (\i -> pStateF "progNum" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +progNumCountTo name ipat = innerJoin $ (\i -> pStateF "progNum" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat progNumbus :: Pattern Int -> Pattern Double -> ControlPattern progNumbus _ _ = error $ "Control parameter 'progNum' can't be sent to a bus." @@ -2191,736 +2698,903 @@ progNumbus _ _ = error $ "Control parameter 'progNum' can't be sent to a bus." -- | used in SuperDirt softsynths as a control rate or "speed" rate :: Pattern Double -> ControlPattern rate = pF "rate" + rateTake :: String -> [Double] -> ControlPattern rateTake name xs = pStateListF "rate" name xs + rateCount :: String -> ControlPattern -rateCount name = pStateF "rate" name (maybe 0 (+1)) +rateCount name = pStateF "rate" name (maybe 0 (+ 1)) + rateCountTo :: String -> Pattern Double -> Pattern ValueMap -rateCountTo name ipat = innerJoin $ (\i -> pStateF "rate" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +rateCountTo name ipat = innerJoin $ (\i -> pStateF "rate" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat ratebus :: Pattern Int -> Pattern Double -> ControlPattern ratebus busid pat = (pF "rate" pat) # (pI "^rate" busid) + raterecv :: Pattern Int -> ControlPattern raterecv busid = pI "^rate" busid -- | Spectral conform real :: Pattern Double -> ControlPattern real = pF "real" + realTake :: String -> [Double] -> ControlPattern realTake name xs = pStateListF "real" name xs + realCount :: String -> ControlPattern -realCount name = pStateF "real" name (maybe 0 (+1)) +realCount name = pStateF "real" name (maybe 0 (+ 1)) + realCountTo :: String -> Pattern Double -> Pattern ValueMap -realCountTo name ipat = innerJoin $ (\i -> pStateF "real" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +realCountTo name ipat = innerJoin $ (\i -> pStateF "real" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat realbus :: Pattern Int -> Pattern Double -> ControlPattern realbus busid pat = (pF "real" pat) # (pI "^real" busid) + realrecv :: Pattern Int -> ControlPattern realrecv busid = pI "^real" busid -- | a pattern of numbers to specify the release time (in seconds) of an envelope applied to each sample. release :: Pattern Double -> ControlPattern release = pF "release" + releaseTake :: String -> [Double] -> ControlPattern releaseTake name xs = pStateListF "release" name xs + releaseCount :: String -> ControlPattern -releaseCount name = pStateF "release" name (maybe 0 (+1)) +releaseCount name = pStateF "release" name (maybe 0 (+ 1)) + releaseCountTo :: String -> Pattern Double -> Pattern ValueMap -releaseCountTo name ipat = innerJoin $ (\i -> pStateF "release" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +releaseCountTo name ipat = innerJoin $ (\i -> pStateF "release" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat releasebus :: Pattern Int -> Pattern Double -> ControlPattern releasebus busid pat = (pF "release" pat) # (pI "^release" busid) + releaserecv :: Pattern Int -> ControlPattern releaserecv busid = pI "^release" busid -- | a pattern of numbers from 0 to 1. Specifies the resonance of the low-pass filter. resonance :: Pattern Double -> ControlPattern resonance = pF "resonance" + resonanceTake :: String -> [Double] -> ControlPattern resonanceTake name xs = pStateListF "resonance" name xs + resonanceCount :: String -> ControlPattern -resonanceCount name = pStateF "resonance" name (maybe 0 (+1)) +resonanceCount name = pStateF "resonance" name (maybe 0 (+ 1)) + resonanceCountTo :: String -> Pattern Double -> Pattern ValueMap -resonanceCountTo name ipat = innerJoin $ (\i -> pStateF "resonance" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +resonanceCountTo name ipat = innerJoin $ (\i -> pStateF "resonance" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat resonancebus :: Pattern Int -> Pattern Double -> ControlPattern resonancebus busid pat = (pF "resonance" pat) # (pI "^resonance" busid) + resonancerecv :: Pattern Int -> ControlPattern resonancerecv busid = pI "^resonance" busid -- | ring modulation ring :: Pattern Double -> ControlPattern ring = pF "ring" + ringTake :: String -> [Double] -> ControlPattern ringTake name xs = pStateListF "ring" name xs + ringCount :: String -> ControlPattern -ringCount name = pStateF "ring" name (maybe 0 (+1)) +ringCount name = pStateF "ring" name (maybe 0 (+ 1)) + ringCountTo :: String -> Pattern Double -> Pattern ValueMap -ringCountTo name ipat = innerJoin $ (\i -> pStateF "ring" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +ringCountTo name ipat = innerJoin $ (\i -> pStateF "ring" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat ringbus :: Pattern Int -> Pattern Double -> ControlPattern ringbus busid pat = (pF "ring" pat) # (pI "^ring" busid) + ringrecv :: Pattern Int -> ControlPattern ringrecv busid = pI "^ring" busid -- | ring modulation ringdf :: Pattern Double -> ControlPattern ringdf = pF "ringdf" + ringdfTake :: String -> [Double] -> ControlPattern ringdfTake name xs = pStateListF "ringdf" name xs + ringdfCount :: String -> ControlPattern -ringdfCount name = pStateF "ringdf" name (maybe 0 (+1)) +ringdfCount name = pStateF "ringdf" name (maybe 0 (+ 1)) + ringdfCountTo :: String -> Pattern Double -> Pattern ValueMap -ringdfCountTo name ipat = innerJoin $ (\i -> pStateF "ringdf" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +ringdfCountTo name ipat = innerJoin $ (\i -> pStateF "ringdf" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat ringdfbus :: Pattern Int -> Pattern Double -> ControlPattern ringdfbus busid pat = (pF "ringdf" pat) # (pI "^ringdf" busid) + ringdfrecv :: Pattern Int -> ControlPattern ringdfrecv busid = pI "^ringdf" busid -- | ring modulation ringf :: Pattern Double -> ControlPattern ringf = pF "ringf" + ringfTake :: String -> [Double] -> ControlPattern ringfTake name xs = pStateListF "ringf" name xs + ringfCount :: String -> ControlPattern -ringfCount name = pStateF "ringf" name (maybe 0 (+1)) +ringfCount name = pStateF "ringf" name (maybe 0 (+ 1)) + ringfCountTo :: String -> Pattern Double -> Pattern ValueMap -ringfCountTo name ipat = innerJoin $ (\i -> pStateF "ringf" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +ringfCountTo name ipat = innerJoin $ (\i -> pStateF "ringf" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat ringfbus :: Pattern Int -> Pattern Double -> ControlPattern ringfbus busid pat = (pF "ringf" pat) # (pI "^ringf" busid) + ringfrecv :: Pattern Int -> ControlPattern ringfrecv busid = pI "^ringf" busid -- | a pattern of numbers from 0 to 1. Sets the level of reverb. room :: Pattern Double -> ControlPattern room = pF "room" + roomTake :: String -> [Double] -> ControlPattern roomTake name xs = pStateListF "room" name xs + roomCount :: String -> ControlPattern -roomCount name = pStateF "room" name (maybe 0 (+1)) +roomCount name = pStateF "room" name (maybe 0 (+ 1)) + roomCountTo :: String -> Pattern Double -> Pattern ValueMap -roomCountTo name ipat = innerJoin $ (\i -> pStateF "room" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +roomCountTo name ipat = innerJoin $ (\i -> pStateF "room" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat roombus :: Pattern Int -> Pattern Double -> ControlPattern roombus busid pat = (pF "room" pat) # (pI "^room" busid) + roomrecv :: Pattern Int -> ControlPattern roomrecv busid = pI "^room" busid --- | +-- | sagogo :: Pattern Double -> ControlPattern sagogo = pF "sagogo" + sagogoTake :: String -> [Double] -> ControlPattern sagogoTake name xs = pStateListF "sagogo" name xs + sagogoCount :: String -> ControlPattern -sagogoCount name = pStateF "sagogo" name (maybe 0 (+1)) +sagogoCount name = pStateF "sagogo" name (maybe 0 (+ 1)) + sagogoCountTo :: String -> Pattern Double -> Pattern ValueMap -sagogoCountTo name ipat = innerJoin $ (\i -> pStateF "sagogo" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +sagogoCountTo name ipat = innerJoin $ (\i -> pStateF "sagogo" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat sagogobus :: Pattern Int -> Pattern Double -> ControlPattern sagogobus busid pat = (pF "sagogo" pat) # (pI "^sagogo" busid) + sagogorecv :: Pattern Int -> ControlPattern sagogorecv busid = pI "^sagogo" busid --- | +-- | sclap :: Pattern Double -> ControlPattern sclap = pF "sclap" + sclapTake :: String -> [Double] -> ControlPattern sclapTake name xs = pStateListF "sclap" name xs + sclapCount :: String -> ControlPattern -sclapCount name = pStateF "sclap" name (maybe 0 (+1)) +sclapCount name = pStateF "sclap" name (maybe 0 (+ 1)) + sclapCountTo :: String -> Pattern Double -> Pattern ValueMap -sclapCountTo name ipat = innerJoin $ (\i -> pStateF "sclap" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +sclapCountTo name ipat = innerJoin $ (\i -> pStateF "sclap" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat sclapbus :: Pattern Int -> Pattern Double -> ControlPattern sclapbus busid pat = (pF "sclap" pat) # (pI "^sclap" busid) + sclaprecv :: Pattern Int -> ControlPattern sclaprecv busid = pI "^sclap" busid --- | +-- | sclaves :: Pattern Double -> ControlPattern sclaves = pF "sclaves" + sclavesTake :: String -> [Double] -> ControlPattern sclavesTake name xs = pStateListF "sclaves" name xs + sclavesCount :: String -> ControlPattern -sclavesCount name = pStateF "sclaves" name (maybe 0 (+1)) +sclavesCount name = pStateF "sclaves" name (maybe 0 (+ 1)) + sclavesCountTo :: String -> Pattern Double -> Pattern ValueMap -sclavesCountTo name ipat = innerJoin $ (\i -> pStateF "sclaves" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +sclavesCountTo name ipat = innerJoin $ (\i -> pStateF "sclaves" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat sclavesbus :: Pattern Int -> Pattern Double -> ControlPattern sclavesbus busid pat = (pF "sclaves" pat) # (pI "^sclaves" busid) + sclavesrecv :: Pattern Int -> ControlPattern sclavesrecv busid = pI "^sclaves" busid -- | Spectral scramble scram :: Pattern Double -> ControlPattern scram = pF "scram" + scramTake :: String -> [Double] -> ControlPattern scramTake name xs = pStateListF "scram" name xs + scramCount :: String -> ControlPattern -scramCount name = pStateF "scram" name (maybe 0 (+1)) +scramCount name = pStateF "scram" name (maybe 0 (+ 1)) + scramCountTo :: String -> Pattern Double -> Pattern ValueMap -scramCountTo name ipat = innerJoin $ (\i -> pStateF "scram" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +scramCountTo name ipat = innerJoin $ (\i -> pStateF "scram" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat scrambus :: Pattern Int -> Pattern Double -> ControlPattern scrambus busid pat = (pF "scram" pat) # (pI "^scram" busid) + scramrecv :: Pattern Int -> ControlPattern scramrecv busid = pI "^scram" busid --- | +-- | scrash :: Pattern Double -> ControlPattern scrash = pF "scrash" + scrashTake :: String -> [Double] -> ControlPattern scrashTake name xs = pStateListF "scrash" name xs + scrashCount :: String -> ControlPattern -scrashCount name = pStateF "scrash" name (maybe 0 (+1)) +scrashCount name = pStateF "scrash" name (maybe 0 (+ 1)) + scrashCountTo :: String -> Pattern Double -> Pattern ValueMap -scrashCountTo name ipat = innerJoin $ (\i -> pStateF "scrash" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +scrashCountTo name ipat = innerJoin $ (\i -> pStateF "scrash" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat scrashbus :: Pattern Int -> Pattern Double -> ControlPattern scrashbus busid pat = (pF "scrash" pat) # (pI "^scrash" busid) + scrashrecv :: Pattern Int -> ControlPattern scrashrecv busid = pI "^scrash" busid --- | +-- | seconds :: Pattern Double -> ControlPattern seconds = pF "seconds" + secondsTake :: String -> [Double] -> ControlPattern secondsTake name xs = pStateListF "seconds" name xs + secondsCount :: String -> ControlPattern -secondsCount name = pStateF "seconds" name (maybe 0 (+1)) +secondsCount name = pStateF "seconds" name (maybe 0 (+ 1)) + secondsCountTo :: String -> Pattern Double -> Pattern ValueMap -secondsCountTo name ipat = innerJoin $ (\i -> pStateF "seconds" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +secondsCountTo name ipat = innerJoin $ (\i -> pStateF "seconds" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat secondsbus :: Pattern Int -> Pattern Double -> ControlPattern secondsbus _ _ = error $ "Control parameter 'seconds' can't be sent to a bus." --- | +-- | semitone :: Pattern Double -> ControlPattern semitone = pF "semitone" + semitoneTake :: String -> [Double] -> ControlPattern semitoneTake name xs = pStateListF "semitone" name xs + semitoneCount :: String -> ControlPattern -semitoneCount name = pStateF "semitone" name (maybe 0 (+1)) +semitoneCount name = pStateF "semitone" name (maybe 0 (+ 1)) + semitoneCountTo :: String -> Pattern Double -> Pattern ValueMap -semitoneCountTo name ipat = innerJoin $ (\i -> pStateF "semitone" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +semitoneCountTo name ipat = innerJoin $ (\i -> pStateF "semitone" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat semitonebus :: Pattern Int -> Pattern Double -> ControlPattern semitonebus busid pat = (pF "semitone" pat) # (pI "^semitone" busid) + semitonerecv :: Pattern Int -> ControlPattern semitonerecv busid = pI "^semitone" busid -- | wave shaping distortion, a pattern of numbers from 0 for no distortion up to 1 for loads of distortion. shape :: Pattern Double -> ControlPattern shape = pF "shape" + shapeTake :: String -> [Double] -> ControlPattern shapeTake name xs = pStateListF "shape" name xs + shapeCount :: String -> ControlPattern -shapeCount name = pStateF "shape" name (maybe 0 (+1)) +shapeCount name = pStateF "shape" name (maybe 0 (+ 1)) + shapeCountTo :: String -> Pattern Double -> Pattern ValueMap -shapeCountTo name ipat = innerJoin $ (\i -> pStateF "shape" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +shapeCountTo name ipat = innerJoin $ (\i -> pStateF "shape" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat shapebus :: Pattern Int -> Pattern Double -> ControlPattern shapebus busid pat = (pF "shape" pat) # (pI "^shape" busid) + shaperecv :: Pattern Int -> ControlPattern shaperecv busid = pI "^shape" busid -- | a pattern of numbers from 0 to 1. Sets the perceptual size (reverb time) of the `room` to be used in reverb. size :: Pattern Double -> ControlPattern size = pF "size" + sizeTake :: String -> [Double] -> ControlPattern sizeTake name xs = pStateListF "size" name xs + sizeCount :: String -> ControlPattern -sizeCount name = pStateF "size" name (maybe 0 (+1)) +sizeCount name = pStateF "size" name (maybe 0 (+ 1)) + sizeCountTo :: String -> Pattern Double -> Pattern ValueMap -sizeCountTo name ipat = innerJoin $ (\i -> pStateF "size" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +sizeCountTo name ipat = innerJoin $ (\i -> pStateF "size" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat sizebus :: Pattern Int -> Pattern Double -> ControlPattern sizebus busid pat = (pF "size" pat) # (pI "^size" busid) + sizerecv :: Pattern Int -> ControlPattern sizerecv busid = pI "^size" busid --- | +-- | slide :: Pattern Double -> ControlPattern slide = pF "slide" + slideTake :: String -> [Double] -> ControlPattern slideTake name xs = pStateListF "slide" name xs + slideCount :: String -> ControlPattern -slideCount name = pStateF "slide" name (maybe 0 (+1)) +slideCount name = pStateF "slide" name (maybe 0 (+ 1)) + slideCountTo :: String -> Pattern Double -> Pattern ValueMap -slideCountTo name ipat = innerJoin $ (\i -> pStateF "slide" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +slideCountTo name ipat = innerJoin $ (\i -> pStateF "slide" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat slidebus :: Pattern Int -> Pattern Double -> ControlPattern slidebus busid pat = (pF "slide" pat) # (pI "^slide" busid) + sliderecv :: Pattern Int -> ControlPattern sliderecv busid = pI "^slide" busid --- | +-- | slider0 :: Pattern Double -> ControlPattern slider0 = pF "slider0" + slider0Take :: String -> [Double] -> ControlPattern slider0Take name xs = pStateListF "slider0" name xs + slider0Count :: String -> ControlPattern -slider0Count name = pStateF "slider0" name (maybe 0 (+1)) +slider0Count name = pStateF "slider0" name (maybe 0 (+ 1)) + slider0CountTo :: String -> Pattern Double -> Pattern ValueMap -slider0CountTo name ipat = innerJoin $ (\i -> pStateF "slider0" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +slider0CountTo name ipat = innerJoin $ (\i -> pStateF "slider0" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat slider0bus :: Pattern Int -> Pattern Double -> ControlPattern slider0bus busid pat = (pF "slider0" pat) # (pI "^slider0" busid) + slider0recv :: Pattern Int -> ControlPattern slider0recv busid = pI "^slider0" busid --- | +-- | slider1 :: Pattern Double -> ControlPattern slider1 = pF "slider1" + slider1Take :: String -> [Double] -> ControlPattern slider1Take name xs = pStateListF "slider1" name xs + slider1Count :: String -> ControlPattern -slider1Count name = pStateF "slider1" name (maybe 0 (+1)) +slider1Count name = pStateF "slider1" name (maybe 0 (+ 1)) + slider1CountTo :: String -> Pattern Double -> Pattern ValueMap -slider1CountTo name ipat = innerJoin $ (\i -> pStateF "slider1" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +slider1CountTo name ipat = innerJoin $ (\i -> pStateF "slider1" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat slider1bus :: Pattern Int -> Pattern Double -> ControlPattern slider1bus busid pat = (pF "slider1" pat) # (pI "^slider1" busid) + slider1recv :: Pattern Int -> ControlPattern slider1recv busid = pI "^slider1" busid --- | +-- | slider10 :: Pattern Double -> ControlPattern slider10 = pF "slider10" + slider10Take :: String -> [Double] -> ControlPattern slider10Take name xs = pStateListF "slider10" name xs + slider10Count :: String -> ControlPattern -slider10Count name = pStateF "slider10" name (maybe 0 (+1)) +slider10Count name = pStateF "slider10" name (maybe 0 (+ 1)) + slider10CountTo :: String -> Pattern Double -> Pattern ValueMap -slider10CountTo name ipat = innerJoin $ (\i -> pStateF "slider10" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +slider10CountTo name ipat = innerJoin $ (\i -> pStateF "slider10" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat slider10bus :: Pattern Int -> Pattern Double -> ControlPattern slider10bus busid pat = (pF "slider10" pat) # (pI "^slider10" busid) + slider10recv :: Pattern Int -> ControlPattern slider10recv busid = pI "^slider10" busid --- | +-- | slider11 :: Pattern Double -> ControlPattern slider11 = pF "slider11" + slider11Take :: String -> [Double] -> ControlPattern slider11Take name xs = pStateListF "slider11" name xs + slider11Count :: String -> ControlPattern -slider11Count name = pStateF "slider11" name (maybe 0 (+1)) +slider11Count name = pStateF "slider11" name (maybe 0 (+ 1)) + slider11CountTo :: String -> Pattern Double -> Pattern ValueMap -slider11CountTo name ipat = innerJoin $ (\i -> pStateF "slider11" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +slider11CountTo name ipat = innerJoin $ (\i -> pStateF "slider11" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat slider11bus :: Pattern Int -> Pattern Double -> ControlPattern slider11bus busid pat = (pF "slider11" pat) # (pI "^slider11" busid) + slider11recv :: Pattern Int -> ControlPattern slider11recv busid = pI "^slider11" busid --- | +-- | slider12 :: Pattern Double -> ControlPattern slider12 = pF "slider12" + slider12Take :: String -> [Double] -> ControlPattern slider12Take name xs = pStateListF "slider12" name xs + slider12Count :: String -> ControlPattern -slider12Count name = pStateF "slider12" name (maybe 0 (+1)) +slider12Count name = pStateF "slider12" name (maybe 0 (+ 1)) + slider12CountTo :: String -> Pattern Double -> Pattern ValueMap -slider12CountTo name ipat = innerJoin $ (\i -> pStateF "slider12" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +slider12CountTo name ipat = innerJoin $ (\i -> pStateF "slider12" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat slider12bus :: Pattern Int -> Pattern Double -> ControlPattern slider12bus busid pat = (pF "slider12" pat) # (pI "^slider12" busid) + slider12recv :: Pattern Int -> ControlPattern slider12recv busid = pI "^slider12" busid --- | +-- | slider13 :: Pattern Double -> ControlPattern slider13 = pF "slider13" + slider13Take :: String -> [Double] -> ControlPattern slider13Take name xs = pStateListF "slider13" name xs + slider13Count :: String -> ControlPattern -slider13Count name = pStateF "slider13" name (maybe 0 (+1)) +slider13Count name = pStateF "slider13" name (maybe 0 (+ 1)) + slider13CountTo :: String -> Pattern Double -> Pattern ValueMap -slider13CountTo name ipat = innerJoin $ (\i -> pStateF "slider13" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +slider13CountTo name ipat = innerJoin $ (\i -> pStateF "slider13" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat slider13bus :: Pattern Int -> Pattern Double -> ControlPattern slider13bus busid pat = (pF "slider13" pat) # (pI "^slider13" busid) + slider13recv :: Pattern Int -> ControlPattern slider13recv busid = pI "^slider13" busid --- | +-- | slider14 :: Pattern Double -> ControlPattern slider14 = pF "slider14" + slider14Take :: String -> [Double] -> ControlPattern slider14Take name xs = pStateListF "slider14" name xs + slider14Count :: String -> ControlPattern -slider14Count name = pStateF "slider14" name (maybe 0 (+1)) +slider14Count name = pStateF "slider14" name (maybe 0 (+ 1)) + slider14CountTo :: String -> Pattern Double -> Pattern ValueMap -slider14CountTo name ipat = innerJoin $ (\i -> pStateF "slider14" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +slider14CountTo name ipat = innerJoin $ (\i -> pStateF "slider14" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat slider14bus :: Pattern Int -> Pattern Double -> ControlPattern slider14bus busid pat = (pF "slider14" pat) # (pI "^slider14" busid) + slider14recv :: Pattern Int -> ControlPattern slider14recv busid = pI "^slider14" busid --- | +-- | slider15 :: Pattern Double -> ControlPattern slider15 = pF "slider15" + slider15Take :: String -> [Double] -> ControlPattern slider15Take name xs = pStateListF "slider15" name xs + slider15Count :: String -> ControlPattern -slider15Count name = pStateF "slider15" name (maybe 0 (+1)) +slider15Count name = pStateF "slider15" name (maybe 0 (+ 1)) + slider15CountTo :: String -> Pattern Double -> Pattern ValueMap -slider15CountTo name ipat = innerJoin $ (\i -> pStateF "slider15" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +slider15CountTo name ipat = innerJoin $ (\i -> pStateF "slider15" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat slider15bus :: Pattern Int -> Pattern Double -> ControlPattern slider15bus busid pat = (pF "slider15" pat) # (pI "^slider15" busid) + slider15recv :: Pattern Int -> ControlPattern slider15recv busid = pI "^slider15" busid --- | +-- | slider2 :: Pattern Double -> ControlPattern slider2 = pF "slider2" + slider2Take :: String -> [Double] -> ControlPattern slider2Take name xs = pStateListF "slider2" name xs + slider2Count :: String -> ControlPattern -slider2Count name = pStateF "slider2" name (maybe 0 (+1)) +slider2Count name = pStateF "slider2" name (maybe 0 (+ 1)) + slider2CountTo :: String -> Pattern Double -> Pattern ValueMap -slider2CountTo name ipat = innerJoin $ (\i -> pStateF "slider2" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +slider2CountTo name ipat = innerJoin $ (\i -> pStateF "slider2" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat slider2bus :: Pattern Int -> Pattern Double -> ControlPattern slider2bus busid pat = (pF "slider2" pat) # (pI "^slider2" busid) + slider2recv :: Pattern Int -> ControlPattern slider2recv busid = pI "^slider2" busid --- | +-- | slider3 :: Pattern Double -> ControlPattern slider3 = pF "slider3" + slider3Take :: String -> [Double] -> ControlPattern slider3Take name xs = pStateListF "slider3" name xs + slider3Count :: String -> ControlPattern -slider3Count name = pStateF "slider3" name (maybe 0 (+1)) +slider3Count name = pStateF "slider3" name (maybe 0 (+ 1)) + slider3CountTo :: String -> Pattern Double -> Pattern ValueMap -slider3CountTo name ipat = innerJoin $ (\i -> pStateF "slider3" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +slider3CountTo name ipat = innerJoin $ (\i -> pStateF "slider3" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat slider3bus :: Pattern Int -> Pattern Double -> ControlPattern slider3bus busid pat = (pF "slider3" pat) # (pI "^slider3" busid) + slider3recv :: Pattern Int -> ControlPattern slider3recv busid = pI "^slider3" busid --- | +-- | slider4 :: Pattern Double -> ControlPattern slider4 = pF "slider4" + slider4Take :: String -> [Double] -> ControlPattern slider4Take name xs = pStateListF "slider4" name xs + slider4Count :: String -> ControlPattern -slider4Count name = pStateF "slider4" name (maybe 0 (+1)) +slider4Count name = pStateF "slider4" name (maybe 0 (+ 1)) + slider4CountTo :: String -> Pattern Double -> Pattern ValueMap -slider4CountTo name ipat = innerJoin $ (\i -> pStateF "slider4" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +slider4CountTo name ipat = innerJoin $ (\i -> pStateF "slider4" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat slider4bus :: Pattern Int -> Pattern Double -> ControlPattern slider4bus busid pat = (pF "slider4" pat) # (pI "^slider4" busid) + slider4recv :: Pattern Int -> ControlPattern slider4recv busid = pI "^slider4" busid --- | +-- | slider5 :: Pattern Double -> ControlPattern slider5 = pF "slider5" + slider5Take :: String -> [Double] -> ControlPattern slider5Take name xs = pStateListF "slider5" name xs + slider5Count :: String -> ControlPattern -slider5Count name = pStateF "slider5" name (maybe 0 (+1)) +slider5Count name = pStateF "slider5" name (maybe 0 (+ 1)) + slider5CountTo :: String -> Pattern Double -> Pattern ValueMap -slider5CountTo name ipat = innerJoin $ (\i -> pStateF "slider5" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +slider5CountTo name ipat = innerJoin $ (\i -> pStateF "slider5" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat slider5bus :: Pattern Int -> Pattern Double -> ControlPattern slider5bus busid pat = (pF "slider5" pat) # (pI "^slider5" busid) + slider5recv :: Pattern Int -> ControlPattern slider5recv busid = pI "^slider5" busid --- | +-- | slider6 :: Pattern Double -> ControlPattern slider6 = pF "slider6" + slider6Take :: String -> [Double] -> ControlPattern slider6Take name xs = pStateListF "slider6" name xs + slider6Count :: String -> ControlPattern -slider6Count name = pStateF "slider6" name (maybe 0 (+1)) +slider6Count name = pStateF "slider6" name (maybe 0 (+ 1)) + slider6CountTo :: String -> Pattern Double -> Pattern ValueMap -slider6CountTo name ipat = innerJoin $ (\i -> pStateF "slider6" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +slider6CountTo name ipat = innerJoin $ (\i -> pStateF "slider6" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat slider6bus :: Pattern Int -> Pattern Double -> ControlPattern slider6bus busid pat = (pF "slider6" pat) # (pI "^slider6" busid) + slider6recv :: Pattern Int -> ControlPattern slider6recv busid = pI "^slider6" busid --- | +-- | slider7 :: Pattern Double -> ControlPattern slider7 = pF "slider7" + slider7Take :: String -> [Double] -> ControlPattern slider7Take name xs = pStateListF "slider7" name xs + slider7Count :: String -> ControlPattern -slider7Count name = pStateF "slider7" name (maybe 0 (+1)) +slider7Count name = pStateF "slider7" name (maybe 0 (+ 1)) + slider7CountTo :: String -> Pattern Double -> Pattern ValueMap -slider7CountTo name ipat = innerJoin $ (\i -> pStateF "slider7" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +slider7CountTo name ipat = innerJoin $ (\i -> pStateF "slider7" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat slider7bus :: Pattern Int -> Pattern Double -> ControlPattern slider7bus busid pat = (pF "slider7" pat) # (pI "^slider7" busid) + slider7recv :: Pattern Int -> ControlPattern slider7recv busid = pI "^slider7" busid --- | +-- | slider8 :: Pattern Double -> ControlPattern slider8 = pF "slider8" + slider8Take :: String -> [Double] -> ControlPattern slider8Take name xs = pStateListF "slider8" name xs + slider8Count :: String -> ControlPattern -slider8Count name = pStateF "slider8" name (maybe 0 (+1)) +slider8Count name = pStateF "slider8" name (maybe 0 (+ 1)) + slider8CountTo :: String -> Pattern Double -> Pattern ValueMap -slider8CountTo name ipat = innerJoin $ (\i -> pStateF "slider8" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +slider8CountTo name ipat = innerJoin $ (\i -> pStateF "slider8" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat slider8bus :: Pattern Int -> Pattern Double -> ControlPattern slider8bus busid pat = (pF "slider8" pat) # (pI "^slider8" busid) + slider8recv :: Pattern Int -> ControlPattern slider8recv busid = pI "^slider8" busid --- | +-- | slider9 :: Pattern Double -> ControlPattern slider9 = pF "slider9" + slider9Take :: String -> [Double] -> ControlPattern slider9Take name xs = pStateListF "slider9" name xs + slider9Count :: String -> ControlPattern -slider9Count name = pStateF "slider9" name (maybe 0 (+1)) +slider9Count name = pStateF "slider9" name (maybe 0 (+ 1)) + slider9CountTo :: String -> Pattern Double -> Pattern ValueMap -slider9CountTo name ipat = innerJoin $ (\i -> pStateF "slider9" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +slider9CountTo name ipat = innerJoin $ (\i -> pStateF "slider9" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat slider9bus :: Pattern Int -> Pattern Double -> ControlPattern slider9bus busid pat = (pF "slider9" pat) # (pI "^slider9" busid) + slider9recv :: Pattern Int -> ControlPattern slider9recv busid = pI "^slider9" busid -- | Spectral smear smear :: Pattern Double -> ControlPattern smear = pF "smear" + smearTake :: String -> [Double] -> ControlPattern smearTake name xs = pStateListF "smear" name xs + smearCount :: String -> ControlPattern -smearCount name = pStateF "smear" name (maybe 0 (+1)) +smearCount name = pStateF "smear" name (maybe 0 (+ 1)) + smearCountTo :: String -> Pattern Double -> Pattern ValueMap -smearCountTo name ipat = innerJoin $ (\i -> pStateF "smear" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +smearCountTo name ipat = innerJoin $ (\i -> pStateF "smear" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat smearbus :: Pattern Int -> Pattern Double -> ControlPattern smearbus busid pat = (pF "smear" pat) # (pI "^smear" busid) + smearrecv :: Pattern Int -> ControlPattern smearrecv busid = pI "^smear" busid --- | +-- | songPtr :: Pattern Double -> ControlPattern songPtr = pF "songPtr" + songPtrTake :: String -> [Double] -> ControlPattern songPtrTake name xs = pStateListF "songPtr" name xs + songPtrCount :: String -> ControlPattern -songPtrCount name = pStateF "songPtr" name (maybe 0 (+1)) +songPtrCount name = pStateF "songPtr" name (maybe 0 (+ 1)) + songPtrCountTo :: String -> Pattern Double -> Pattern ValueMap -songPtrCountTo name ipat = innerJoin $ (\i -> pStateF "songPtr" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +songPtrCountTo name ipat = innerJoin $ (\i -> pStateF "songPtr" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat songPtrbus :: Pattern Int -> Pattern Double -> ControlPattern songPtrbus _ _ = error $ "Control parameter 'songPtr' can't be sent to a bus." -{-| - A pattern of numbers which changes the speed of sample playback which also - changes pitch. Negative values will play the sample backwards. - - > d1 $ slow 5 $ s "sax:5" # legato 1 # speed 0.5 - - This will play the @sax:5@ sample at half its rate. As a result, the sample will - last twice the normal time, and will be pitched a whole octave lower. This is - equivalent to @d1 $ slow 5 $ s "sax:5" # legato 1 |- note 12@. - - > d1 $ fast 2 $ s "breaks125:1" # cps (125/60/4) # speed (-2) - - In the above example, the break (which lasts for exactly one bar at 125 BPM), will be played backwards, and at double speed (so, we use @fast 2@ to fill the whole cycle). --} +-- | +-- A pattern of numbers which changes the speed of sample playback which also +-- changes pitch. Negative values will play the sample backwards. +-- +-- > d1 $ slow 5 $ s "sax:5" # legato 1 # speed 0.5 +-- +-- This will play the @sax:5@ sample at half its rate. As a result, the sample will +-- last twice the normal time, and will be pitched a whole octave lower. This is +-- equivalent to @d1 $ slow 5 $ s "sax:5" # legato 1 |- note 12@. +-- +-- > d1 $ fast 2 $ s "breaks125:1" # cps (125/60/4) # speed (-2) +-- +-- In the above example, the break (which lasts for exactly one bar at 125 BPM), will be played backwards, and at double speed (so, we use @fast 2@ to fill the whole cycle). speed :: Pattern Double -> ControlPattern speed = pF "speed" + speedTake :: String -> [Double] -> ControlPattern speedTake name xs = pStateListF "speed" name xs + speedCount :: String -> ControlPattern -speedCount name = pStateF "speed" name (maybe 0 (+1)) +speedCount name = pStateF "speed" name (maybe 0 (+ 1)) + speedCountTo :: String -> Pattern Double -> Pattern ValueMap -speedCountTo name ipat = innerJoin $ (\i -> pStateF "speed" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +speedCountTo name ipat = innerJoin $ (\i -> pStateF "speed" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat speedbus :: Pattern Int -> Pattern Double -> ControlPattern speedbus _ _ = error $ "Control parameter 'speed' can't be sent to a bus." --- | +-- | squiz :: Pattern Double -> ControlPattern squiz = pF "squiz" + squizTake :: String -> [Double] -> ControlPattern squizTake name xs = pStateListF "squiz" name xs + squizCount :: String -> ControlPattern -squizCount name = pStateF "squiz" name (maybe 0 (+1)) +squizCount name = pStateF "squiz" name (maybe 0 (+ 1)) + squizCountTo :: String -> Pattern Double -> Pattern ValueMap -squizCountTo name ipat = innerJoin $ (\i -> pStateF "squiz" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +squizCountTo name ipat = innerJoin $ (\i -> pStateF "squiz" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat squizbus :: Pattern Int -> Pattern Double -> ControlPattern squizbus busid pat = (pF "squiz" pat) # (pI "^squiz" busid) + squizrecv :: Pattern Int -> ControlPattern squizrecv busid = pI "^squiz" busid --- | +-- | stepsPerOctave :: Pattern Double -> ControlPattern stepsPerOctave = pF "stepsPerOctave" + stepsPerOctaveTake :: String -> [Double] -> ControlPattern stepsPerOctaveTake name xs = pStateListF "stepsPerOctave" name xs + stepsPerOctaveCount :: String -> ControlPattern -stepsPerOctaveCount name = pStateF "stepsPerOctave" name (maybe 0 (+1)) +stepsPerOctaveCount name = pStateF "stepsPerOctave" name (maybe 0 (+ 1)) + stepsPerOctaveCountTo :: String -> Pattern Double -> Pattern ValueMap -stepsPerOctaveCountTo name ipat = innerJoin $ (\i -> pStateF "stepsPerOctave" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +stepsPerOctaveCountTo name ipat = innerJoin $ (\i -> pStateF "stepsPerOctave" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat stepsPerOctavebus :: Pattern Int -> Pattern Double -> ControlPattern stepsPerOctavebus busid pat = (pF "stepsPerOctave" pat) # (pI "^stepsPerOctave" busid) + stepsPerOctaverecv :: Pattern Int -> ControlPattern stepsPerOctaverecv busid = pI "^stepsPerOctave" busid --- | +-- | stutterdepth :: Pattern Double -> ControlPattern stutterdepth = pF "stutterdepth" + stutterdepthTake :: String -> [Double] -> ControlPattern stutterdepthTake name xs = pStateListF "stutterdepth" name xs + stutterdepthCount :: String -> ControlPattern -stutterdepthCount name = pStateF "stutterdepth" name (maybe 0 (+1)) +stutterdepthCount name = pStateF "stutterdepth" name (maybe 0 (+ 1)) + stutterdepthCountTo :: String -> Pattern Double -> Pattern ValueMap -stutterdepthCountTo name ipat = innerJoin $ (\i -> pStateF "stutterdepth" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +stutterdepthCountTo name ipat = innerJoin $ (\i -> pStateF "stutterdepth" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat stutterdepthbus :: Pattern Int -> Pattern Double -> ControlPattern stutterdepthbus busid pat = (pF "stutterdepth" pat) # (pI "^stutterdepth" busid) + stutterdepthrecv :: Pattern Int -> ControlPattern stutterdepthrecv busid = pI "^stutterdepth" busid --- | +-- | stuttertime :: Pattern Double -> ControlPattern stuttertime = pF "stuttertime" + stuttertimeTake :: String -> [Double] -> ControlPattern stuttertimeTake name xs = pStateListF "stuttertime" name xs + stuttertimeCount :: String -> ControlPattern -stuttertimeCount name = pStateF "stuttertime" name (maybe 0 (+1)) +stuttertimeCount name = pStateF "stuttertime" name (maybe 0 (+ 1)) + stuttertimeCountTo :: String -> Pattern Double -> Pattern ValueMap -stuttertimeCountTo name ipat = innerJoin $ (\i -> pStateF "stuttertime" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +stuttertimeCountTo name ipat = innerJoin $ (\i -> pStateF "stuttertime" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat stuttertimebus :: Pattern Int -> Pattern Double -> ControlPattern stuttertimebus busid pat = (pF "stuttertime" pat) # (pI "^stuttertime" busid) + stuttertimerecv :: Pattern Int -> ControlPattern stuttertimerecv busid = pI "^stuttertime" busid -{-| - A pattern of numbers that indicates the total duration of sample playback in seconds. - - This @sustain@ refers to the whole playback duration and is not to be confused with the sustain level of a typical ADSR envelope. - - > d1 $ fast 2 $ s "breaks125:1" # cps (120/60/4) # sustain 1 - - At 120 BPM, a cycle lasts for two seconds. In the above example, we cut the - sample so it plays just for one second, and repeat this part two times, so we - fill the whole cycle. Note that sample pitch isn’t modified. - - > d1 $ s "breaks125:2!3" # cps (120/60/4) # sustain "0.4 0.2 0.4" # begin "0 0 0.4" - - Here, we take advantage that sustain receives a pattern to build a different - break from the original sample. --} +-- | +-- A pattern of numbers that indicates the total duration of sample playback in seconds. +-- +-- This @sustain@ refers to the whole playback duration and is not to be confused with the sustain level of a typical ADSR envelope. +-- +-- > d1 $ fast 2 $ s "breaks125:1" # cps (120/60/4) # sustain 1 +-- +-- At 120 BPM, a cycle lasts for two seconds. In the above example, we cut the +-- sample so it plays just for one second, and repeat this part two times, so we +-- fill the whole cycle. Note that sample pitch isn’t modified. +-- +-- > d1 $ s "breaks125:2!3" # cps (120/60/4) # sustain "0.4 0.2 0.4" # begin "0 0 0.4" +-- +-- Here, we take advantage that sustain receives a pattern to build a different +-- break from the original sample. sustain :: Pattern Double -> ControlPattern sustain = pF "sustain" + sustainTake :: String -> [Double] -> ControlPattern sustainTake name xs = pStateListF "sustain" name xs + sustainCount :: String -> ControlPattern -sustainCount name = pStateF "sustain" name (maybe 0 (+1)) +sustainCount name = pStateF "sustain" name (maybe 0 (+ 1)) + sustainCountTo :: String -> Pattern Double -> Pattern ValueMap -sustainCountTo name ipat = innerJoin $ (\i -> pStateF "sustain" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +sustainCountTo name ipat = innerJoin $ (\i -> pStateF "sustain" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat sustainbus :: Pattern Int -> Pattern Double -> ControlPattern sustainbus _ _ = error $ "Control parameter 'sustain' can't be sent to a bus." --- | +-- | sustainpedal :: Pattern Double -> ControlPattern sustainpedal = pF "sustainpedal" + sustainpedalTake :: String -> [Double] -> ControlPattern sustainpedalTake name xs = pStateListF "sustainpedal" name xs + sustainpedalCount :: String -> ControlPattern -sustainpedalCount name = pStateF "sustainpedal" name (maybe 0 (+1)) +sustainpedalCount name = pStateF "sustainpedal" name (maybe 0 (+ 1)) + sustainpedalCountTo :: String -> Pattern Double -> Pattern ValueMap -sustainpedalCountTo name ipat = innerJoin $ (\i -> pStateF "sustainpedal" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +sustainpedalCountTo name ipat = innerJoin $ (\i -> pStateF "sustainpedal" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat sustainpedalbus :: Pattern Int -> Pattern Double -> ControlPattern sustainpedalbus busid pat = (pF "sustainpedal" pat) # (pI "^sustainpedal" busid) + sustainpedalrecv :: Pattern Int -> ControlPattern sustainpedalrecv busid = pI "^sustainpedal" busid -{- | - @timescale@ is the main function used to activate time-stretching, and usually - the only one you need. It receives a single parameter which is the stretching - rate to apply. - - You can use any positive number as the ratio, but the particular method used is - designed for ratios greater than 1, and work reasonably well for values between - 0.1 and 3. - - > d1 $ slow 2 $ s "breaks152" # legato 1 # timescale (152/130) # cps (130/60/4) - - In the example above, we set tempo at 130 beats per minute. But we want to play - one of the @breaks152@ samples, which are, as indicated, at 152 BPM. So, the - ratio we want is 152 over 130. This will slow down the sample to fit in our 130 - BPM tempo. --} +-- | +-- @timescale@ is the main function used to activate time-stretching, and usually +-- the only one you need. It receives a single parameter which is the stretching +-- rate to apply. +-- +-- You can use any positive number as the ratio, but the particular method used is +-- designed for ratios greater than 1, and work reasonably well for values between +-- 0.1 and 3. +-- +-- > d1 $ slow 2 $ s "breaks152" # legato 1 # timescale (152/130) # cps (130/60/4) +-- +-- In the example above, we set tempo at 130 beats per minute. But we want to play +-- one of the @breaks152@ samples, which are, as indicated, at 152 BPM. So, the +-- ratio we want is 152 over 130. This will slow down the sample to fit in our 130 +-- BPM tempo. timescale :: Pattern Double -> ControlPattern timescale = pF "timescale" timescaleTake :: String -> [Double] -> ControlPattern timescaleTake name xs = pStateListF "timescale" name xs + timescaleCount :: String -> ControlPattern -timescaleCount name = pStateF "timescale" name (maybe 0 (+1)) +timescaleCount name = pStateF "timescale" name (maybe 0 (+ 1)) + timescaleCountTo :: String -> Pattern Double -> Pattern ValueMap -timescaleCountTo name ipat = innerJoin $ (\i -> pStateF "timescale" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +timescaleCountTo name ipat = innerJoin $ (\i -> pStateF "timescale" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat timescalebus :: Pattern Int -> Pattern Double -> ControlPattern timescalebus _ _ = error $ "Control parameter 'timescale' can't be sent to a bus." -{- | Time stretch window size. - -The algorithm used to time-stretch a sample divides a sample in many little parts, modifies them, and puts them all together again. It uses one particular parameter, called @windowSize@, which is the length of each sample part. - -The @windowSize@ value is automatically calculated, but can be changed with @timescalewin@. The @windowSize@ value is multiplied by the number provided. - -@timescalewin@ can be used to improve the quality of time-stretching for some samples, or simply as an effect. - -Consider the following two examples. In the first one, @timescalewin 0.01@ makes -the window size a lot smaller, and the extreme chopping of the sample causes -a rougher sound. In the second one, @timescalewin 10@ makes the chunks a lot -bigger. The method used overlaps the treated chunks when recomposing the sample, -and, with the bigger window size, this overlap is noticeable and causes a kind -of delay effect. - -> d1 $ slow 2 -> $ s "breaks152" -> # legato 1 -> # timescale (152/130) -> # timescalewin 0.01 -> # cps (130/60/4) - -> d1 $ slow 2 -> $ s "breaks152" -> # legato 1 -> # timescale (152/130) -> # timescalewin 10 -> # cps (130/60/4) - --} +-- | Time stretch window size. +-- +-- The algorithm used to time-stretch a sample divides a sample in many little parts, modifies them, and puts them all together again. It uses one particular parameter, called @windowSize@, which is the length of each sample part. +-- +-- The @windowSize@ value is automatically calculated, but can be changed with @timescalewin@. The @windowSize@ value is multiplied by the number provided. +-- +-- @timescalewin@ can be used to improve the quality of time-stretching for some samples, or simply as an effect. +-- +-- Consider the following two examples. In the first one, @timescalewin 0.01@ makes +-- the window size a lot smaller, and the extreme chopping of the sample causes +-- a rougher sound. In the second one, @timescalewin 10@ makes the chunks a lot +-- bigger. The method used overlaps the treated chunks when recomposing the sample, +-- and, with the bigger window size, this overlap is noticeable and causes a kind +-- of delay effect. +-- +-- > d1 $ slow 2 +-- > $ s "breaks152" +-- > # legato 1 +-- > # timescale (152/130) +-- > # timescalewin 0.01 +-- > # cps (130/60/4) +-- +-- > d1 $ slow 2 +-- > $ s "breaks152" +-- > # legato 1 +-- > # timescale (152/130) +-- > # timescalewin 10 +-- > # cps (130/60/4) timescalewin :: Pattern Double -> ControlPattern timescalewin = pF "timescalewin" timescalewinTake :: String -> [Double] -> ControlPattern timescalewinTake name xs = pStateListF "timescalewin" name xs + timescalewinCount :: String -> ControlPattern -timescalewinCount name = pStateF "timescalewin" name (maybe 0 (+1)) +timescalewinCount name = pStateF "timescalewin" name (maybe 0 (+ 1)) + timescalewinCountTo :: String -> Pattern Double -> Pattern ValueMap -timescalewinCountTo name ipat = innerJoin $ (\i -> pStateF "timescalewin" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +timescalewinCountTo name ipat = innerJoin $ (\i -> pStateF "timescalewin" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat timescalewinbus :: Pattern Int -> Pattern Double -> ControlPattern timescalewinbus _ _ = error $ "Control parameter 'timescalewin' can't be sent to a bus." @@ -2928,273 +3602,338 @@ timescalewinbus _ _ = error $ "Control parameter 'timescalewin' can't be sent to -- | for internal sound routing to :: Pattern Double -> ControlPattern to = pF "to" + toTake :: String -> [Double] -> ControlPattern toTake name xs = pStateListF "to" name xs + toCount :: String -> ControlPattern -toCount name = pStateF "to" name (maybe 0 (+1)) +toCount name = pStateF "to" name (maybe 0 (+ 1)) + toCountTo :: String -> Pattern Double -> Pattern ValueMap -toCountTo name ipat = innerJoin $ (\i -> pStateF "to" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +toCountTo name ipat = innerJoin $ (\i -> pStateF "to" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat tobus :: Pattern Int -> Pattern Double -> ControlPattern tobus busid pat = (pF "to" pat) # (pI "^to" busid) + torecv :: Pattern Int -> ControlPattern torecv busid = pI "^to" busid -- | for internal sound routing toArg :: Pattern String -> ControlPattern toArg = pS "toArg" + toArgTake :: String -> [Double] -> ControlPattern toArgTake name xs = pStateListF "toArg" name xs + toArgbus :: Pattern Int -> Pattern String -> ControlPattern toArgbus busid pat = (pS "toArg" pat) # (pI "^toArg" busid) + toArgrecv :: Pattern Int -> ControlPattern toArgrecv busid = pI "^toArg" busid --- | +-- | tomdecay :: Pattern Double -> ControlPattern tomdecay = pF "tomdecay" + tomdecayTake :: String -> [Double] -> ControlPattern tomdecayTake name xs = pStateListF "tomdecay" name xs + tomdecayCount :: String -> ControlPattern -tomdecayCount name = pStateF "tomdecay" name (maybe 0 (+1)) +tomdecayCount name = pStateF "tomdecay" name (maybe 0 (+ 1)) + tomdecayCountTo :: String -> Pattern Double -> Pattern ValueMap -tomdecayCountTo name ipat = innerJoin $ (\i -> pStateF "tomdecay" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +tomdecayCountTo name ipat = innerJoin $ (\i -> pStateF "tomdecay" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat tomdecaybus :: Pattern Int -> Pattern Double -> ControlPattern tomdecaybus busid pat = (pF "tomdecay" pat) # (pI "^tomdecay" busid) + tomdecayrecv :: Pattern Int -> ControlPattern tomdecayrecv busid = pI "^tomdecay" busid -- | Tremolo Audio DSP effect | params are 'tremolorate' and 'tremolodepth' tremolodepth :: Pattern Double -> ControlPattern tremolodepth = pF "tremolodepth" + tremolodepthTake :: String -> [Double] -> ControlPattern tremolodepthTake name xs = pStateListF "tremolodepth" name xs + tremolodepthCount :: String -> ControlPattern -tremolodepthCount name = pStateF "tremolodepth" name (maybe 0 (+1)) +tremolodepthCount name = pStateF "tremolodepth" name (maybe 0 (+ 1)) + tremolodepthCountTo :: String -> Pattern Double -> Pattern ValueMap -tremolodepthCountTo name ipat = innerJoin $ (\i -> pStateF "tremolodepth" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +tremolodepthCountTo name ipat = innerJoin $ (\i -> pStateF "tremolodepth" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat tremolodepthbus :: Pattern Int -> Pattern Double -> ControlPattern tremolodepthbus busid pat = (pF "tremolodepth" pat) # (pI "^tremolodepth" busid) + tremolodepthrecv :: Pattern Int -> ControlPattern tremolodepthrecv busid = pI "^tremolodepth" busid -- | Tremolo Audio DSP effect | params are 'tremolorate' and 'tremolodepth' tremolorate :: Pattern Double -> ControlPattern tremolorate = pF "tremolorate" + tremolorateTake :: String -> [Double] -> ControlPattern tremolorateTake name xs = pStateListF "tremolorate" name xs + tremolorateCount :: String -> ControlPattern -tremolorateCount name = pStateF "tremolorate" name (maybe 0 (+1)) +tremolorateCount name = pStateF "tremolorate" name (maybe 0 (+ 1)) + tremolorateCountTo :: String -> Pattern Double -> Pattern ValueMap -tremolorateCountTo name ipat = innerJoin $ (\i -> pStateF "tremolorate" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +tremolorateCountTo name ipat = innerJoin $ (\i -> pStateF "tremolorate" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat tremoloratebus :: Pattern Int -> Pattern Double -> ControlPattern tremoloratebus busid pat = (pF "tremolorate" pat) # (pI "^tremolorate" busid) + tremoloraterecv :: Pattern Int -> ControlPattern tremoloraterecv busid = pI "^tremolorate" busid -- | tube distortion triode :: Pattern Double -> ControlPattern triode = pF "triode" + triodeTake :: String -> [Double] -> ControlPattern triodeTake name xs = pStateListF "triode" name xs + triodeCount :: String -> ControlPattern -triodeCount name = pStateF "triode" name (maybe 0 (+1)) +triodeCount name = pStateF "triode" name (maybe 0 (+ 1)) + triodeCountTo :: String -> Pattern Double -> Pattern ValueMap -triodeCountTo name ipat = innerJoin $ (\i -> pStateF "triode" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +triodeCountTo name ipat = innerJoin $ (\i -> pStateF "triode" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat triodebus :: Pattern Int -> Pattern Double -> ControlPattern triodebus busid pat = (pF "triode" pat) # (pI "^triode" busid) + trioderecv :: Pattern Int -> ControlPattern trioderecv busid = pI "^triode" busid --- | +-- | tsdelay :: Pattern Double -> ControlPattern tsdelay = pF "tsdelay" + tsdelayTake :: String -> [Double] -> ControlPattern tsdelayTake name xs = pStateListF "tsdelay" name xs + tsdelayCount :: String -> ControlPattern -tsdelayCount name = pStateF "tsdelay" name (maybe 0 (+1)) +tsdelayCount name = pStateF "tsdelay" name (maybe 0 (+ 1)) + tsdelayCountTo :: String -> Pattern Double -> Pattern ValueMap -tsdelayCountTo name ipat = innerJoin $ (\i -> pStateF "tsdelay" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +tsdelayCountTo name ipat = innerJoin $ (\i -> pStateF "tsdelay" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat tsdelaybus :: Pattern Int -> Pattern Double -> ControlPattern tsdelaybus busid pat = (pF "tsdelay" pat) # (pI "^tsdelay" busid) + tsdelayrecv :: Pattern Int -> ControlPattern tsdelayrecv busid = pI "^tsdelay" busid --- | +-- | uid :: Pattern Double -> ControlPattern uid = pF "uid" + uidTake :: String -> [Double] -> ControlPattern uidTake name xs = pStateListF "uid" name xs + uidCount :: String -> ControlPattern -uidCount name = pStateF "uid" name (maybe 0 (+1)) +uidCount name = pStateF "uid" name (maybe 0 (+ 1)) + uidCountTo :: String -> Pattern Double -> Pattern ValueMap -uidCountTo name ipat = innerJoin $ (\i -> pStateF "uid" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +uidCountTo name ipat = innerJoin $ (\i -> pStateF "uid" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat uidbus :: Pattern Int -> Pattern Double -> ControlPattern uidbus _ _ = error $ "Control parameter 'uid' can't be sent to a bus." -{- | - Used in conjunction with `speed`. It accepts values of @r@ (rate, default - behavior), @c@ (cycles), or @s@ (seconds). Using @unit "c"@ means `speed` - will be interpreted in units of cycles, e.g. @speed "1"@ means samples will be - stretched to fill a cycle. Using @unit "s"@ means the playback speed will be - adjusted so that the duration is the number of seconds specified by `speed`. - - In the following example, @speed 2@ means that samples will be stretched to fill - half a cycle: - - > d1 $ stack [ - > s "sax:5" # legato 1 # speed 2 # unit "c", - > s "bd*2" - > ] --} +-- | +-- Used in conjunction with `speed`. It accepts values of @r@ (rate, default +-- behavior), @c@ (cycles), or @s@ (seconds). Using @unit "c"@ means `speed` +-- will be interpreted in units of cycles, e.g. @speed "1"@ means samples will be +-- stretched to fill a cycle. Using @unit "s"@ means the playback speed will be +-- adjusted so that the duration is the number of seconds specified by `speed`. +-- +-- In the following example, @speed 2@ means that samples will be stretched to fill +-- half a cycle: +-- +-- > d1 $ stack [ +-- > s "sax:5" # legato 1 # speed 2 # unit "c", +-- > s "bd*2" +-- > ] unit :: Pattern String -> ControlPattern unit = pS "unit" + unitTake :: String -> [Double] -> ControlPattern unitTake name xs = pStateListF "unit" name xs + unitbus :: Pattern Int -> Pattern String -> ControlPattern unitbus _ _ = error $ "Control parameter 'unit' can't be sent to a bus." --- | +-- | val :: Pattern Double -> ControlPattern val = pF "val" + valTake :: String -> [Double] -> ControlPattern valTake name xs = pStateListF "val" name xs + valCount :: String -> ControlPattern -valCount name = pStateF "val" name (maybe 0 (+1)) +valCount name = pStateF "val" name (maybe 0 (+ 1)) + valCountTo :: String -> Pattern Double -> Pattern ValueMap -valCountTo name ipat = innerJoin $ (\i -> pStateF "val" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +valCountTo name ipat = innerJoin $ (\i -> pStateF "val" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat valbus :: Pattern Int -> Pattern Double -> ControlPattern valbus _ _ = error $ "Control parameter 'val' can't be sent to a bus." --- | +-- | vcfegint :: Pattern Double -> ControlPattern vcfegint = pF "vcfegint" + vcfegintTake :: String -> [Double] -> ControlPattern vcfegintTake name xs = pStateListF "vcfegint" name xs + vcfegintCount :: String -> ControlPattern -vcfegintCount name = pStateF "vcfegint" name (maybe 0 (+1)) +vcfegintCount name = pStateF "vcfegint" name (maybe 0 (+ 1)) + vcfegintCountTo :: String -> Pattern Double -> Pattern ValueMap -vcfegintCountTo name ipat = innerJoin $ (\i -> pStateF "vcfegint" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +vcfegintCountTo name ipat = innerJoin $ (\i -> pStateF "vcfegint" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat vcfegintbus :: Pattern Int -> Pattern Double -> ControlPattern vcfegintbus busid pat = (pF "vcfegint" pat) # (pI "^vcfegint" busid) + vcfegintrecv :: Pattern Int -> ControlPattern vcfegintrecv busid = pI "^vcfegint" busid --- | +-- | vcoegint :: Pattern Double -> ControlPattern vcoegint = pF "vcoegint" + vcoegintTake :: String -> [Double] -> ControlPattern vcoegintTake name xs = pStateListF "vcoegint" name xs + vcoegintCount :: String -> ControlPattern -vcoegintCount name = pStateF "vcoegint" name (maybe 0 (+1)) +vcoegintCount name = pStateF "vcoegint" name (maybe 0 (+ 1)) + vcoegintCountTo :: String -> Pattern Double -> Pattern ValueMap -vcoegintCountTo name ipat = innerJoin $ (\i -> pStateF "vcoegint" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +vcoegintCountTo name ipat = innerJoin $ (\i -> pStateF "vcoegint" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat vcoegintbus :: Pattern Int -> Pattern Double -> ControlPattern vcoegintbus busid pat = (pF "vcoegint" pat) # (pI "^vcoegint" busid) + vcoegintrecv :: Pattern Int -> ControlPattern vcoegintrecv busid = pI "^vcoegint" busid --- | +-- | velocity :: Pattern Double -> ControlPattern velocity = pF "velocity" + velocityTake :: String -> [Double] -> ControlPattern velocityTake name xs = pStateListF "velocity" name xs + velocityCount :: String -> ControlPattern -velocityCount name = pStateF "velocity" name (maybe 0 (+1)) +velocityCount name = pStateF "velocity" name (maybe 0 (+ 1)) + velocityCountTo :: String -> Pattern Double -> Pattern ValueMap -velocityCountTo name ipat = innerJoin $ (\i -> pStateF "velocity" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +velocityCountTo name ipat = innerJoin $ (\i -> pStateF "velocity" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat velocitybus :: Pattern Int -> Pattern Double -> ControlPattern velocitybus busid pat = (pF "velocity" pat) # (pI "^velocity" busid) + velocityrecv :: Pattern Int -> ControlPattern velocityrecv busid = pI "^velocity" busid --- | +-- | voice :: Pattern Double -> ControlPattern voice = pF "voice" + voiceTake :: String -> [Double] -> ControlPattern voiceTake name xs = pStateListF "voice" name xs + voiceCount :: String -> ControlPattern -voiceCount name = pStateF "voice" name (maybe 0 (+1)) +voiceCount name = pStateF "voice" name (maybe 0 (+ 1)) + voiceCountTo :: String -> Pattern Double -> Pattern ValueMap -voiceCountTo name ipat = innerJoin $ (\i -> pStateF "voice" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +voiceCountTo name ipat = innerJoin $ (\i -> pStateF "voice" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat voicebus :: Pattern Int -> Pattern Double -> ControlPattern voicebus busid pat = (pF "voice" pat) # (pI "^voice" busid) + voicerecv :: Pattern Int -> ControlPattern voicerecv busid = pI "^voice" busid -- | formant filter to make things sound like vowels, a pattern of either `a`, `e`, `i`, `o` or `u`. Use a rest (`~`) for no effect. vowel :: Pattern String -> ControlPattern vowel = pS "vowel" + vowelTake :: String -> [Double] -> ControlPattern vowelTake name xs = pStateListF "vowel" name xs + vowelbus :: Pattern Int -> Pattern String -> ControlPattern vowelbus busid pat = (pS "vowel" pat) # (pI "^vowel" busid) + vowelrecv :: Pattern Int -> ControlPattern vowelrecv busid = pI "^vowel" busid --- | +-- | waveloss :: Pattern Double -> ControlPattern waveloss = pF "waveloss" + wavelossTake :: String -> [Double] -> ControlPattern wavelossTake name xs = pStateListF "waveloss" name xs + wavelossCount :: String -> ControlPattern -wavelossCount name = pStateF "waveloss" name (maybe 0 (+1)) +wavelossCount name = pStateF "waveloss" name (maybe 0 (+ 1)) + wavelossCountTo :: String -> Pattern Double -> Pattern ValueMap -wavelossCountTo name ipat = innerJoin $ (\i -> pStateF "waveloss" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +wavelossCountTo name ipat = innerJoin $ (\i -> pStateF "waveloss" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat wavelossbus :: Pattern Int -> Pattern Double -> ControlPattern wavelossbus busid pat = (pF "waveloss" pat) # (pI "^waveloss" busid) + wavelossrecv :: Pattern Int -> ControlPattern wavelossrecv busid = pI "^waveloss" busid --- | +-- | xsdelay :: Pattern Double -> ControlPattern xsdelay = pF "xsdelay" + xsdelayTake :: String -> [Double] -> ControlPattern xsdelayTake name xs = pStateListF "xsdelay" name xs + xsdelayCount :: String -> ControlPattern -xsdelayCount name = pStateF "xsdelay" name (maybe 0 (+1)) +xsdelayCount name = pStateF "xsdelay" name (maybe 0 (+ 1)) + xsdelayCountTo :: String -> Pattern Double -> Pattern ValueMap -xsdelayCountTo name ipat = innerJoin $ (\i -> pStateF "xsdelay" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat +xsdelayCountTo name ipat = innerJoin $ (\i -> pStateF "xsdelay" name (maybe 0 ((`mod'` i) . (+ 1)))) <$> ipat xsdelaybus :: Pattern Int -> Pattern Double -> ControlPattern xsdelaybus busid pat = (pF "xsdelay" pat) # (pI "^xsdelay" busid) + xsdelayrecv :: Pattern Int -> ControlPattern xsdelayrecv busid = pI "^xsdelay" busid - - -- * Aliases voi :: Pattern Double -> ControlPattern voi = voice + voibus :: Pattern Int -> Pattern Double -> ControlPattern voibus = voicebus + voirecv :: Pattern Int -> ControlPattern voirecv = voicerecv vco :: Pattern Double -> ControlPattern vco = vcoegint + vcobus :: Pattern Int -> Pattern Double -> ControlPattern vcobus = vcoegintbus + vcorecv :: Pattern Int -> ControlPattern vcorecv = vcoegintrecv vcf :: Pattern Double -> ControlPattern vcf = vcfegint + vcfbus :: Pattern Int -> Pattern Double -> ControlPattern vcfbus = vcfegintbus + vcfrecv :: Pattern Int -> ControlPattern vcfrecv = vcfegintrecv @@ -3203,29 +3942,37 @@ up = note tremr :: Pattern Double -> ControlPattern tremr = tremolorate + tremrbus :: Pattern Int -> Pattern Double -> ControlPattern tremrbus = tremoloratebus + tremrrecv :: Pattern Int -> ControlPattern tremrrecv = tremoloraterecv tremdp :: Pattern Double -> ControlPattern tremdp = tremolodepth + tremdpbus :: Pattern Int -> Pattern Double -> ControlPattern tremdpbus = tremolodepthbus + tremdprecv :: Pattern Int -> ControlPattern tremdprecv = tremolodepthrecv tdecay :: Pattern Double -> ControlPattern tdecay = tomdecay + tdecaybus :: Pattern Int -> Pattern Double -> ControlPattern tdecaybus = tomdecaybus + tdecayrecv :: Pattern Int -> ControlPattern tdecayrecv = tomdecayrecv sz :: Pattern Double -> ControlPattern sz = size + szbus :: Pattern Int -> Pattern Double -> ControlPattern szbus = sizebus + szrecv :: Pattern Int -> ControlPattern szrecv = sizerecv @@ -3234,50 +3981,64 @@ sus = sustain stt :: Pattern Double -> ControlPattern stt = stuttertime + sttbus :: Pattern Int -> Pattern Double -> ControlPattern sttbus = stuttertimebus + sttrecv :: Pattern Int -> ControlPattern sttrecv = stuttertimerecv std :: Pattern Double -> ControlPattern std = stutterdepth + stdbus :: Pattern Int -> Pattern Double -> ControlPattern stdbus = stutterdepthbus + stdrecv :: Pattern Int -> ControlPattern stdrecv = stutterdepthrecv sld :: Pattern Double -> ControlPattern sld = slide + sldbus :: Pattern Int -> Pattern Double -> ControlPattern sldbus = slidebus + sldrecv :: Pattern Int -> ControlPattern sldrecv = sliderecv scr :: Pattern Double -> ControlPattern scr = scrash + scrbus :: Pattern Int -> Pattern Double -> ControlPattern scrbus = scrashbus + scrrecv :: Pattern Int -> ControlPattern scrrecv = scrashrecv scp :: Pattern Double -> ControlPattern scp = sclap + scpbus :: Pattern Int -> Pattern Double -> ControlPattern scpbus = sclapbus + scprecv :: Pattern Int -> ControlPattern scprecv = sclaprecv scl :: Pattern Double -> ControlPattern scl = sclaves + sclbus :: Pattern Int -> Pattern Double -> ControlPattern sclbus = sclavesbus + sclrecv :: Pattern Int -> ControlPattern sclrecv = sclavesrecv sag :: Pattern Double -> ControlPattern sag = sagogo + sagbus :: Pattern Int -> Pattern Double -> ControlPattern sagbus = sagogobus + sagrecv :: Pattern Int -> ControlPattern sagrecv = sagogorecv @@ -3286,57 +4047,73 @@ s = sound rel :: Pattern Double -> ControlPattern rel = release + relbus :: Pattern Int -> Pattern Double -> ControlPattern relbus = releasebus + relrecv :: Pattern Int -> ControlPattern relrecv = releaserecv por :: Pattern Double -> ControlPattern por = portamento + porbus :: Pattern Int -> Pattern Double -> ControlPattern porbus = portamentobus + porrecv :: Pattern Int -> ControlPattern porrecv = portamentorecv pit3 :: Pattern Double -> ControlPattern pit3 = pitch3 + pit3bus :: Pattern Int -> Pattern Double -> ControlPattern pit3bus = pitch3bus + pit3recv :: Pattern Int -> ControlPattern pit3recv = pitch3recv pit2 :: Pattern Double -> ControlPattern pit2 = pitch2 + pit2bus :: Pattern Int -> Pattern Double -> ControlPattern pit2bus = pitch2bus + pit2recv :: Pattern Int -> ControlPattern pit2recv = pitch2recv pit1 :: Pattern Double -> ControlPattern pit1 = pitch1 + pit1bus :: Pattern Int -> Pattern Double -> ControlPattern pit1bus = pitch1bus + pit1recv :: Pattern Int -> ControlPattern pit1recv = pitch1recv phasr :: Pattern Double -> ControlPattern phasr = phaserrate + phasrbus :: Pattern Int -> Pattern Double -> ControlPattern phasrbus = phaserratebus + phasrrecv :: Pattern Int -> ControlPattern phasrrecv = phaserraterecv phasdp :: Pattern Double -> ControlPattern phasdp = phaserdepth + phasdpbus :: Pattern Int -> Pattern Double -> ControlPattern phasdpbus = phaserdepthbus + phasdprecv :: Pattern Int -> ControlPattern phasdprecv = phaserdepthrecv ohdecay :: Pattern Double -> ControlPattern ohdecay = ophatdecay + ohdecaybus :: Pattern Int -> Pattern Double -> ControlPattern ohdecaybus = ophatdecaybus + ohdecayrecv :: Pattern Int -> ControlPattern ohdecayrecv = ophatdecayrecv @@ -3345,134 +4122,172 @@ number = n lsn :: Pattern Double -> ControlPattern lsn = lsnare + lsnbus :: Pattern Int -> Pattern Double -> ControlPattern lsnbus = lsnarebus + lsnrecv :: Pattern Int -> ControlPattern lsnrecv = lsnarerecv lpq :: Pattern Double -> ControlPattern lpq = resonance + lpqbus :: Pattern Int -> Pattern Double -> ControlPattern lpqbus = resonancebus + lpqrecv :: Pattern Int -> ControlPattern lpqrecv = resonancerecv lpf :: Pattern Double -> ControlPattern lpf = cutoff + lpfbus :: Pattern Int -> Pattern Double -> ControlPattern lpfbus = cutoffbus + lpfrecv :: Pattern Int -> ControlPattern lpfrecv = cutoffrecv loh :: Pattern Double -> ControlPattern loh = lophat + lohbus :: Pattern Int -> Pattern Double -> ControlPattern lohbus = lophatbus + lohrecv :: Pattern Int -> ControlPattern lohrecv = lophatrecv llt :: Pattern Double -> ControlPattern llt = llotom + lltbus :: Pattern Int -> Pattern Double -> ControlPattern lltbus = llotombus + lltrecv :: Pattern Int -> ControlPattern lltrecv = llotomrecv lht :: Pattern Double -> ControlPattern lht = lhitom + lhtbus :: Pattern Int -> Pattern Double -> ControlPattern lhtbus = lhitombus + lhtrecv :: Pattern Int -> ControlPattern lhtrecv = lhitomrecv lfop :: Pattern Double -> ControlPattern lfop = lfopitchint + lfopbus :: Pattern Int -> Pattern Double -> ControlPattern lfopbus = lfopitchintbus + lfoprecv :: Pattern Int -> ControlPattern lfoprecv = lfopitchintrecv lfoi :: Pattern Double -> ControlPattern lfoi = lfoint + lfoibus :: Pattern Int -> Pattern Double -> ControlPattern lfoibus = lfointbus + lfoirecv :: Pattern Int -> ControlPattern lfoirecv = lfointrecv lfoc :: Pattern Double -> ControlPattern lfoc = lfocutoffint + lfocbus :: Pattern Int -> Pattern Double -> ControlPattern lfocbus = lfocutoffintbus + lfocrecv :: Pattern Int -> ControlPattern lfocrecv = lfocutoffintrecv lcr :: Pattern Double -> ControlPattern lcr = lcrash + lcrbus :: Pattern Int -> Pattern Double -> ControlPattern lcrbus = lcrashbus + lcrrecv :: Pattern Int -> ControlPattern lcrrecv = lcrashrecv lcp :: Pattern Double -> ControlPattern lcp = lclap + lcpbus :: Pattern Int -> Pattern Double -> ControlPattern lcpbus = lclapbus + lcprecv :: Pattern Int -> ControlPattern lcprecv = lclaprecv lcl :: Pattern Double -> ControlPattern lcl = lclaves + lclbus :: Pattern Int -> Pattern Double -> ControlPattern lclbus = lclavesbus + lclrecv :: Pattern Int -> ControlPattern lclrecv = lclavesrecv lch :: Pattern Double -> ControlPattern lch = lclhat + lchbus :: Pattern Int -> Pattern Double -> ControlPattern lchbus = lclhatbus + lchrecv :: Pattern Int -> ControlPattern lchrecv = lclhatrecv lbd :: Pattern Double -> ControlPattern lbd = lkick + lbdbus :: Pattern Int -> Pattern Double -> ControlPattern lbdbus = lkickbus + lbdrecv :: Pattern Int -> ControlPattern lbdrecv = lkickrecv lag :: Pattern Double -> ControlPattern lag = lagogo + lagbus :: Pattern Int -> Pattern Double -> ControlPattern lagbus = lagogobus + lagrecv :: Pattern Int -> ControlPattern lagrecv = lagogorecv hpq :: Pattern Double -> ControlPattern hpq = hresonance + hpqbus :: Pattern Int -> Pattern Double -> ControlPattern hpqbus = hresonancebus + hpqrecv :: Pattern Int -> ControlPattern hpqrecv = hresonancerecv hpf :: Pattern Double -> ControlPattern hpf = hcutoff + hpfbus :: Pattern Int -> Pattern Double -> ControlPattern hpfbus = hcutoffbus + hpfrecv :: Pattern Int -> ControlPattern hpfrecv = hcutoffrecv hg :: Pattern Double -> ControlPattern hg = hatgrain + hgbus :: Pattern Int -> Pattern Double -> ControlPattern hgbus = hatgrainbus + hgrecv :: Pattern Int -> ControlPattern hgrecv = hatgrainrecv gat :: Pattern Double -> ControlPattern gat = gate + gatbus :: Pattern Int -> Pattern Double -> ControlPattern gatbus = gatebus + gatrecv :: Pattern Int -> ControlPattern gatrecv = gaterecv @@ -3481,77 +4296,99 @@ fadeOutTime = fadeTime dt :: Pattern Double -> ControlPattern dt = delaytime + dtbus :: Pattern Int -> Pattern Double -> ControlPattern dtbus = delaytimebus + dtrecv :: Pattern Int -> ControlPattern dtrecv = delaytimerecv dfb :: Pattern Double -> ControlPattern dfb = delayfeedback + dfbbus :: Pattern Int -> Pattern Double -> ControlPattern dfbbus = delayfeedbackbus + dfbrecv :: Pattern Int -> ControlPattern dfbrecv = delayfeedbackrecv det :: Pattern Double -> ControlPattern det = detune + detbus :: Pattern Int -> Pattern Double -> ControlPattern detbus = detunebus + detrecv :: Pattern Int -> ControlPattern detrecv = detunerecv delayt :: Pattern Double -> ControlPattern delayt = delaytime + delaytbus :: Pattern Int -> Pattern Double -> ControlPattern delaytbus = delaytimebus + delaytrecv :: Pattern Int -> ControlPattern delaytrecv = delaytimerecv delayfb :: Pattern Double -> ControlPattern delayfb = delayfeedback + delayfbbus :: Pattern Int -> Pattern Double -> ControlPattern delayfbbus = delayfeedbackbus + delayfbrecv :: Pattern Int -> ControlPattern delayfbrecv = delayfeedbackrecv ctfg :: Pattern Double -> ControlPattern ctfg = cutoffegint + ctfgbus :: Pattern Int -> Pattern Double -> ControlPattern ctfgbus = cutoffegintbus + ctfgrecv :: Pattern Int -> ControlPattern ctfgrecv = cutoffegintrecv ctf :: Pattern Double -> ControlPattern ctf = cutoff + ctfbus :: Pattern Int -> Pattern Double -> ControlPattern ctfbus = cutoffbus + ctfrecv :: Pattern Int -> ControlPattern ctfrecv = cutoffrecv chdecay :: Pattern Double -> ControlPattern chdecay = clhatdecay + chdecaybus :: Pattern Int -> Pattern Double -> ControlPattern chdecaybus = clhatdecaybus + chdecayrecv :: Pattern Int -> ControlPattern chdecayrecv = clhatdecayrecv bpq :: Pattern Double -> ControlPattern bpq = bandq + bpqbus :: Pattern Int -> Pattern Double -> ControlPattern bpqbus = bandqbus + bpqrecv :: Pattern Int -> ControlPattern bpqrecv = bandqrecv bpf :: Pattern Double -> ControlPattern bpf = bandf + bpfbus :: Pattern Int -> Pattern Double -> ControlPattern bpfbus = bandfbus + bpfrecv :: Pattern Int -> ControlPattern bpfrecv = bandfrecv att :: Pattern Double -> ControlPattern att = attack + attbus :: Pattern Int -> Pattern Double -> ControlPattern attbus = attackbus + attrecv :: Pattern Int -> ControlPattern attrecv = attackrecv diff --git a/src/Sound/Tidal/ParseBP.hs b/src/Sound/Tidal/ParseBP.hs index 4ff392da..c7256718 100644 --- a/src/Sound/Tidal/ParseBP.hs +++ b/src/Sound/Tidal/ParseBP.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} +{-# 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 #-} @@ -28,62 +28,63 @@ 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 Data.Colour -import Data.Colour.Names -import Data.Functor.Identity (Identity) -import Data.List (intercalate) -import Data.Maybe -import Data.Ratio -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.Utils (fromRight) -import Text.Parsec.Error +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.Maybe +import Data.Ratio +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.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 - } +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 + } deriving (Eq, Typeable) instance E.Exception TidalParseError instance Show TidalParseError where show err = "Syntax error in sequence:\n \"" ++ code err ++ "\"\n " ++ pointer ++ " " ++ message - where pointer = replicate (sourceColumn $ errorPos perr) ' ' ++ "^" - message = showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" $ errorMessages perr - perr = parsecError err + where + pointer = replicate (sourceColumn $ errorPos perr) ' ' ++ "^" + message = showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" $ errorMessages perr + perr = parsecError err type MyParser = Text.Parsec.Prim.Parsec String Int -- | AST representation of patterns - data TPat a where - TPat_Atom :: (Maybe ((Int, Int), (Int, Int))) -> a -> (TPat a) - TPat_Fast :: (TPat Time) -> (TPat a) -> (TPat a) - TPat_Slow :: (TPat Time) -> (TPat a) -> (TPat a) - TPat_DegradeBy :: Int -> Double -> (TPat a) -> (TPat a) - TPat_CycleChoose :: Int -> [TPat a] -> (TPat a) - TPat_Euclid :: (TPat Int) -> (TPat Int) -> (TPat Int) -> (TPat a) -> (TPat a) - TPat_Stack :: [TPat a] -> (TPat a) - TPat_Polyrhythm :: (Maybe (TPat Rational)) -> [TPat a] -> (TPat a) - TPat_Seq :: [TPat a] -> (TPat a) - TPat_Silence :: (TPat a) - TPat_Foot :: (TPat a) - TPat_Elongate :: Rational -> (TPat a) -> (TPat a) - TPat_Repeat :: Int -> (TPat a) -> (TPat a) - TPat_EnumFromTo :: (TPat a) -> (TPat a) -> (TPat a) - TPat_Var :: String -> (TPat a) - TPat_Chord :: (Num b, Enum b, Parseable b, Enumerable b) => (b -> a) -> (TPat b) -> (TPat String) -> [TPat [Modifier]] -> (TPat a) + TPat_Atom :: (Maybe ((Int, Int), (Int, Int))) -> a -> TPat a + TPat_Fast :: (TPat Time) -> (TPat a) -> TPat a + TPat_Slow :: (TPat Time) -> (TPat a) -> TPat a + TPat_DegradeBy :: Int -> Double -> (TPat a) -> TPat a + TPat_CycleChoose :: Int -> [TPat a] -> TPat a + TPat_Euclid :: (TPat Int) -> (TPat Int) -> (TPat Int) -> (TPat a) -> TPat a + TPat_Stack :: [TPat a] -> TPat a + TPat_Polyrhythm :: (Maybe (TPat Rational)) -> [TPat a] -> TPat a + TPat_Seq :: [TPat a] -> TPat a + TPat_Silence :: TPat a + TPat_Foot :: TPat a + TPat_Elongate :: Rational -> (TPat a) -> TPat a + TPat_Repeat :: Int -> (TPat a) -> TPat a + TPat_EnumFromTo :: (TPat a) -> (TPat a) -> TPat a + TPat_Var :: String -> TPat a + TPat_Chord :: (Num b, Enum b, Parseable b, Enumerable b) => (b -> a) -> (TPat b) -> (TPat String) -> [TPat [Modifier]] -> TPat a instance Show a => Show (TPat a) where show (TPat_Atom c v) = "TPat_Atom (" ++ show c ++ ") (" ++ show v ++ ")" @@ -132,82 +133,82 @@ tShow (TPat_Slow t v) = "slow " ++ show t ++ " $ " ++ tShow v tShow (TPat_DegradeBy _ r v) = "degradeBy " ++ show r ++ " $ " ++ tShow v -- TODO - ditto tShow (TPat_CycleChoose _ vs) = "cycleChoose " ++ tShowList vs - -tShow (TPat_Euclid a b c v) = "doEuclid (" ++ intercalate ") (" (map tShow [a,b,c]) ++ ") $ " ++ tShow v +tShow (TPat_Euclid a b c v) = "doEuclid (" ++ intercalate ") (" (map tShow [a, b, c]) ++ ") $ " ++ tShow v tShow (TPat_Stack vs) = "stack " ++ tShowList vs - tShow (TPat_Polyrhythm mSteprate vs) = "stack [" ++ intercalate ", " (map adjust_speed pats) ++ "]" - where adjust_speed (sz, pat) = "(fast (" ++ (steprate ++ "/" ++ show sz) ++ ") $ " ++ pat ++ ")" - steprate :: String - steprate = maybe base_first tShow mSteprate - base_first | null pats = "0" - | otherwise = show $ fst $ head pats - pats = map steps_tpat vs - + where + adjust_speed (sz, pat) = "(fast (" ++ (steprate ++ "/" ++ show sz) ++ ") $ " ++ pat ++ ")" + steprate :: String + steprate = maybe base_first tShow mSteprate + base_first + | null pats = "0" + | otherwise = show $ fst $ head pats + pats = map steps_tpat vs tShow (TPat_Seq vs) = snd $ steps_seq vs - tShow TPat_Silence = "silence" tShow (TPat_EnumFromTo a b) = "unwrap $ fromTo <$> (" ++ tShow a ++ ") <*> (" ++ tShow b ++ ")" tShow (TPat_Var s) = "getControl " ++ s tShow (TPat_Chord f n name mods) = "chord (" ++ (tShow $ fmap f n) ++ ") (" ++ tShow name ++ ")" ++ tShowList mods tShow a = "can't happen? " ++ show a - toPat :: (Parseable a, Enumerable a) => TPat a -> Pattern a toPat = \case - TPat_Atom (Just loc) x -> setContext (Context [loc]) $ pure x - TPat_Atom Nothing x -> pure x - TPat_Fast t x -> fast (toPat t) $ toPat x - TPat_Slow t x -> slow (toPat t) $ toPat x - TPat_DegradeBy seed amt x -> _degradeByUsing (rotL (0.0001 * fromIntegral seed) rand) amt $ toPat x - TPat_CycleChoose seed xs -> unwrap $ segment 1 $ chooseBy (rotL (0.0001 * fromIntegral seed) rand) $ map toPat xs - TPat_Euclid n k s thing -> doEuclid (toPat n) (toPat k) (toPat s) (toPat thing) - TPat_Stack xs -> stack $ map toPat xs - TPat_Silence -> silence - TPat_EnumFromTo a b -> unwrap $ fromTo <$> toPat a <*> toPat b - TPat_Foot -> error "Can't happen, feet are pre-processed." - TPat_Polyrhythm mSteprate ps -> stack $ map adjust_speed pats - where adjust_speed (sz, pat) = fast ((/sz) <$> steprate) pat - pats = map resolve_tpat ps - steprate :: Pattern Rational - steprate = (maybe base_first toPat mSteprate) - base_first | null pats = pure 0 - | otherwise = pure $ fst $ head pats - TPat_Seq xs -> snd $ resolve_seq xs - TPat_Var s -> getControl s - TPat_Chord f iP nP mP -> chordToPatSeq f (toPat iP) (toPat nP) (map toPat mP) - _ -> silence + TPat_Atom (Just loc) x -> setContext (Context [loc]) $ pure x + TPat_Atom Nothing x -> pure x + TPat_Fast t x -> fast (toPat t) $ toPat x + TPat_Slow t x -> slow (toPat t) $ toPat x + TPat_DegradeBy seed amt x -> _degradeByUsing (rotL (0.0001 * fromIntegral seed) rand) amt $ toPat x + TPat_CycleChoose seed xs -> unwrap $ segment 1 $ chooseBy (rotL (0.0001 * fromIntegral seed) rand) $ map toPat xs + TPat_Euclid n k s thing -> doEuclid (toPat n) (toPat k) (toPat s) (toPat thing) + TPat_Stack xs -> stack $ map toPat xs + TPat_Silence -> silence + TPat_EnumFromTo a b -> unwrap $ fromTo <$> toPat a <*> toPat b + TPat_Foot -> error "Can't happen, feet are pre-processed." + TPat_Polyrhythm mSteprate ps -> stack $ map adjust_speed pats + where + adjust_speed (sz, pat) = fast ((/ sz) <$> steprate) pat + pats = map resolve_tpat ps + steprate :: Pattern Rational + steprate = (maybe base_first toPat mSteprate) + base_first + | null pats = pure 0 + | otherwise = pure $ fst $ head pats + TPat_Seq xs -> snd $ resolve_seq xs + TPat_Var s -> getControl s + TPat_Chord f iP nP mP -> chordToPatSeq f (toPat iP) (toPat nP) (map toPat mP) + _ -> silence resolve_tpat :: (Enumerable a, Parseable a) => TPat a -> (Rational, Pattern a) 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) - where sized_pats = map (toPat <$>) $ resolve_size xs - total_size = sum $ map fst sized_pats + where + sized_pats = map (toPat <$>) $ resolve_size xs + total_size = sum $ map fst sized_pats resolve_size :: [TPat a] -> [(Rational, TPat a)] -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 [] = [] +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 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) ++ "]") - where sized_pats = steps_size xs - total_size = sum $ map fst sized_pats +steps_seq xs = (total_size, "timeCat [" ++ intercalate "," (map (\(r, s) -> "(" ++ show r ++ ", " ++ s ++ ")") sized_pats) ++ "]") + where + sized_pats = steps_size xs + total_size = sum $ map fst sized_pats steps_size :: Show a => [TPat a] -> [(Rational, String)] -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 [] = [] +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 parseBP :: (Enumerable a, Parseable a) => String -> Either ParseError (Pattern a) parseBP s = toPat <$> parseTPat s @@ -217,7 +218,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) @@ -226,16 +227,18 @@ parseTPat = runParser (pSequence parseRest Prelude.<* eof) (0 :: Int) "" -- | a '-' is a negative sign if followed anything but another dash -- otherwise, it's treated as rest parseRest :: Parseable a => MyParser (TPat a) -parseRest = - try (do +parseRest = + try + ( do lookAhead $ do char '-' spaces noneOf "-" - tPatParser) - <|> char '-' Prelude.*> pure TPat_Silence - <|> tPatParser - <|> char '~' Prelude.*> pure TPat_Silence + tPatParser + ) + <|> char '-' Prelude.*> pure TPat_Silence + <|> tPatParser + <|> char '~' Prelude.*> pure TPat_Silence cP :: (Enumerable a, Parseable a) => String -> Pattern a cP s = innerJoin $ parseBP_E <$> _cX_ getS s @@ -256,7 +259,7 @@ instance Parseable Char where instance Enumerable Char where fromTo = enumFromTo' - fromThenTo a b c = fastFromList [a,b,c] + fromThenTo a b c = fastFromList [a, b, c] instance Parseable Double where tPatParser = pDouble @@ -282,8 +285,8 @@ instance Parseable String where getControl = cS_ instance Enumerable String where - fromTo a b = fastFromList [a,b] - fromThenTo a b c = fastFromList [a,b,c] + fromTo a b = fastFromList [a, b] + fromThenTo a b c = fastFromList [a, b, c] instance Parseable Bool where tPatParser = pBool @@ -291,8 +294,8 @@ instance Parseable Bool where getControl = cB_ instance Enumerable Bool where - fromTo a b = fastFromList [a,b] - fromThenTo a b c = fastFromList [a,b,c] + fromTo a b = fastFromList [a, b] + fromThenTo a b c = fastFromList [a, b, c] instance Parseable Int where tPatParser = pIntegral @@ -322,12 +325,14 @@ instance Enumerable Rational where fromThenTo = enumFromThenTo' enumFromTo' :: (Ord a, Enum a) => a -> a -> Pattern a -enumFromTo' a b | a > b = fastFromList $ reverse $ enumFromTo b a - | otherwise = fastFromList $ enumFromTo a b +enumFromTo' a b + | a > b = fastFromList $ reverse $ enumFromTo b a + | otherwise = fastFromList $ enumFromTo a b enumFromThenTo' :: (Ord a, Enum a, Num a) => a -> a -> a -> Pattern a -enumFromThenTo' a b c | a > c = fastFromList $ reverse $ enumFromThenTo c (c + (a-b)) a - | otherwise = fastFromList $ enumFromThenTo a b c +enumFromThenTo' a b c + | a > c = fastFromList $ reverse $ enumFromThenTo c (c + (a - b)) a + | otherwise = fastFromList $ enumFromThenTo a b c type ColourD = Colour Double @@ -336,23 +341,23 @@ instance Parseable ColourD where doEuclid = euclidOff instance Enumerable ColourD where - fromTo a b = fastFromList [a,b] - fromThenTo a b c = fastFromList [a,b,c] + fromTo a b = fastFromList [a, b] + fromThenTo a b c = fastFromList [a, b, c] instance (Enumerable a, Parseable a) => IsString (Pattern a) where fromString = parseBP_E lexer :: P.GenTokenParser String u Data.Functor.Identity.Identity -lexer = P.makeTokenParser haskellDef +lexer = P.makeTokenParser haskellDef -braces, brackets, parens, angles:: MyParser a -> MyParser a +braces, brackets, parens, angles :: MyParser a -> MyParser a braces p = char '{' Prelude.*> p Prelude.<* char '}' brackets p = char '[' Prelude.*> p Prelude.<* char ']' parens p = char '(' Prelude.*> p Prelude.<* char ')' angles p = char '<' Prelude.*> p Prelude.<* char '>' symbol :: String -> MyParser String -symbol = P.symbol lexer +symbol = P.symbol lexer natural, integer, decimal :: MyParser Integer natural = P.natural lexer @@ -365,18 +370,21 @@ float = P.float lexer naturalOrFloat :: MyParser (Either Integer Double) naturalOrFloat = P.naturalOrFloat lexer -data Sign = Positive | Negative +data Sign = Positive | Negative -applySign :: Num a => Sign -> a -> a -applySign Positive = id -applySign Negative = negate +applySign :: Num a => Sign -> a -> a +applySign Positive = id +applySign Negative = negate -sign :: MyParser Sign -sign = do char '-' - return Negative - <|> do char '+' - return Positive - <|> return Positive +sign :: MyParser Sign +sign = + do + char '-' + return Negative + <|> do + char '+' + return Positive + <|> return Positive intOrFloat :: MyParser Double intOrFloat = try pFloat <|> pInteger @@ -384,100 +392,123 @@ intOrFloat = try pFloat <|> pInteger pSequence :: Parseable a => MyParser (TPat a) -> MyParser (TPat a) pSequence f = do spaces - s <- many $ do - a <- pPart f - spaces - do - try $ symbol ".." - b <- pPart f - return $ TPat_EnumFromTo a b - <|> pElongate a - <|> pRepeat a - <|> return a - <|> do - symbol "." - return TPat_Foot + s <- + many $ + do + a <- pPart f + spaces + do + try $ symbol ".." + b <- pPart f + return $ TPat_EnumFromTo a b + <|> pElongate a + <|> pRepeat a + <|> return a + <|> do + symbol "." + return TPat_Foot pRand $ resolve_feet s - where resolve_feet ps | length ss > 1 = TPat_Seq $ map TPat_Seq ss - | otherwise = TPat_Seq ps - where ss = splitFeet ps - splitFeet :: [TPat t] -> [[TPat t]] - splitFeet [] = [] - splitFeet pats = foot : splitFeet pats' - where (foot, pats') = takeFoot pats - takeFoot [] = ([], []) - takeFoot (TPat_Foot:pats'') = ([], pats'') - takeFoot (pat:pats'') = first (pat:) $ takeFoot pats'' + where + resolve_feet ps + | length ss > 1 = TPat_Seq $ map TPat_Seq ss + | otherwise = TPat_Seq ps + where + ss = splitFeet ps + splitFeet :: [TPat t] -> [[TPat t]] + splitFeet [] = [] + splitFeet pats = foot : splitFeet pats' + where + (foot, pats') = takeFoot pats + takeFoot [] = ([], []) + takeFoot (TPat_Foot : pats'') = ([], pats'') + takeFoot (pat : pats'') = first (pat :) $ takeFoot pats'' pRepeat :: TPat a -> MyParser (TPat a) -pRepeat a = do es <- many1 $ do char '!' - n <- (subtract 1 . read <$> many1 digit) <|> return 1 - spaces - return n - return $ TPat_Repeat (1 + sum es) a +pRepeat a = do + es <- many1 $ do + char '!' + n <- (subtract 1 . read <$> many1 digit) <|> return 1 + spaces + return n + return $ TPat_Repeat (1 + sum es) a pElongate :: TPat a -> MyParser (TPat a) -pElongate a = do rs <- many1 $ do oneOf "@_" - r <- (subtract 1 <$> pRatio) <|> return 1 - spaces - return r - return $ TPat_Elongate (1 + sum rs) a +pElongate a = do + rs <- many1 $ do + oneOf "@_" + r <- (subtract 1 <$> pRatio) <|> return 1 + spaces + return r + return $ TPat_Elongate (1 + sum rs) a pSingle :: MyParser (TPat a) -> MyParser (TPat a) pSingle f = f >>= pRand >>= pMult pVar :: MyParser (TPat a) -pVar = wrapPos $ do char '^' - name <- many (letter <|> oneOf "0123456789:.-_") "string" - return $ TPat_Var name +pVar = wrapPos $ do + char '^' + name <- many (letter <|> oneOf "0123456789:.-_") "string" + return $ TPat_Var name pPart :: Parseable a => MyParser (TPat a) -> MyParser (TPat a) pPart f = (pSingle f <|> pPolyIn f <|> pPolyOut f <|> pVar) >>= pE >>= pRand newSeed :: MyParser Int -newSeed = do seed <- Text.Parsec.Prim.getState - Text.Parsec.Prim.modifyState (+1) - return seed +newSeed = do + seed <- Text.Parsec.Prim.getState + Text.Parsec.Prim.modifyState (+ 1) + return seed pPolyIn :: Parseable a => MyParser (TPat a) -> MyParser (TPat a) -pPolyIn f = do x <- brackets $ do s <- pSequence f "sequence" - stackTail s <|> chooseTail s <|> return s - pMult x - where stackTail s = do symbol "," - ss <- pSequence f `sepBy` symbol "," - return $ TPat_Stack (s:ss) - chooseTail s = do symbol "|" - ss <- pSequence f `sepBy` symbol "|" - seed <- newSeed - return $ TPat_CycleChoose seed (s:ss) +pPolyIn f = do + x <- brackets $ do + s <- pSequence f "sequence" + stackTail s <|> chooseTail s <|> return s + pMult x + where + stackTail s = do + symbol "," + ss <- pSequence f `sepBy` symbol "," + return $ TPat_Stack (s : ss) + chooseTail s = do + symbol "|" + ss <- pSequence f `sepBy` symbol "|" + seed <- newSeed + return $ TPat_CycleChoose seed (s : ss) pPolyOut :: Parseable a => MyParser (TPat a) -> MyParser (TPat a) -pPolyOut f = do ss <- braces (pSequence f `sepBy` symbol ",") - base <- do char '%' - r <- pSequence pRational "rational number" - return $ Just r - <|> return Nothing - pMult $ TPat_Polyrhythm base ss - <|> - do ss <- angles (pSequence f `sepBy` symbol ",") - pMult $ TPat_Polyrhythm (Just $ TPat_Atom Nothing 1) ss +pPolyOut f = + do + ss <- braces (pSequence f `sepBy` symbol ",") + base <- + do + char '%' + r <- pSequence pRational "rational number" + return $ Just r + <|> return Nothing + pMult $ TPat_Polyrhythm base ss + <|> do + ss <- angles (pSequence f `sepBy` symbol ",") + pMult $ TPat_Polyrhythm (Just $ TPat_Atom Nothing 1) ss pCharNum :: MyParser Char pCharNum = (letter <|> oneOf "0123456789") "letter or number" pString :: MyParser String -pString = do c <- pCharNum "charnum" - cs <- many (letter <|> oneOf "0123456789:.-_") "string" - return (c:cs) +pString = do + c <- pCharNum "charnum" + cs <- many (letter <|> oneOf "0123456789:.-_") "string" + return (c : cs) wrapPos :: MyParser (TPat a) -> MyParser (TPat a) -wrapPos p = do b <- getPosition - tpat <- p - e <- getPosition - let addPos (TPat_Atom _ v') = - TPat_Atom (Just ((sourceColumn b, sourceLine b), (sourceColumn e, sourceLine e))) v' - addPos x = x -- shouldn't happen.. - return $ addPos tpat +wrapPos p = do + b <- getPosition + tpat <- p + e <- getPosition + let addPos (TPat_Atom _ v') = + TPat_Atom (Just ((sourceColumn b, sourceLine b), (sourceColumn e, sourceLine e))) v' + addPos x = x -- shouldn't happen.. + return $ addPos tpat pVocable :: MyParser (TPat String) pVocable = wrapPos $ TPat_Atom Nothing <$> pString @@ -486,136 +517,170 @@ pChar :: MyParser (TPat Char) pChar = wrapPos $ TPat_Atom Nothing <$> pCharNum pDouble :: MyParser (TPat Double) -pDouble = try $ do d <- pDoubleWithoutChord - pChord d <|> return d - <|> pChord (TPat_Atom Nothing 0) - <|> pDoubleWithoutChord +pDouble = + try $ + do + d <- pDoubleWithoutChord + pChord d <|> return d + <|> pChord (TPat_Atom Nothing 0) + <|> pDoubleWithoutChord pDoubleWithoutChord :: MyParser (TPat Double) -pDoubleWithoutChord = pPart $ wrapPos $ do s <- sign - f <- choice [fromRational <$> pRatio, parseNote] "float" - return $ TPat_Atom Nothing (applySign s f) +pDoubleWithoutChord = pPart $ + wrapPos $ do + s <- sign + f <- choice [fromRational <$> pRatio, parseNote] "float" + return $ TPat_Atom Nothing (applySign s f) pNote :: MyParser (TPat Note) -pNote = try $ do n <- pNoteWithoutChord - pChord n <|> return n - <|> pChord (TPat_Atom Nothing 0) - <|> pNoteWithoutChord - <|> do TPat_Atom Nothing . fromRational <$> pRatio +pNote = + try $ + do + n <- pNoteWithoutChord + pChord n <|> return n + <|> pChord (TPat_Atom Nothing 0) + <|> pNoteWithoutChord + <|> do TPat_Atom Nothing . fromRational <$> pRatio pNoteWithoutChord :: MyParser (TPat Note) -pNoteWithoutChord = pPart $ wrapPos $ do s <- sign - f <- choice [intOrFloat, parseNote] "float" - return $ TPat_Atom Nothing (Note $ applySign s f) - +pNoteWithoutChord = pPart $ + wrapPos $ do + s <- sign + f <- choice [intOrFloat, parseNote] "float" + return $ TPat_Atom Nothing (Note $ applySign s f) pBool :: MyParser (TPat Bool) -pBool = wrapPos $ do oneOf "t1" - return $ TPat_Atom Nothing True - <|> - do oneOf "f0" - return $ TPat_Atom Nothing False - -parseIntNote :: Integral i => MyParser i -parseIntNote = do s <- sign - d <- choice [intOrFloat, parseNote] - if isInt d - then return $ applySign s $ round d - else fail "not an integer" +pBool = + wrapPos $ + do + oneOf "t1" + return $ TPat_Atom Nothing True + <|> do + oneOf "f0" + return $ TPat_Atom Nothing False + +parseIntNote :: Integral i => MyParser i +parseIntNote = do + s <- sign + d <- choice [intOrFloat, parseNote] + if isInt d + then return $ applySign s $ round d + else fail "not an integer" pIntegral :: (Integral a, Parseable a, Enumerable a) => MyParser (TPat a) -pIntegral = try $ do i <- pIntegralWithoutChord - pChord i <|> return i - <|> pChord (TPat_Atom Nothing 0) - <|> pIntegralWithoutChord +pIntegral = + try $ + do + i <- pIntegralWithoutChord + pChord i <|> return i + <|> pChord (TPat_Atom Nothing 0) + <|> pIntegralWithoutChord pIntegralWithoutChord :: (Integral a, Parseable a, Enumerable a) => MyParser (TPat a) pIntegralWithoutChord = pPart $ wrapPos $ fmap (TPat_Atom Nothing) parseIntNote parseChord :: (Enum a, Num a) => MyParser [a] -parseChord = do char '\'' - name <- many1 $ letter <|> digit - let foundChord = fromMaybe [0] $ lookup name chordTable - do char '\'' - notFollowedBy space "chord range or 'i' or 'o'" - let n = length foundChord - i <- option n (fromIntegral <$> integer) - j <- length <$> many (char 'i') - o <- length <$> many (char 'o') - let chord' = take i $ drop j $ concatMap (\x -> map (+ x) foundChord) [0,12..] - -- open voiced chords - let chordo' = if o > 0 && n > 2 then - [ (chord' !! 0 - 12), (chord' !! 2 - 12), (chord' !! 1) ] ++ reverse (take (length chord' - 3) (reverse chord')) - else chord' - return chordo' - <|> return foundChord +parseChord = do + char '\'' + name <- many1 $ letter <|> digit + let foundChord = fromMaybe [0] $ lookup name chordTable + do + char '\'' + notFollowedBy space "chord range or 'i' or 'o'" + let n = length foundChord + i <- option n (fromIntegral <$> integer) + j <- length <$> many (char 'i') + o <- length <$> many (char 'o') + let chord' = take i $ drop j $ concatMap (\x -> map (+ x) foundChord) [0, 12 ..] + -- open voiced chords + let chordo' = + if o > 0 && n > 2 + then [(chord' !! 0 - 12), (chord' !! 2 - 12), (chord' !! 1)] ++ reverse (take (length chord' - 3) (reverse chord')) + else chord' + return chordo' + <|> return foundChord parseNote :: Num a => MyParser a -parseNote = do n <- notenum - modifiers <- many noteModifier - octave <- option 5 natural - let n' = foldr (+) n modifiers - return $ fromIntegral $ n' + ((octave-5)*12) +parseNote = do + n <- notenum + modifiers <- many noteModifier + octave <- option 5 natural + let n' = foldr (+) n modifiers + return $ fromIntegral $ n' + ((octave - 5) * 12) where - notenum :: MyParser Integer - notenum = choice [char 'c' >> return 0, - char 'd' >> return 2, - char 'e' >> return 4, - char 'f' >> return 5, - char 'g' >> return 7, - char 'a' >> return 9, - char 'b' >> return 11 - ] - noteModifier :: MyParser Integer - noteModifier = choice [char 's' >> return 1, - char 'f' >> return (-1), - char 'n' >> return 0 - ] + notenum :: MyParser Integer + notenum = + choice + [ char 'c' >> return 0, + char 'd' >> return 2, + char 'e' >> return 4, + char 'f' >> return 5, + char 'g' >> return 7, + char 'a' >> return 9, + char 'b' >> return 11 + ] + noteModifier :: MyParser Integer + noteModifier = + choice + [ char 's' >> return 1, + char 'f' >> return (-1), + char 'n' >> return 0 + ] fromNote :: Num a => Pattern String -> Pattern a fromNote pat = fromRight 0 . runParser parseNote 0 "" <$> pat pColour :: MyParser (TPat ColourD) -pColour = wrapPos $ do name <- many1 letter "colour name" - colour <- readColourName name "known colour" - return $ TPat_Atom Nothing colour +pColour = wrapPos $ do + name <- many1 letter "colour name" + colour <- readColourName name "known colour" + return $ TPat_Atom Nothing colour pMult :: TPat a -> MyParser (TPat a) -pMult thing = do char '*' - spaces - r <- pRational <|> pPolyIn pRational <|> pPolyOut pRational - return $ TPat_Fast r thing - <|> - do char '/' - spaces - r <- pRational <|> pPolyIn pRational <|> pPolyOut pRational - return $ TPat_Slow r thing - <|> - return thing +pMult thing = + do + char '*' + spaces + r <- pRational <|> pPolyIn pRational <|> pPolyOut pRational + return $ TPat_Fast r thing + <|> do + char '/' + spaces + r <- pRational <|> pPolyIn pRational <|> pPolyOut pRational + return $ TPat_Slow r thing + <|> return thing pRand :: TPat a -> MyParser (TPat a) -pRand thing = do char '?' - r <- float <|> return 0.5 - spaces - seed <- newSeed - return $ TPat_DegradeBy seed r thing - <|> return thing +pRand thing = + do + char '?' + r <- float <|> return 0.5 + spaces + seed <- newSeed + return $ TPat_DegradeBy seed r thing + <|> return thing pE :: TPat a -> MyParser (TPat a) -pE thing = do (n,k,s) <- parens pair - pure $ TPat_Euclid n k s thing - <|> return thing - where pair :: MyParser (TPat Int, TPat Int, TPat Int) - pair = do a <- pSequence pIntegral - spaces - symbol "," - spaces - b <- pSequence pIntegral - c <- do symbol "," - spaces - pSequence pIntegral - <|> return (TPat_Atom Nothing 0) - return (a, b, c) +pE thing = + do + (n, k, s) <- parens pair + pure $ TPat_Euclid n k s thing + <|> return thing + where + pair :: MyParser (TPat Int, TPat Int, TPat Int) + pair = do + a <- pSequence pIntegral + spaces + symbol "," + spaces + b <- pSequence pIntegral + c <- + do + symbol "," + spaces + pSequence pIntegral + <|> return (TPat_Atom Nothing 0) + return (a, b, c) pRational :: MyParser (TPat Rational) pRational = wrapPos $ TPat_Atom Nothing <$> pRatio @@ -623,12 +688,13 @@ pRational = wrapPos $ TPat_Atom Nothing <$> pRatio pRatio :: MyParser Rational pRatio = do s <- sign - r <- do n <- try intOrFloat - v <- pFraction n <|> return (toRational n) - r <- pRatioChar <|> return 1 - return (v * r) - <|> - pRatioChar + r <- + do + n <- try intOrFloat + v <- pFraction n <|> return (toRational n) + r <- pRatioChar <|> return 1 + return (v * r) + <|> pRatioChar return $ applySign s r pInteger :: MyParser Double @@ -636,13 +702,17 @@ pInteger = read <$> many1 digit pFloat :: MyParser Double pFloat = do - i <- many1 digit - d <- option "0" (char '.' >> many1 digit) - e <- option "0" (char 'e' >> do - s <- option "" (char '-' >> return "-") - e' <- many1 digit - return $ s++e') - return $ read (i++"."++d++"e"++e) + i <- many1 digit + d <- option "0" (char '.' >> many1 digit) + e <- + option + "0" + ( char 'e' >> do + s <- option "" (char '-' >> return "-") + e' <- many1 digit + return $ s ++ e' + ) + return $ read (i ++ "." ++ d ++ "e" ++ e) pFraction :: RealFrac a => a -> MyParser Rational pFraction n = do @@ -653,14 +723,15 @@ pFraction n = do else fail "fractions need int numerator and denominator" pRatioChar :: Fractional a => MyParser a -pRatioChar = pRatioSingleChar 'w' 1 - <|> pRatioSingleChar 'h' 0.5 - <|> pRatioSingleChar 'q' 0.25 - <|> pRatioSingleChar 'e' 0.125 - <|> pRatioSingleChar 's' 0.0625 - <|> pRatioSingleChar 't' (1/3) - <|> pRatioSingleChar 'f' 0.2 - <|> pRatioSingleChar 'x' (1/6) +pRatioChar = + pRatioSingleChar 'w' 1 + <|> pRatioSingleChar 'h' 0.5 + <|> pRatioSingleChar 'q' 0.25 + <|> pRatioSingleChar 'e' 0.125 + <|> pRatioSingleChar 's' 0.0625 + <|> pRatioSingleChar 't' (1 / 3) + <|> pRatioSingleChar 'f' 0.2 + <|> pRatioSingleChar 'x' (1 / 6) pRatioSingleChar :: Fractional a => Char -> a -> MyParser a pRatioSingleChar c v = try $ do @@ -678,23 +749,23 @@ instance Parseable [Modifier] where doEuclid = euclidOff instance Enumerable [Modifier] where - fromTo a b = fastFromList [a,b] - fromThenTo a b c = fastFromList [a,b,c] + fromTo a b = fastFromList [a, b] + fromThenTo a b c = fastFromList [a, b, c] parseModInv :: MyParser Modifier parseModInv = char 'i' >> return Invert parseModInvNum :: MyParser [Modifier] parseModInvNum = do - char 'i' - n <- pInteger - return $ replicate (round n) Invert + char 'i' + n <- pInteger + return $ replicate (round n) Invert parseModDrop :: MyParser [Modifier] parseModDrop = do - char 'd' - n <- pInteger - return $ [Drop $ round n] + char 'd' + n <- pInteger + return $ [Drop $ round n] parseModOpen :: MyParser Modifier parseModOpen = char 'o' >> return Open @@ -703,14 +774,14 @@ parseModRange :: MyParser Modifier parseModRange = parseIntNote >>= \i -> return $ Range $ fromIntegral (i :: Integer) parseModifiers :: MyParser [Modifier] -parseModifiers = (many1 parseModOpen) <|> parseModDrop <|> (fmap pure parseModRange) <|> try parseModInvNum <|> (many1 parseModInv) "modifier" +parseModifiers = (many1 parseModOpen) <|> parseModDrop <|> (fmap pure parseModRange) <|> try parseModInvNum <|> (many1 parseModInv) "modifier" pModifiers :: MyParser (TPat [Modifier]) pModifiers = wrapPos $ TPat_Atom Nothing <$> parseModifiers pChord :: (Enum a, Num a, Parseable a, Enumerable a) => TPat a -> MyParser (TPat a) pChord i = do - char '\'' - n <- pPart pVocable "chordname" - ms <- option [] $ many1 $ (char '\'' >> pPart pModifiers) - return $ TPat_Chord id i n ms + char '\'' + n <- pPart pVocable "chordname" + ms <- option [] $ many1 $ (char '\'' >> pPart pModifiers) + return $ TPat_Chord id i n ms diff --git a/src/Sound/Tidal/Pattern.hs b/src/Sound/Tidal/Pattern.hs index f7bf4d4f..cf63bb2c 100644 --- a/src/Sound/Tidal/Pattern.hs +++ b/src/Sound/Tidal/Pattern.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -24,34 +24,35 @@ along with this library. If not, see . -} -module Sound.Tidal.Pattern (module Sound.Tidal.Pattern, - module Sound.Tidal.Time - ) +module Sound.Tidal.Pattern + ( module Sound.Tidal.Pattern, + module Sound.Tidal.Time, + ) where -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 (Generic) - -import Sound.Tidal.Time +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 (Generic) +import Sound.Tidal.Time +import Prelude hiding ((*>), (<*)) ------------------------------------------------------------------------ + -- * Types -- | an Arc and some named control values -data State = State {arc :: Arc, - controls :: ValueMap - } +data State = State + { arc :: Arc, + controls :: ValueMap + } -- | A datatype representing events taking place over time data Pattern a = Pattern {query :: State -> [Event a], tactus :: Maybe Rational, pureValue :: Maybe a} @@ -74,7 +75,7 @@ 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 _ p = p steps :: Pattern Rational -> Pattern a -> Pattern a steps = patternify _steps @@ -91,17 +92,21 @@ type ControlPattern = Pattern ValueMap -- * Applicative and friends instance Applicative Pattern where - -- | Repeat the given value once per cycle, forever + -- Repeat the given value once per cycle, forever 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@ + 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), -- the time structure of the result -- depends on the structures of both @a@ and @b@. @@ -124,7 +129,7 @@ instance Applicative Pattern where -- > (⅓>½)-⅔|11 -- > ⅓-(½>⅔)|12 -- > (⅔>1)|102 - (<*>) a b = (applyPatToPatBoth a b) {tactus = lcmr <$> tactus a <*> tactus b } + (<*>) 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 @@ -136,60 +141,71 @@ instance Applicative Pattern where -- | Like @<*>@, but the "wholes" come from the left (<<*) :: Pattern (a -> b) -> Pattern a -> Pattern b -(<<*) a b = (applyPatToPatSqueeze a b) {tactus = (*) <$> tactus a <*> tactus b } +(<<*) 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 applyPatToPat combineWholes pf px = pattern q - where q st = catMaybes $ concatMap match $ query pf st - where - match ef@(Event (Context c) _ fPart f) = - map - (\ex@(Event (Context c') _ xPart x) -> - do whole' <- combineWholes (whole ef) (whole ex) - part' <- subArc fPart xPart - return (Event (Context $ c ++ c') whole' part' (f x)) - ) - (query px $ st {arc = wholeOrPart ef}) + where + q st = catMaybes $ concatMap match $ query pf st + where + match ef@(Event (Context c) _ fPart f) = + map + ( \ex@(Event (Context c') _ xPart x) -> + do + whole' <- combineWholes (whole ef) (whole ex) + part' <- subArc fPart xPart + return (Event (Context $ c ++ c') whole' part' (f x)) + ) + (query px $ st {arc = wholeOrPart ef}) applyPatToPatBoth :: Pattern (a -> b) -> Pattern a -> Pattern b 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 - match ef@(Event _ Nothing fPart _) = map (withFX ef) (query px $ st {arc = fPart}) -- analog - -- match digital events from pf with digital events from px - match ef@(Event _ (Just fWhole) _ _) = map (withFX ef) (query (filterDigital px) $ st {arc = fWhole}) -- digital - -- match analog events from px (constrained above) with digital events from px - matchX ex@(Event _ Nothing fPart _) = map (`withFX` ex) (query (filterDigital pf) $ st {arc = fPart}) -- digital - matchX _ = error "can't happen" - withFX ef ex = do whole' <- subMaybeArc (whole ef) (whole ex) - part' <- subArc (part ef) (part ex) - return (Event (combineContexts [context ef, context ex]) whole' part' (value ef $ value ex)) + 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 + match ef@(Event _ Nothing fPart _) = map (withFX ef) (query px $ st {arc = fPart}) -- analog + -- match digital events from pf with digital events from px + match ef@(Event _ (Just fWhole) _ _) = map (withFX ef) (query (filterDigital px) $ st {arc = fWhole}) -- digital + -- match analog events from px (constrained above) with digital events from px + matchX ex@(Event _ Nothing fPart _) = map (`withFX` ex) (query (filterDigital pf) $ st {arc = fPart}) -- digital + matchX _ = error "can't happen" + withFX ef ex = do + whole' <- subMaybeArc (whole ef) (whole ex) + part' <- subArc (part ef) (part ex) + 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 - where q st = catMaybes $ concatMap match $ query pf st - where - match ef = map (withFX ef) (query px $ st {arc = wholeOrPart ef}) - withFX ef ex = do let whole' = whole ef - part' <- subArc (part ef) (part ex) - return (Event (combineContexts [context ef, context ex]) whole' part' (value ef $ value ex)) + where + q st = catMaybes $ concatMap match $ query pf st + where + match ef = map (withFX ef) (query px $ st {arc = wholeOrPart ef}) + withFX ef ex = do + let whole' = whole ef + part' <- subArc (part ef) (part ex) + 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 - where q st = catMaybes $ concatMap match $ query px st - where - match ex = map (`withFX` ex) (query pf $ st {arc = wholeOrPart ex}) - withFX ef ex = do let whole' = whole ex - part' <- subArc (part ef) (part ex) - return (Event (combineContexts [context ef, context ex]) whole' part' (value ef $ value ex)) + where + q st = catMaybes $ concatMap match $ query px st + where + match ex = map (`withFX` ex) (query pf $ st {arc = wholeOrPart ex}) + withFX ef ex = do + let whole' = whole ex + part' <- subArc (part ef) (part ex) + return (Event (combineContexts [context ef, context ex]) whole' part' (value ef $ value ex)) applyPatToPatSqueeze :: Pattern (a -> b) -> Pattern a -> Pattern b applyPatToPatSqueeze pf px = squeezeJoin $ (\f -> f <$> px) <$> pf -- * Monad and friends + -- + -- $monadAndFriends -- -- Note there are four ways of joining - the default 'unwrap' used by @>>=@, as well @@ -211,72 +227,86 @@ 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, pureValue = Nothing} - where q st = concatMap - (\(Event c w p v) -> - mapMaybe (munge c w p) $ query v st {arc = p}) - (query pp st) - munge oc ow op (Event ic iw ip v') = - do - w' <- subMaybeArc ow iw - p' <- subArc op ip - return (Event (combineContexts [ic, oc]) w' p' v') + where + q st = + concatMap + ( \(Event c w p v) -> + mapMaybe (munge c w p) $ query v st {arc = p} + ) + (query pp st) + munge oc ow op (Event ic iw ip v') = + do + w' <- subMaybeArc ow iw + p' <- subArc op ip + return (Event (combineContexts [ic, oc]) w' p' v') -- | 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, pureValue = Nothing} - where q st = concatMap - (\(Event oc _ op v) -> mapMaybe (munge oc) $ query v st {arc = op} - ) - (query pp st) - where munge oc (Event ic iw ip v) = - do - p <- subArc (arc st) ip - p' <- subArc p (arc st) - return (Event (combineContexts [ic, oc]) iw p' v) + where + q st = + concatMap + ( \(Event oc _ op v) -> mapMaybe (munge oc) $ query v st {arc = op} + ) + (query pp st) + where + munge oc (Event ic iw ip v) = + do + p <- subArc (arc st) ip + p' <- subArc p (arc st) + return (Event (combineContexts [ic, oc]) iw p' v) -- | 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, pureValue = Nothing} - where q st = concatMap - (\e -> - mapMaybe (munge (context e) (whole e) (part e)) $ query (value e) st {arc = pure (start $ wholeOrPart e)} - ) - (query pp st) - where munge oc ow op (Event ic _ _ v') = - do - p' <- subArc (arc st) op - return (Event (combineContexts [oc, ic]) ow p' v') + where + q st = + concatMap + ( \e -> + mapMaybe (munge (context e) (whole e) (part e)) $ query (value e) st {arc = pure (start $ wholeOrPart e)} + ) + (query pp st) + where + munge oc ow op (Event ic _ _ v') = + do + p' <- subArc (arc st) op + return (Event (combineContexts [oc, ic]) ow p' v') -- | Like @unwrap@, but cycles of the inner patterns are compressed to fit the -- 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, 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} - ) - (query pp st) - munge oContext oWhole oPart (Event iContext iWhole iPart v) = - do w' <- subMaybeArc oWhole iWhole - p' <- subArc oPart iPart - return (Event (combineContexts [iContext, oContext]) w' p' v) - + where + q st = + concatMap + ( \e@(Event c w p v) -> + mapMaybe (munge c w p) $ query (focusArc (wholeOrPart e) v) st {arc = p} + ) + (query pp st) + munge oContext oWhole oPart (Event iContext iWhole iPart v) = + do + w' <- subMaybeArc oWhole iWhole + p' <- subArc oPart iPart + return (Event (combineContexts [iContext, oContext]) w' p' v) _trigJoin :: Bool -> Pattern (Pattern a) -> Pattern a _trigJoin cycleZero pat_of_pats = pattern q - where q st = - catMaybes $ - concatMap - (\(Event oc jow op ov) -> - map (\(Event ic (iw) ip iv) -> - 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 (fromJust jow)) `rotR` ov) st + where + q st = + catMaybes $ + concatMap + ( \(Event oc jow op ov) -> + map + ( \(Event ic (iw) ip iv) -> + 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 (fromJust jow)) `rotR` ov) st ) (query (filterDigital pat_of_pats) st) @@ -299,7 +329,6 @@ restartTo :: Pattern Rational -> Pattern a -> Pattern a restartTo bp pat = trigZeroJoin $ (\v -> rotL v pat) <$> bp -- | * Patterns as numbers - noOv :: String -> a noOv meth = error $ meth ++ ": not supported for patterns" @@ -313,21 +342,21 @@ instance Ord a => Ord (Pattern a) where (<=) = noOv "(<=)" instance Num a => Num (Pattern a) where - negate = fmap negate - (+) = liftA2 (+) - (*) = liftA2 (*) + negate = fmap negate + (+) = liftA2 (+) + (*) = liftA2 (*) fromInteger = pure . fromInteger - abs = fmap abs - signum = fmap signum + abs = fmap abs + signum = fmap signum instance Enum a => Enum (Pattern a) where - succ = fmap succ - pred = fmap pred - toEnum = pure . toEnum - fromEnum = noOv "fromEnum" - enumFrom = noOv "enumFrom" - enumFromThen = noOv "enumFromThen" - enumFromTo = noOv "enumFromTo" + succ = fmap succ + pred = fmap pred + toEnum = pure . toEnum + fromEnum = noOv "fromEnum" + enumFrom = noOv "enumFrom" + enumFromThen = noOv "enumFromThen" + enumFromTo = noOv "enumFromTo" enumFromThenTo = noOv "enumFromThenTo" instance Monoid (Pattern a) where @@ -340,67 +369,67 @@ instance (Num a, Ord a) => Real (Pattern a) where toRational = noOv "toRational" instance (Integral a) => Integral (Pattern a) where - quot = liftA2 quot - rem = liftA2 rem - div = liftA2 div - mod = liftA2 mod - toInteger = noOv "toInteger" + quot = liftA2 quot + rem = liftA2 rem + div = liftA2 div + mod = liftA2 mod + toInteger = noOv "toInteger" x `quotRem` y = (x `quot` y, x `rem` y) - x `divMod` y = (x `div` y, x `mod` y) + x `divMod` y = (x `div` y, x `mod` y) instance (Fractional a) => Fractional (Pattern a) where - recip = fmap recip + recip = fmap recip fromRational = pure . fromRational instance (Floating a) => Floating (Pattern a) where - pi = pure pi - sqrt = fmap sqrt - exp = fmap exp - log = fmap log - sin = fmap sin - cos = fmap cos - asin = fmap asin - atan = fmap atan - acos = fmap acos - sinh = fmap sinh - cosh = fmap cosh + pi = pure pi + sqrt = fmap sqrt + exp = fmap exp + log = fmap log + sin = fmap sin + cos = fmap cos + asin = fmap asin + atan = fmap atan + acos = fmap acos + sinh = fmap sinh + cosh = fmap cosh asinh = fmap asinh atanh = fmap atanh acosh = fmap acosh instance (RealFrac a) => RealFrac (Pattern a) where properFraction = noOv "properFraction" - truncate = noOv "truncate" - round = noOv "round" - ceiling = noOv "ceiling" - floor = noOv "floor" + truncate = noOv "truncate" + round = noOv "round" + ceiling = noOv "ceiling" + floor = noOv "floor" instance (RealFloat a) => RealFloat (Pattern a) where - floatRadix = noOv "floatRadix" - floatDigits = noOv "floatDigits" - floatRange = noOv "floatRange" - decodeFloat = noOv "decodeFloat" - encodeFloat = ((.).(.)) pure encodeFloat - exponent = noOv "exponent" - significand = noOv "significand" - scaleFloat n = fmap (scaleFloat n) - isNaN = noOv "isNaN" - isInfinite = noOv "isInfinite" + floatRadix = noOv "floatRadix" + floatDigits = noOv "floatDigits" + floatRange = noOv "floatRange" + decodeFloat = noOv "decodeFloat" + encodeFloat = ((.) . (.)) pure encodeFloat + exponent = noOv "exponent" + significand = noOv "significand" + scaleFloat n = fmap (scaleFloat n) + isNaN = noOv "isNaN" + isInfinite = noOv "isInfinite" isDenormalized = noOv "isDenormalized" isNegativeZero = noOv "isNegativeZero" - isIEEE = noOv "isIEEE" - atan2 = liftA2 atan2 + isIEEE = noOv "isIEEE" + atan2 = liftA2 atan2 instance Num ValueMap where - negate = (applyFIS negate negate id <$>) - (+) = Map.unionWith (fNum2 (+) (+)) - (*) = Map.unionWith (fNum2 (*) (*)) + negate = (applyFIS negate negate id <$>) + (+) = Map.unionWith (fNum2 (+) (+)) + (*) = Map.unionWith (fNum2 (*) (*)) fromInteger i = Map.singleton "n" $ VI (fromInteger i) - signum = (applyFIS signum signum id <$>) - abs = (applyFIS abs abs id <$>) + signum = (applyFIS signum signum id <$>) + abs = (applyFIS abs abs id <$>) instance Fractional ValueMap where - recip = fmap (applyFIS recip id id) + recip = fmap (applyFIS recip id id) fromRational r = Map.singleton "speed" $ VF (fromRational r) class Moddable a where @@ -408,31 +437,36 @@ class Moddable a where instance Moddable Double where gmod = mod' + instance Moddable Rational where gmod = mod' + instance Moddable Note where gmod (Note a) (Note b) = Note (mod' a b) + instance Moddable Int where gmod = mod + instance Moddable ValueMap where gmod = Map.unionWith (fNum2 mod mod') -instance Floating ValueMap - where pi = noOv "pi" - exp _ = noOv "exp" - log _ = noOv "log" - sin _ = noOv "sin" - cos _ = noOv "cos" - asin _ = noOv "asin" - acos _ = noOv "acos" - atan _ = noOv "atan" - sinh _ = noOv "sinh" - cosh _ = noOv "cosh" - asinh _ = noOv "asinh" - acosh _ = noOv "acosh" - atanh _ = noOv "atanh" +instance Floating ValueMap where + pi = noOv "pi" + exp _ = noOv "exp" + log _ = noOv "log" + sin _ = noOv "sin" + cos _ = noOv "cos" + asin _ = noOv "asin" + acos _ = noOv "acos" + atan _ = noOv "atan" + sinh _ = noOv "sinh" + cosh _ = noOv "cosh" + asinh _ = noOv "asinh" + acosh _ = noOv "acosh" + atanh _ = noOv "atanh" ------------------------------------------------------------------------ + -- * Internal/fundamental functions empty :: Pattern a @@ -456,8 +490,10 @@ splitQueries p = p {query = \st -> concatMap (\a -> query p st {arc = a}) $ arcC -- | Apply a function to the arcs/timespans (both whole and parts) of the result withResultArc :: (Arc -> Arc) -> Pattern a -> Pattern a -withResultArc f pat = pat - { query = map (\(Event c w p e) -> Event c (f <$> w) (f p) e) . query pat} +withResultArc f pat = + pat + { query = map (\(Event c w p e) -> Event c (f <$> w) (f p) e) . query pat + } -- | Apply a function to the time (both start and end of the timespans -- of both whole and parts) of the result @@ -465,7 +501,7 @@ 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 +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 @@ -476,11 +512,11 @@ 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 +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))} +withQueryControls f pat = pat {query = query pat . (\(State a m) -> State a (f m))} -- | @withEvent f p@ returns a new @Pattern@ with each event mapped over -- function @f@. @@ -530,68 +566,66 @@ extractN :: String -> ControlPattern -> Pattern Note extractN = _extract getN compressArc :: Arc -> Pattern a -> Pattern a -compressArc (Arc s e) p | s > e = empty - | s > 1 || e > 1 = empty - | s < 0 || e < 0 = empty - | otherwise = s `rotR` _fastGap (1/(e-s)) p +compressArc (Arc s e) p + | s > e = empty + | s > 1 || e > 1 = empty + | s < 0 || e < 0 = empty + | otherwise = s `rotR` _fastGap (1 / (e - s)) p compressArcTo :: Arc -> Pattern a -> Pattern a compressArcTo (Arc s e) = compressArc (Arc (cyclePos s) (e - sam s)) focusArc :: Arc -> Pattern a -> Pattern a -focusArc (Arc s e) p = (cyclePos s) `rotR` (_fast (1/(e-s)) p) +focusArc (Arc s e) p = (cyclePos s) `rotR` (_fast (1 / (e - s)) p) - -{-| Speed up a pattern by the given time pattern. - -For example, the following will play the sound pattern @"bd sn kurt"@ twice as -fast (i.e., so it repeats twice per cycle), and the vowel pattern three times -as fast: - -> d1 $ sound (fast 2 "bd sn kurt") -> # fast 3 (vowel "a e o") - -The first parameter can be patterned to, for example, play the pattern at twice -the speed for the first half of each cycle and then four times the speed for the -second half: - -> d1 $ fast "2 4" $ sound "bd sn kurt cp" --} +-- | Speed up a pattern by the given time pattern. +-- +-- For example, the following will play the sound pattern @"bd sn kurt"@ twice as +-- fast (i.e., so it repeats twice per cycle), and the vowel pattern three times +-- as fast: +-- +-- > d1 $ sound (fast 2 "bd sn kurt") +-- > # fast 3 (vowel "a e o") +-- +-- The first parameter can be patterned to, for example, play the pattern at twice +-- the speed for the first half of each cycle and then four times the speed for the +-- second half: +-- +-- > d1 $ fast "2 4" $ sound "bd sn kurt cp" fast :: Pattern Time -> Pattern a -> Pattern a 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 - pattern at every repetition. - - To better understand how it works, compare it with 'fast': - - >>> print $ fast "1 2" $ s "bd sn" - (0>½)|s: "bd" - (½>¾)|s: "bd" - (¾>1)|s: "sn" - - This will give @bd@ played in the first half cycle, and @bd sn@ in the second - half. On the other hand, using fastSqueeze; - - >>> print $ fastSqueeze "1 2" $ s "bd sn" - (0>¼)|s: "bd" - (¼>½)|s: "sn" - (½>⅝)|s: "bd" - (⅝>¾)|s: "sn" - (¾>⅞)|s: "bd" - (⅞>1)|s: "sn" - - The original pattern will play in the first half, and two repetitions of the - original pattern will play in the second half. That is, every repetition - contains the whole pattern. - - If the time pattern has a single value, it becomes equivalent to 'fast': - - > d1 $ fastSqueeze 2 $ s "bd sn" - > d1 $ fast 2 $ s "bd sn" - > d1 $ s "[bd sn]*2" --} +-- | @fastSqueeze@ speeds up a pattern by a time pattern given as input, +-- squeezing the resulting pattern inside one cycle and playing the original +-- pattern at every repetition. +-- +-- To better understand how it works, compare it with 'fast': +-- +-- >>> print $ fast "1 2" $ s "bd sn" +-- (0>½)|s: "bd" +-- (½>¾)|s: "bd" +-- (¾>1)|s: "sn" +-- +-- This will give @bd@ played in the first half cycle, and @bd sn@ in the second +-- half. On the other hand, using fastSqueeze; +-- +-- >>> print $ fastSqueeze "1 2" $ s "bd sn" +-- (0>¼)|s: "bd" +-- (¼>½)|s: "sn" +-- (½>⅝)|s: "bd" +-- (⅝>¾)|s: "sn" +-- (¾>⅞)|s: "bd" +-- (⅞>1)|s: "sn" +-- +-- The original pattern will play in the first half, and two repetitions of the +-- original pattern will play in the second half. That is, every repetition +-- contains the whole pattern. +-- +-- If the time pattern has a single value, it becomes equivalent to 'fast': +-- +-- > d1 $ fastSqueeze 2 $ s "bd sn" +-- > d1 $ fast 2 $ s "bd sn" +-- > d1 $ s "[bd sn]*2" fastSqueeze :: Pattern Time -> Pattern a -> Pattern a fastSqueeze = patternifySqueeze _fast @@ -600,116 +634,132 @@ density :: Pattern Time -> Pattern a -> Pattern a density = fast _fast :: Time -> Pattern a -> Pattern a -_fast rate pat | rate == 0 = silence - | rate < 0 = rev $ _fast (negate rate) pat - | otherwise = keepTactus pat $ withResultTime (/ rate) $ withQueryTime (* rate) pat - -{-| Slow down a pattern by the given time pattern. +_fast rate pat + | rate == 0 = silence + | rate < 0 = rev $ _fast (negate rate) pat + | otherwise = keepTactus pat $ withResultTime (/ rate) $ withQueryTime (* rate) pat - For example, the following will play the sound pattern @"bd sn kurt"@ twice as - slow (i.e., so it repeats once every two cycles), and the vowel pattern three - times as slow: - - > d1 $ sound (slow 2 "bd sn kurt") - > # slow 3 (vowel "a e o") --} +-- | Slow down a pattern by the given time pattern. +-- +-- For example, the following will play the sound pattern @"bd sn kurt"@ twice as +-- slow (i.e., so it repeats once every two cycles), and the vowel pattern three +-- times as slow: +-- +-- > d1 $ sound (slow 2 "bd sn kurt") +-- > # slow 3 (vowel "a e o") slow :: Pattern Time -> Pattern a -> Pattern a slow = patternify _slow + _slow :: Time -> Pattern a -> Pattern a _slow 0 _ = silence -_slow r p = _fast (1/r) p +_slow r p = _fast (1 / r) p _fastGap :: Time -> Pattern a -> Pattern a _fastGap 0 _ = empty -_fastGap r p = splitQueries $ - withResultArc (\(Arc s e) -> Arc (sam s + ((s - sam s)/r')) - (sam s + ((e - sam s)/r')) - ) $ p {query = f} - where r' = max r 1 - -- zero width queries of the next sam should return zero in this case.. - f st@(State a _) | start a' == nextSam (start a) = [] - | otherwise = query p st {arc = a'} - where mungeQuery t = sam t + min 1 (r' * cyclePos t) - a' = (\(Arc s e) -> Arc (mungeQuery s) (mungeQuery e)) a - -{-| Shifts a pattern back in time by the given amount, expressed in cycles. - - This will skip to the fourth cycle: - - > do - > resetCycles - > d1 $ rotL 4 $ seqP - > [ (0, 12, sound "bd bd*2") - > , (4, 12, sound "hh*2 [sn cp] cp future*4") - > , (8, 12, sound (samples "arpy*8" (run 16))) - > ] - - Useful when building and testing out longer sequences. --} +_fastGap r p = + splitQueries $ + withResultArc + ( \(Arc s e) -> + Arc + (sam s + ((s - sam s) / r')) + (sam s + ((e - sam s) / r')) + ) + $ p {query = f} + where + r' = max r 1 + -- zero width queries of the next sam should return zero in this case.. + f st@(State a _) + | start a' == nextSam (start a) = [] + | otherwise = query p st {arc = a'} + where + mungeQuery t = sam t + min 1 (r' * cyclePos t) + a' = (\(Arc s e) -> Arc (mungeQuery s) (mungeQuery e)) a + +-- | Shifts a pattern back in time by the given amount, expressed in cycles. +-- +-- This will skip to the fourth cycle: +-- +-- > do +-- > resetCycles +-- > d1 $ rotL 4 $ seqP +-- > [ (0, 12, sound "bd bd*2") +-- > , (4, 12, sound "hh*2 [sn cp] cp future*4") +-- > , (8, 12, sound (samples "arpy*8" (run 16))) +-- > ] +-- +-- Useful when building and testing out longer sequences. rotL :: Time -> Pattern a -> Pattern a rotL t p = withResultTime (subtract t) $ withQueryTime (+ t) p -{-| Shifts a pattern forward in time by the given amount, expressed in cycles. - Opposite of 'rotL'. --} +-- | Shifts a pattern forward in time by the given amount, expressed in cycles. +-- Opposite of 'rotL'. rotR :: Time -> Pattern a -> Pattern a rotR t = rotL (negate t) -{- | @rev p@ returns @p@ with the event positions in each cycle reversed (or - mirrored). - - For example rev @"1 [~ 2] ~ 3"@ is equivalent to rev @"3 ~ [2 ~] 1"@. - - Note that @rev@ reverses on a cycle-by-cycle basis. This means that @rev (slow - 2 "1 2 3 4")@ would actually result in @(slow 2 "2 1 4 3")@. This is because the - @slow 2@ makes the repeating pattern last two cycles, each of which is reversed - independently. - - In practice rev is generally used with conditionals, for example with every: - - > d1 $ every 3 rev $ n "0 1 [~ 2] 3" # sound "arpy" - - or 'jux': - - > d1 $ jux rev $ n (iter 4 "0 1 [~ 2] 3") # sound "arpy" --} +-- | @rev p@ returns @p@ with the event positions in each cycle reversed (or +-- mirrored). +-- +-- For example rev @"1 [~ 2] ~ 3"@ is equivalent to rev @"3 ~ [2 ~] 1"@. +-- +-- Note that @rev@ reverses on a cycle-by-cycle basis. This means that @rev (slow +-- 2 "1 2 3 4")@ would actually result in @(slow 2 "2 1 4 3")@. This is because the +-- @slow 2@ makes the repeating pattern last two cycles, each of which is reversed +-- independently. +-- +-- In practice rev is generally used with conditionals, for example with every: +-- +-- > d1 $ every 3 rev $ n "0 1 [~ 2] 3" # sound "arpy" +-- +-- or 'jux': +-- +-- > d1 $ jux rev $ n (iter 4 "0 1 [~ 2] 3") # sound "arpy" rev :: Pattern a -> Pattern a rev p = - keepMeta p $ splitQueries $ p { - query = \st -> map makeWholeAbsolute $ - mapParts (mirrorArc (midCycle $ arc st)) $ - map makeWholeRelative - (query p st - {arc = mirrorArc (midCycle $ arc st) (arc st) - }) - } - where makeWholeRelative :: Event a -> Event a - makeWholeRelative e@Event {whole = Nothing} = e - makeWholeRelative (Event c (Just (Arc s e)) p'@(Arc s' e') v) = - Event c (Just $ Arc (s'-s) (e-e')) p' v - makeWholeAbsolute :: Event a -> Event a - makeWholeAbsolute e@Event {whole = Nothing} = e - makeWholeAbsolute (Event c (Just (Arc s e)) p'@(Arc s' e') v) = - Event c (Just $ Arc (s'-e) (e'+s)) p' v - midCycle :: Arc -> Time - midCycle (Arc s _) = sam s + 0.5 - mapParts :: (Arc -> Arc) -> [Event a] -> [Event a] - mapParts f es = (\(Event c w p' v) -> Event c w (f p') v) <$> es - -- | Returns the `mirror image' of a 'Arc' around the given point in time - mirrorArc :: Time -> Arc -> Arc - mirrorArc mid' (Arc s e) = Arc (mid' - (e-mid')) (mid'+(mid'-s)) + keepMeta p $ + splitQueries $ + p + { query = \st -> + map makeWholeAbsolute $ + mapParts (mirrorArc (midCycle $ arc st)) $ + map + makeWholeRelative + ( query + p + st + { arc = mirrorArc (midCycle $ arc st) (arc st) + } + ) + } + where + makeWholeRelative :: Event a -> Event a + makeWholeRelative e@Event {whole = Nothing} = e + makeWholeRelative (Event c (Just (Arc s e)) p'@(Arc s' e') v) = + Event c (Just $ Arc (s' - s) (e - e')) p' v + makeWholeAbsolute :: Event a -> Event a + makeWholeAbsolute e@Event {whole = Nothing} = e + makeWholeAbsolute (Event c (Just (Arc s e)) p'@(Arc s' e') v) = + Event c (Just $ Arc (s' - e) (e' + s)) p' v + midCycle :: Arc -> Time + midCycle (Arc s _) = sam s + 0.5 + mapParts :: (Arc -> Arc) -> [Event a] -> [Event a] + mapParts f es = (\(Event c w p' v) -> Event c w (f p') v) <$> es + -- Returns the `mirror image' of a 'Arc' around the given point in time + mirrorArc :: Time -> Arc -> Arc + mirrorArc mid' (Arc s e) = Arc (mid' - (e - mid')) (mid' + (mid' - s)) -- | 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, pureValue = Nothing} - where q st = map match $ query pb st + where + q st = map match $ query pb st + where + match ex@(Event xContext xWhole xPart x) = + Event (combineContexts $ xContext : map context as') xWhole xPart (any (f x . value) as', x) where - match ex@(Event xContext xWhole xPart x) = - Event (combineContexts $ xContext:map context as') xWhole xPart (any (f x . value) as', x) - where as' = as $ start $ wholeOrPart ex - as s = query pa $ fQuery s - fQuery s = st {arc = Arc s s} + as' = as $ start $ wholeOrPart ex + as s = query pa $ fQuery s + fQuery s = st {arc = Arc s s} -- ** Event filters @@ -744,18 +794,19 @@ playFor s e pat = pattern $ \st -> maybe [] (\a -> query pat (st {arc = a})) $ s -- 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' +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 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 +patternify f pa p = innerJoin $ (`f` p) <$> pa -- versions that preserve the tactus -patternify' ::(b -> Pattern c -> Pattern a) -> Pattern b -> Pattern c -> Pattern a +patternify' :: (b -> Pattern c -> Pattern a) -> Pattern b -> Pattern c -> Pattern a patternify' f pa p = (patternify f pa p) {tactus = tactus p} patternify2 :: (a -> b -> c -> Pattern d) -> Pattern a -> Pattern b -> c -> Pattern d @@ -791,29 +842,32 @@ withContext f pat = keepMeta pat $ withEvents (map (\e -> e {context = f $ conte -- where they are within a whole tidal pattern deltaMini :: String -> String deltaMini = outside 0 0 - where outside :: Int -> Int -> String -> String - outside _ _ [] = [] - outside column line ('"':xs) = "(deltaContext " - ++ show column - ++ " " - ++ show line - ++ " \"" - ++ inside (column+1) line xs - 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 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 + where + outside :: Int -> Int -> String -> String + outside _ _ [] = [] + outside column line ('"' : xs) = + "(deltaContext " + ++ show column + ++ " " + ++ show line + ++ " \"" + ++ inside (column + 1) line xs + 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 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 class Stringy a where deltaContext :: Int -> Int -> a -> a instance Stringy (Pattern a) where deltaContext column line pat = withEvents (map (\e -> e {context = f $ context e})) pat - where f :: Context -> Context - f (Context xs) = Context $ map (\((bx,by), (ex,ey)) -> ((bx+column,by+line), (ex+column,ey+line))) xs + where + f :: Context -> Context + f (Context xs) = Context $ map (\((bx, by), (ex, ey)) -> ((bx + column, by + line), (ex + column, ey + line))) xs -- deltaContext on an actual (non overloaded) string is a no-op instance Stringy String where @@ -824,16 +878,19 @@ instance Stringy String where -- | Some context for an event, currently just position within sourcecode data Context = Context {contextPosition :: [((Int, Int), (Int, Int))]} deriving (Eq, Ord, Generic) + instance NFData Context -- | An event is a value that's active during a timespan. If a whole -- 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 - } deriving (Eq, Ord, Functor, Generic) + { context :: Context, + whole :: Maybe a, + part :: a, + value :: b + } + deriving (Eq, Ord, Functor, Generic) + instance (NFData a, NFData b) => NFData (EventF a b) type Event a = EventF (ArcF Time) a @@ -842,7 +899,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 @@ -855,25 +912,27 @@ onsetIn a e = isIn a (wholeStart e) defragParts :: Eq a => [Event a] -> [Event a] defragParts [] = [] defragParts [e] = [e] -defragParts (e:es) | isJust i = defraged : defragParts (delete e' es) - | otherwise = e : defragParts es - where i = findIndex (isAdjacent e) es - e' = es !! fromJust i - defraged = Event (context e) (whole e) u (value e) - u = hull (part e) (part e') +defragParts (e : es) + | isJust i = defraged : defragParts (delete e' es) + | otherwise = e : defragParts es + where + i = findIndex (isAdjacent e) es + e' = es !! fromJust i + defraged = Event (context e) (whole e) u (value e) + u = hull (part e) (part e') -- | Returns 'True' if the two given events are adjacent parts of the same whole isAdjacent :: Eq a => Event a -> Event a -> Bool -isAdjacent e e' = (whole e == whole e') - && (value e == value e') - && ((stop (part e) == start (part e')) - || - (stop (part e') == start (part e)) - ) +isAdjacent e e' = + (whole e == whole e') + && (value e == value e') + && ( (stop (part e) == start (part e')) + || (stop (part e') == start (part 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 @@ -899,50 +958,54 @@ eventValue :: Event a -> a eventValue = value eventHasOnset :: Event a -> Bool -eventHasOnset e | isAnalog e = False - | otherwise = start (fromJust $ whole e) == start (part e) +eventHasOnset e + | isAnalog e = False + | otherwise = start (fromJust $ whole e) == start (part e) -- TODO - Is this used anywhere? Just tests, it seems -- TODO - support 'context' field toEvent :: (((Time, Time), (Time, Time)), a) -> Event a toEvent (((ws, we), (ps, pe)), v) = Event (Context []) (Just $ Arc ws we) (Arc ps pe) v - -- Resolves higher order VState values to plain values, by passing through (and changing) state +-- Resolves higher order VState values to plain values, by passing through (and changing) state 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) - (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 +resolveState sMap (e : es) = (sMap'', (e {value = v'}) : es') + where + f sm (VState v) = v sm + 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 -- ** Values -- | Polymorphic values - -data Value = VS { svalue :: String } - | VF { fvalue :: Double } - | VN { nvalue :: Note } - | VR { rvalue :: Rational } - | VI { ivalue :: Int } - | VB { bvalue :: Bool } - | VX { xvalue :: [Word8] } -- Used for OSC 'blobs' - | VPattern {pvalue :: Pattern Value} - | VList {lvalue :: [Value]} - | VState {statevalue :: ValueMap -> (ValueMap, Value)} - deriving (Typeable, Generic) +data Value + = VS {svalue :: String} + | VF {fvalue :: Double} + | VN {nvalue :: Note} + | VR {rvalue :: Rational} + | VI {ivalue :: Int} + | VB {bvalue :: Bool} + | VX {xvalue :: [Word8]} -- Used for OSC 'blobs' + | VPattern {pvalue :: Pattern Value} + | VList {lvalue :: [Value]} + | VState {statevalue :: ValueMap -> (ValueMap, Value)} + deriving (Typeable, Generic) class Valuable a where toValue :: a -> Value + instance NFData Value type ValueMap = Map.Map String Value -- | Note is Double, but with a different parser -newtype Note = Note { unNote :: Double } +newtype Note = Note {unNote :: Double} deriving (Typeable, Data, Generic, Eq, Ord, Enum, Num, Fractional, Floating, Real, RealFrac) instance NFData Note @@ -957,18 +1020,25 @@ instance Show Note where instance Valuable String where toValue a = VS a + instance Valuable Double where toValue a = VF a + instance Valuable Rational where toValue a = VR a + instance Valuable Int where toValue a = VI a + instance Valuable Bool where toValue a = VB a + instance Valuable Note where toValue a = VN a + instance Valuable [Word8] where toValue a = VX a + instance Valuable [Value] where toValue a = VList a @@ -980,63 +1050,50 @@ instance Eq Value where (VN x) == (VN y) = x == y (VR x) == (VR y) = x == y (VX x) == (VX y) = x == y - (VF x) == (VI y) = x == fromIntegral y (VI y) == (VF x) = x == fromIntegral y - (VF x) == (VR y) = toRational x == y (VR y) == (VF x) = toRational x == y (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 _) _ = 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 (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 (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 (VF x) (VN y) = compare x (unNote y) - compare (VN x) (VF y) = compare (unNote 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 (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 (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) (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 -- you can't really compare patterns, state or lists.. compare (VPattern _) (VPattern _) = EQ - compare (VPattern _) _ = GT - compare _ (VPattern _) = LT - - compare (VState _) (VState _) = EQ - compare (VState _) _ = GT - compare _ (VState _) = LT - - compare (VList _) (VList _) = EQ - compare (VList _) _ = GT - compare _ (VList _) = LT + compare (VPattern _) _ = GT + compare _ (VPattern _) = LT + compare (VState _) (VState _) = EQ + compare (VState _) _ = GT + compare _ (VState _) = LT + compare (VList _) (VList _) = EQ + compare (VList _) _ = GT + compare _ (VList _) = LT -- | General utilities.. @@ -1052,89 +1109,91 @@ applyFIS _ _ _ v = v -- | Apply one of two functions to a pair of Values, depending on their types (int -- or float; strings and rationals are ignored) fNum2 :: (Int -> Int -> Int) -> (Double -> Double -> Double) -> Value -> Value -> Value -fNum2 fInt _ (VI a) (VI b) = VI (fInt a b) -fNum2 _ fFloat (VF a) (VF b) = VF (fFloat a b) -fNum2 _ fFloat (VN (Note a)) (VN (Note b)) = VN (Note $ fFloat a b) -fNum2 _ fFloat (VF a) (VN (Note b)) = VN (Note $ fFloat a b) -fNum2 _ fFloat (VN (Note a)) (VF b) = VN (Note $ fFloat a b) -fNum2 _ fFloat (VI a) (VF b) = VF (fFloat (fromIntegral a) b) -fNum2 _ fFloat (VF a) (VI b) = VF (fFloat a (fromIntegral b)) +fNum2 fInt _ (VI a) (VI b) = VI (fInt a b) +fNum2 _ fFloat (VF a) (VF b) = VF (fFloat a b) +fNum2 _ fFloat (VN (Note a)) (VN (Note b)) = VN (Note $ fFloat a b) +fNum2 _ fFloat (VF a) (VN (Note b)) = VN (Note $ fFloat a b) +fNum2 _ fFloat (VN (Note a)) (VF b) = VN (Note $ fFloat a b) +fNum2 _ fFloat (VI a) (VF b) = VF (fFloat (fromIntegral a) b) +fNum2 _ fFloat (VF a) (VI b) = VF (fFloat a (fromIntegral b)) fNum2 fInt fFloat (VState a) b = VState $ \cmap -> ((\a' -> fNum2 fInt fFloat a' b) <$> (a cmap)) fNum2 fInt fFloat a (VState b) = VState $ \cmap -> ((\b' -> fNum2 fInt fFloat a b') <$> (b cmap)) -fNum2 _ _ x _ = x +fNum2 _ _ x _ = x 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 - sameDur :: Event a -> Event a -> Bool sameDur e1 e2 = (whole e1 == whole e2) && (part e1 == part e2) groupEventsBy :: Eq a => (Event a -> Event a -> Bool) -> [Event a] -> [[Event a]] groupEventsBy _ [] = [] -groupEventsBy f (e:es) = eqs:(groupEventsBy f (es \\ eqs)) - where eqs = e:[x | x <- es, f e x] +groupEventsBy f (e : es) = eqs : (groupEventsBy f (es \\ eqs)) + where + eqs = e : [x | x <- es, f e x] -- assumes that all events in the list have same whole/part collectEvent :: [Event a] -> Maybe (Event [a]) collectEvent [] = Nothing -collectEvent l@(e:_) = Just $ e {context = con, value = vs} - where con = unionC $ map context l - vs = map value l - unionC [] = Context [] - unionC ((Context is):cs) = Context (is ++ iss) - where Context iss = unionC cs +collectEvent l@(e : _) = Just $ e {context = con, value = vs} + where + con = unionC $ map context l + vs = map value l + unionC [] = Context [] + unionC ((Context is) : cs) = Context (is ++ iss) + where + Context iss = unionC cs collectEventsBy :: Eq a => (Event a -> Event a -> Bool) -> [Event a] -> [Event [a]] collectEventsBy f es = remNo $ map collectEvent (groupEventsBy f es) - where - remNo [] = [] - remNo (Nothing:cs) = remNo cs - remNo ((Just c):cs) = c : (remNo cs) + where + remNo [] = [] + remNo (Nothing : cs) = remNo cs + remNo ((Just c) : cs) = c : (remNo cs) -- | collects all events satisfying the same constraint into a list collectBy :: Eq a => (Event a -> Event a -> Bool) -> Pattern a -> Pattern [a] @@ -1145,10 +1204,11 @@ collect :: Eq a => Pattern a -> Pattern [a] collect = collectBy sameDur uncollectEvent :: Event [a] -> [Event a] -uncollectEvent e = [e {value = (value e)!!i, context = resolveContext i (context e)} | i <-[0..length (value e) - 1]] - where resolveContext i (Context xs) = case length xs <= i of - True -> Context [] - False -> Context [xs!!i] +uncollectEvent e = [e {value = (value e) !! i, context = resolveContext i (context e)} | i <- [0 .. length (value e) - 1]] + where + resolveContext i (Context xs) = case length xs <= i of + True -> Context [] + False -> Context [xs !! i] uncollectEvents :: [Event [a]] -> [Event a] uncollectEvents = concatMap uncollectEvent diff --git a/src/Sound/Tidal/Safe/Boot.hs b/src/Sound/Tidal/Safe/Boot.hs index b9a33bed..e69405f3 100644 --- a/src/Sound/Tidal/Safe/Boot.hs +++ b/src/Sound/Tidal/Safe/Boot.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} {- Safe/Boot.hs - as in BootTidal but in the Op monad Copyright (C) 2021 Johannes Waldmann and contributors @@ -18,9 +19,7 @@ You should have received a copy of the GNU General Public License along with this library. If not, see . -} - {-# OPTIONS_GHC -Wno-missing-signatures #-} -{-# language NoMonomorphismRestriction #-} module Sound.Tidal.Safe.Boot where @@ -31,98 +30,142 @@ import qualified Sound.Tidal.Transition -- this will be provided by the Reader monad p = streamReplace + hush = streamHush + list = streamList + mute = streamMute + unmute = streamUnmute + solo = streamSolo + unsolo = streamUnsolo + once = streamOnce + first = streamFirst -asap = once -nudgeAll = streamNudgeAll -all = streamAll -{-| - Resets the cycle count back to 0. - Useful to make sure a pattern or set of patterns start from the beginning: +asap = once - > do - > resetCycles - > d1 $ s "bd hh hh hh" - > d2 $ s "ade" # cut 1 +nudgeAll = streamNudgeAll - Cycle count affects all patterns, so if there are any active, all of them will immediately jump to the beginning. - @resetCycles@ is also userful in multi-user Tidal. +all = streamAll - Also see 'setCycle', 'getnow'. --} +-- | +-- Resets the cycle count back to 0. +-- Useful to make sure a pattern or set of patterns start from the beginning: +-- +-- > do +-- > resetCycles +-- > d1 $ s "bd hh hh hh" +-- > d2 $ s "ade" # cut 1 +-- +-- Cycle count affects all patterns, so if there are any active, all of them will immediately jump to the beginning. +-- @resetCycles@ is also userful in multi-user Tidal. +-- +-- Also see 'setCycle', 'getnow'. resetCycles = streamResetCycles -{-| - Adjusts the number of cycles per second, i.e., tempo. - Accepts integers, decimals, and fractions. - - The default number of cycles per second is 0.5625, equivalent to 135\/60\/4, i.e., - 135 beats per minute if there are 4 beats per cycle. - - Representing cycles per second using fractions has the advantage of being more - human-readable and more closely aligned with how tempo is commonly represented - in music as beats per minute (bpm). For example, techno has a typical range of - 120-140 bpm and house has a range of 115-130 bpm. To set the tempo in Tidal to - fast house, e.g.,: @setcps (130\/60\/4)@. - - The following sound the same: - - > setcps (130/60/4) - > d1 $ n "1" # s "kick kick kick kick" - - and - - > setcps (130/60/1) - > d1 $ n "1" # s "kick" --} +-- | +-- Adjusts the number of cycles per second, i.e., tempo. +-- Accepts integers, decimals, and fractions. +-- +-- The default number of cycles per second is 0.5625, equivalent to 135\/60\/4, i.e., +-- 135 beats per minute if there are 4 beats per cycle. +-- +-- Representing cycles per second using fractions has the advantage of being more +-- human-readable and more closely aligned with how tempo is commonly represented +-- in music as beats per minute (bpm). For example, techno has a typical range of +-- 120-140 bpm and house has a range of 115-130 bpm. To set the tempo in Tidal to +-- fast house, e.g.,: @setcps (130\/60\/4)@. +-- +-- The following sound the same: +-- +-- > setcps (130/60/4) +-- > d1 $ n "1" # s "kick kick kick kick" +-- +-- and +-- +-- > setcps (130/60/1) +-- > d1 $ n "1" # s "kick" setcps = asap . cps -- * Transitions xfade i = transition True (Sound.Tidal.Transition.xfadeIn 4) i + xfadeIn i t = transition True (Sound.Tidal.Transition.xfadeIn t) i + histpan i t = transition True (Sound.Tidal.Transition.histpan t) i + wait i t = transition True (Sound.Tidal.Transition.wait t) i + waitT i f t = transition True (Sound.Tidal.Transition.waitT f t) i + jump i = transition True (Sound.Tidal.Transition.jump) i + jumpIn i t = transition True (Sound.Tidal.Transition.jumpIn t) i + jumpIn' i t = transition True (Sound.Tidal.Transition.jumpIn' t) i + jumpMod i t = transition True (Sound.Tidal.Transition.jumpMod t) i + mortal i lifespan releaseTime = transition True (Sound.Tidal.Transition.mortal lifespan releaseTime) i + interpolate i = transition True (Sound.Tidal.Transition.interpolate) i + interpolateIn i t = transition True (Sound.Tidal.Transition.interpolateIn t) i + clutch i = transition True (Sound.Tidal.Transition.clutch) i + clutchIn i t = transition True (Sound.Tidal.Transition.clutchIn t) i + anticipate i = transition True (Sound.Tidal.Transition.anticipate) i + anticipateIn i t = transition True (Sound.Tidal.Transition.anticipateIn t) i + forId i t = transition 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 setI = streamSetI + setF = streamSetF + setS = streamSetS + setR = streamSetR + setB = streamSetB diff --git a/src/Sound/Tidal/Safe/Context.hs b/src/Sound/Tidal/Safe/Context.hs index afb3754d..cf5c1ce0 100644 --- a/src/Sound/Tidal/Safe/Context.hs +++ b/src/Sound/Tidal/Safe/Context.hs @@ -18,42 +18,46 @@ You should have received a copy of the GNU General Public License along with this library. If not, see . -} - -{-# language GeneralizedNewtypeDeriving #-} -{-# language NoMonomorphismRestriction #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoMonomorphismRestriction #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} module Sound.Tidal.Safe.Context - ( Op () -- do not export constructor, - -- so the user has no way of putting arbitraty IO stuff - -- in "Op", and below "run" - , exec - , streamReplace - , streamHush - , streamList - , streamMute - , streamUnmute - , streamSolo - , streamUnsolo - , streamOnce - , streamFirst - , streamNudgeAll - , streamAll - , streamResetCycles - , streamSetI - , streamSetF - , streamSetS - , streamSetR - , streamSetB - , transition - , module C - , Target(..) + ( Op (), -- do not export constructor, + -- so the user has no way of putting arbitraty IO stuff + -- in "Op", and below "run" + exec, + streamReplace, + streamHush, + streamList, + streamMute, + streamUnmute, + streamSolo, + streamUnsolo, + streamOnce, + streamFirst, + streamNudgeAll, + streamAll, + streamResetCycles, + streamSetI, + streamSetF, + streamSetS, + streamSetR, + streamSetB, + transition, + module C, + Target (..), ) where +-- import Sound.Tidal.Transition as C + +import Control.Monad.Catch +import Control.Monad.Reader import Data.Ratio as C -import Sound.Tidal.Stream.Config as C +import Sound.Tidal.Context (Stream) +import qualified Sound.Tidal.Context as C import Sound.Tidal.Control as C import Sound.Tidal.Core as C import Sound.Tidal.Params as C @@ -61,45 +65,61 @@ import Sound.Tidal.ParseBP as C import Sound.Tidal.Pattern as C import Sound.Tidal.Scales as C import Sound.Tidal.Simple as C -import Sound.Tidal.Stream.Target (superdirtTarget) -import Sound.Tidal.Stream.Types (Target(..)) +import Sound.Tidal.Stream.Config as C import Sound.Tidal.Stream.Main (startTidal) --- import Sound.Tidal.Transition as C +import Sound.Tidal.Stream.Target (superdirtTarget) +import Sound.Tidal.Stream.Types (Target (..)) import Sound.Tidal.UI as C import Sound.Tidal.Version as C -import qualified Sound.Tidal.Context as C -import Sound.Tidal.Context (Stream) -import Control.Monad.Reader -import Control.Monad.Catch - -newtype Op r = Op ( ReaderT Stream IO r ) - deriving (Functor, Applicative, Monad, MonadCatch,MonadThrow) +newtype Op r = Op (ReaderT Stream IO r) + deriving (Functor, Applicative, Monad, MonadCatch, MonadThrow) exec :: Stream -> Op r -> IO r exec stream (Op m) = runReaderT m stream -op1 f = Op $ do a <- ask; lift $ f a -op2 f b = Op $ do a <- ask; lift $ f a b -op3 f b c = Op $ do a <- ask; lift $ f a b c -op4 f b c d = Op $ do a <- ask; lift $ f a b c d +op1 f = Op $ do a <- ask; lift $ f a + +op2 f b = Op $ do a <- ask; lift $ f a b + +op3 f b c = Op $ do a <- ask; lift $ f a b c + +op4 f b c d = Op $ do a <- ask; lift $ f a b c d + op5 f b c d e = Op $ do a <- ask; lift $ f a b c d e streamReplace = op3 C.streamReplace + streamHush = op1 C.streamHush + streamList = op1 C.streamList + streamMute = op2 C.streamMute + streamUnmute = op2 C.streamUnmute + streamSolo = op2 C.streamSolo + streamUnsolo = op2 C.streamUnsolo + streamOnce = op2 C.streamOnce + streamFirst = op2 C.streamFirst + streamNudgeAll = op2 C.streamNudgeAll + streamAll = op2 C.streamAll + streamResetCycles = op1 C.streamResetCycles + transition = op5 C.transition + streamSetI = op3 C.streamSetI + streamSetF = op3 C.streamSetF + streamSetS = op3 C.streamSetS + streamSetR = op3 C.streamSetR + streamSetB = op3 C.streamSetB diff --git a/src/Sound/Tidal/Scales.hs b/src/Sound/Tidal/Scales.hs index 6e354245..4e818392 100644 --- a/src/Sound/Tidal/Scales.hs +++ b/src/Sound/Tidal/Scales.hs @@ -18,228 +18,300 @@ module Sound.Tidal.Scales (scale, scaleList, scaleTable, getScale) where along with this library. If not, see . -} -import Prelude hiding ((<*), (*>)) import Data.Maybe +import Sound.Tidal.Core import Sound.Tidal.Pattern import Sound.Tidal.Utils -import Sound.Tidal.Core +import Prelude hiding ((*>), (<*)) -- * Scale definitions -- ** Five notes scales + minPent :: Fractional a => [a] -minPent = [0,3,5,7,10] +minPent = [0, 3, 5, 7, 10] + majPent :: Fractional a => [a] -majPent = [0,2,4,7,9] +majPent = [0, 2, 4, 7, 9] -- | Another mode of major pentatonic ritusen :: Fractional a => [a] -ritusen = [0,2,5,7,9] +ritusen = [0, 2, 5, 7, 9] -- | Another mode of major pentatonic egyptian :: Fractional a => [a] -egyptian = [0,2,5,7,10] +egyptian = [0, 2, 5, 7, 10] -- *** Other scales kumai :: Fractional a => [a] -kumai = [0,2,3,7,9] +kumai = [0, 2, 3, 7, 9] + hirajoshi :: Fractional a => [a] -hirajoshi = [0,2,3,7,8] +hirajoshi = [0, 2, 3, 7, 8] + iwato :: Fractional a => [a] -iwato = [0,1,5,6,10] +iwato = [0, 1, 5, 6, 10] + chinese :: Fractional a => [a] -chinese = [0,4,6,7,11] +chinese = [0, 4, 6, 7, 11] + indian :: Fractional a => [a] -indian = [0,4,5,7,10] +indian = [0, 4, 5, 7, 10] + pelog :: Fractional a => [a] -pelog = [0,1,3,7,8] +pelog = [0, 1, 3, 7, 8] -- *** More scales prometheus :: Fractional a => [a] -prometheus = [0,2,4,6,11] +prometheus = [0, 2, 4, 6, 11] + scriabin :: Fractional a => [a] -scriabin = [0,1,4,7,9] +scriabin = [0, 1, 4, 7, 9] -- *** Han Chinese pentatonic scales + gong :: Fractional a => [a] -gong = [0,2,4,7,9] +gong = [0, 2, 4, 7, 9] + shang :: Fractional a => [a] -shang = [0,2,5,7,10] +shang = [0, 2, 5, 7, 10] + jiao :: Fractional a => [a] -jiao = [0,3,5,8,10] +jiao = [0, 3, 5, 8, 10] + zhi :: Fractional a => [a] -zhi = [0,2,5,7,9] +zhi = [0, 2, 5, 7, 9] + yu :: Fractional a => [a] -yu = [0,3,5,7,10] +yu = [0, 3, 5, 7, 10] -- ** 6 note scales + whole' :: Fractional a => [a] -whole' = [0,2,4,6,8,10] +whole' = [0, 2, 4, 6, 8, 10] + augmented :: Fractional a => [a] -augmented = [0,3,4,7,8,11] +augmented = [0, 3, 4, 7, 8, 11] + augmented2 :: Fractional a => [a] -augmented2 = [0,1,4,5,8,9] +augmented2 = [0, 1, 4, 5, 8, 9] -- *** Hexatonic modes with no tritone + hexMajor7 :: Fractional a => [a] -hexMajor7 = [0,2,4,7,9,11] +hexMajor7 = [0, 2, 4, 7, 9, 11] + hexDorian :: Fractional a => [a] -hexDorian = [0,2,3,5,7,10] +hexDorian = [0, 2, 3, 5, 7, 10] + hexPhrygian :: Fractional a => [a] -hexPhrygian = [0,1,3,5,8,10] +hexPhrygian = [0, 1, 3, 5, 8, 10] + hexSus :: Fractional a => [a] -hexSus = [0,2,5,7,9,10] +hexSus = [0, 2, 5, 7, 9, 10] + hexMajor6 :: Fractional a => [a] -hexMajor6 = [0,2,4,5,7,9] +hexMajor6 = [0, 2, 4, 5, 7, 9] + hexAeolian :: Fractional a => [a] -hexAeolian = [0,3,5,7,8,10] +hexAeolian = [0, 3, 5, 7, 8, 10] -- ** 7 note scales + major :: Fractional a => [a] -major = [0,2,4,5,7,9,11] +major = [0, 2, 4, 5, 7, 9, 11] + ionian :: Fractional a => [a] -ionian = [0,2,4,5,7,9,11] +ionian = [0, 2, 4, 5, 7, 9, 11] + dorian :: Fractional a => [a] -dorian = [0,2,3,5,7,9,10] +dorian = [0, 2, 3, 5, 7, 9, 10] + phrygian :: Fractional a => [a] -phrygian = [0,1,3,5,7,8,10] +phrygian = [0, 1, 3, 5, 7, 8, 10] + lydian :: Fractional a => [a] -lydian = [0,2,4,6,7,9,11] +lydian = [0, 2, 4, 6, 7, 9, 11] + mixolydian :: Fractional a => [a] -mixolydian = [0,2,4,5,7,9,10] +mixolydian = [0, 2, 4, 5, 7, 9, 10] + aeolian :: Fractional a => [a] -aeolian = [0,2,3,5,7,8,10] +aeolian = [0, 2, 3, 5, 7, 8, 10] + minor :: Fractional a => [a] -minor = [0,2,3,5,7,8,10] +minor = [0, 2, 3, 5, 7, 8, 10] + locrian :: Fractional a => [a] -locrian = [0,1,3,5,6,8,10] +locrian = [0, 1, 3, 5, 6, 8, 10] + harmonicMinor :: Fractional a => [a] -harmonicMinor = [0,2,3,5,7,8,11] +harmonicMinor = [0, 2, 3, 5, 7, 8, 11] + harmonicMajor :: Fractional a => [a] -harmonicMajor = [0,2,4,5,7,8,11] +harmonicMajor = [0, 2, 4, 5, 7, 8, 11] + melodicMinor :: Fractional a => [a] -melodicMinor = [0,2,3,5,7,9,11] +melodicMinor = [0, 2, 3, 5, 7, 9, 11] + melodicMinorDesc :: Fractional a => [a] -melodicMinorDesc = [0,2,3,5,7,8,10] +melodicMinorDesc = [0, 2, 3, 5, 7, 8, 10] + melodicMajor :: Fractional a => [a] -melodicMajor = [0,2,4,5,7,8,10] +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] +todi = [0, 1, 3, 6, 7, 8, 11] + purvi :: Fractional a => [a] -purvi = [0,1,4,6,7,8,11] +purvi = [0, 1, 4, 6, 7, 8, 11] + marva :: Fractional a => [a] -marva = [0,1,4,6,7,9,11] +marva = [0, 1, 4, 6, 7, 9, 11] + bhairav :: Fractional a => [a] -bhairav = [0,1,4,5,7,8,11] +bhairav = [0, 1, 4, 5, 7, 8, 11] + ahirbhairav :: Fractional a => [a] -ahirbhairav = [0,1,4,5,7,9,10] +ahirbhairav = [0, 1, 4, 5, 7, 9, 10] -- *** More modes + superLocrian :: Fractional a => [a] -superLocrian = [0,1,3,4,6,8,10] +superLocrian = [0, 1, 3, 4, 6, 8, 10] + romanianMinor :: Fractional a => [a] -romanianMinor = [0,2,3,6,7,9,10] +romanianMinor = [0, 2, 3, 6, 7, 9, 10] + hungarianMinor :: Fractional a => [a] -hungarianMinor = [0,2,3,6,7,8,11] +hungarianMinor = [0, 2, 3, 6, 7, 8, 11] + neapolitanMinor :: Fractional a => [a] -neapolitanMinor = [0,1,3,5,7,8,11] +neapolitanMinor = [0, 1, 3, 5, 7, 8, 11] + enigmatic :: Fractional a => [a] -enigmatic = [0,1,4,6,8,10,11] +enigmatic = [0, 1, 4, 6, 8, 10, 11] + spanish :: Fractional a => [a] -spanish = [0,1,4,5,7,8,10] +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] +leadingWhole = [0, 2, 4, 6, 8, 10, 11] + lydianMinor :: Fractional a => [a] -lydianMinor = [0,2,4,6,7,8,10] +lydianMinor = [0, 2, 4, 6, 7, 8, 10] + neapolitanMajor :: Fractional a => [a] -neapolitanMajor = [0,1,3,5,7,9,11] +neapolitanMajor = [0, 1, 3, 5, 7, 9, 11] + locrianMajor :: Fractional a => [a] -locrianMajor = [0,2,4,5,6,8,10] +locrianMajor = [0, 2, 4, 5, 6, 8, 10] -- ** 8 note scales + diminished :: Fractional a => [a] -diminished = [0,1,3,4,6,7,9,10] +diminished = [0, 1, 3, 4, 6, 7, 9, 10] + diminished2 :: Fractional a => [a] -diminished2 = [0,2,3,5,6,8,9,11] +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] - -{-| - Interprets a pattern of note numbers into a particular named scale. For example: - - > d1 - > $ jux rev - > $ chunk 4 (fast 2 . (|- n 12)) - > $ off 0.25 (|+ 7) - > $ struct (iter 4 "t(5,8)") - > $ n (scale "ritusen" "0 .. 7") - > # sound "superpiano" --} +chromatic = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11] + +-- | +-- Interprets a pattern of note numbers into a particular named scale. For example: +-- +-- > d1 +-- > $ jux rev +-- > $ chunk 4 (fast 2 . (|- n 12)) +-- > $ off 0.25 (|+ 7) +-- > $ struct (iter 4 "t(5,8)") +-- > $ n (scale "ritusen" "0 .. 7") +-- > # sound "superpiano" scale :: Fractional a => Pattern String -> Pattern Int -> Pattern a scale = getScale scaleTable -{-| - Build a scale function, with additional scales if you wish. For example: - - > let myscale = - > getScale - > ( scaleTable ++ - > [ ("techno", [0,2,3,5,7,8,10]) - > , ("broken", [0,1,4,7,8,10]) - > ] - > ) - - The above takes the standard 'scaleTable' as a starting point and adds two custom scales to it. You’ll be able to use the new function in place of the normal one: - - > d1 $ n (myscale "techno" "0 1 2 3 4 5 6 7") # sound "superpiano" --} +-- | +-- Build a scale function, with additional scales if you wish. For example: +-- +-- > let myscale = +-- > getScale +-- > ( scaleTable ++ +-- > [ ("techno", [0,2,3,5,7,8,10]) +-- > , ("broken", [0,1,4,7,8,10]) +-- > ] +-- > ) +-- +-- The above takes the standard 'scaleTable' as a starting point and adds two custom scales to it. You’ll be able to use the new function in place of the normal one: +-- +-- > d1 $ n (myscale "techno" "0 1 2 3 4 5 6 7") # sound "superpiano" getScale :: Fractional a => [(String, [a])] -> Pattern String -> Pattern Int -> Pattern 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) +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) {- Variant of @scale@ allowing to modify the current scale (seen as a list) with an [a] -> [a] function. @@ -260,165 +332,168 @@ scaleWithList sp fs p = slowcat $ map (\f -> scaleWith sp f p) fs {- Variant of @getScale@ used to build the @scaleWith@ function -} getScaleMod :: (Eq a, Fractional a) => [(String, [a])] -> Pattern String -> ([a] -> [a]) -> Pattern Int -> Pattern a -getScaleMod table sp f p = (\n scaleName - -> noteInScale (uniq $ f $ 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) +getScaleMod table sp f p = + ( \n scaleName -> + noteInScale (uniq $ f $ 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) {- Eliminates duplicates in a sorted list -} uniq :: (Eq a) => [a] -> [a] -uniq (h1:h2:tl) = if (h1 == h2) then h1:(uniq tl) else h1:(uniq (h2:tl)) +uniq (h1 : h2 : tl) = if (h1 == h2) then h1 : (uniq tl) else h1 : (uniq (h2 : tl)) uniq l = l {- Raises a specified degree of a scale, provided as a numbers list. Meant to be passed as an argument to @scaleWith@ -} raiseDegree :: Fractional a => Int -> [a] -> [a] -raiseDegree n (hd:[]) = (hd+1):[] -raiseDegree 0 (hd:tl) = (hd+1):tl -raiseDegree n (hd:tl) = hd:(raiseDegree (n-1) tl) +raiseDegree n (hd : []) = (hd + 1) : [] +raiseDegree 0 (hd : tl) = (hd + 1) : tl +raiseDegree n (hd : tl) = hd : (raiseDegree (n - 1) tl) raiseDegree _ [] = error "Degree is not present in the scale" {- Lowers a specified degree of a scale, provided as a numbers list. Meant to be passed as an argument to @scaleWith@ -} lowerDegree :: Fractional a => Int -> [a] -> [a] -lowerDegree n (hd:[]) = (hd-1):[] -lowerDegree 0 (hd:tl) = (hd-1):tl -lowerDegree n (hd:tl) = hd:(lowerDegree (n-1) tl) +lowerDegree n (hd : []) = (hd - 1) : [] +lowerDegree 0 (hd : tl) = (hd - 1) : tl +lowerDegree n (hd : tl) = hd : (lowerDegree (n - 1) tl) lowerDegree _ [] = error "Degree is not present in the scale" {- Like @raiseDegree@, but raises a range of degrees instead of a single one -} raiseDegrees :: Fractional a => Int -> Int -> [a] -> [a] -raiseDegrees n m (hd:[]) = (hd+1):[] -raiseDegrees 0 0 (hd:tl) = (hd+1):tl -raiseDegrees 0 m (hd:tl) = (hd+1):(raiseDegrees 0 (m-1) tl) -raiseDegrees n m (hd:tl) = hd:(raiseDegrees (n-1) (m-1) tl) +raiseDegrees n m (hd : []) = (hd + 1) : [] +raiseDegrees 0 0 (hd : tl) = (hd + 1) : tl +raiseDegrees 0 m (hd : tl) = (hd + 1) : (raiseDegrees 0 (m - 1) tl) +raiseDegrees n m (hd : tl) = hd : (raiseDegrees (n - 1) (m - 1) tl) raiseDegrees _ _ [] = error "Degrees are out of the scale" {- Like @lowerDegree@, but lowers a range of degrees instead of a single one -} lowerDegrees :: Fractional a => Int -> Int -> [a] -> [a] -lowerDegrees n m (hd:[]) = (hd-1):[] -lowerDegrees 0 0 (hd:tl) = (hd-1):tl -lowerDegrees 0 m (hd:tl) = (hd-1):(lowerDegrees 0 (m-1) tl) -lowerDegrees n m (hd:tl) = hd:(lowerDegrees (n-1) (m-1) tl) +lowerDegrees n m (hd : []) = (hd - 1) : [] +lowerDegrees 0 0 (hd : tl) = (hd - 1) : tl +lowerDegrees 0 m (hd : tl) = (hd - 1) : (lowerDegrees 0 (m - 1) tl) +lowerDegrees n m (hd : tl) = hd : (lowerDegrees (n - 1) (m - 1) tl) lowerDegrees _ _ [] = error "Degrees are out of the scale" - -{-| - Outputs this list of all the available scales: - -@ -minPent majPent ritusen egyptian kumai hirajoshi iwato chinese indian pelog -prometheus scriabin gong shang jiao zhi yu whole wholetone augmented augmented2 -hexMajor7 hexDorian hexPhrygian hexSus hexMajor6 hexAeolian major ionian dorian -phrygian lydian mixolydian aeolian minor locrian harmonicMinor harmonicMajor -melodicMinor melodicMinorDesc melodicMajor bartok hindu todi purvi marva bhairav -ahirbhairav superLocrian romanianMinor hungarianMinor neapolitanMinor enigmatic -spanish leadingWhole lydianMinor neapolitanMajor locrianMajor diminished -octatonic diminished2 octatonic2 messiaen1 messiaen2 messiaen3 messiaen4 -messiaen5 messiaen6 messiaen7 chromatic bayati hijaz sikah rast saba iraq -@ --} +-- | +-- Outputs this list of all the available scales: +-- +-- @ +-- minPent majPent ritusen egyptian kumai hirajoshi iwato chinese indian pelog +-- prometheus scriabin gong shang jiao zhi yu whole wholetone augmented augmented2 +-- hexMajor7 hexDorian hexPhrygian hexSus hexMajor6 hexAeolian major ionian dorian +-- phrygian lydian mixolydian aeolian minor locrian harmonicMinor harmonicMajor +-- melodicMinor melodicMinorDesc melodicMajor bartok hindu todi purvi marva bhairav +-- ahirbhairav superLocrian romanianMinor hungarianMinor neapolitanMinor enigmatic +-- spanish leadingWhole lydianMinor neapolitanMajor locrianMajor diminished +-- octatonic diminished2 octatonic2 messiaen1 messiaen2 messiaen3 messiaen4 +-- messiaen5 messiaen6 messiaen7 chromatic bayati hijaz sikah rast saba iraq +-- @ scaleList :: String scaleList = unwords $ map fst (scaleTable :: [(String, [Rational])]) -{-| - Outputs a list of all available scales and their corresponding notes. For - example, its first entry is @("minPent",[0,3,5,7,10]@) which means that - a minor pentatonic scale is formed by the root (0), the minor third (3 semitones - above the root), the perfect fourth (5 semitones above the root), etc. - - As the list is big, you can use the Haskell function lookup to look up a - specific scale: @lookup "phrygian" scaleTable@. This will output - @Just [0.0,1.0,3.0,5.0,7.0,8.0,10.0]@. - - You can also do a reverse lookup into the scale table. For example: - - > filter ( \(_, x) -> take 3 x == [0,2,4] ) scaleTable - - The above example will output all scales of which the first three notes are - the root, the major second (2 semitones above the fundamental), and the major - third (4 semitones above the root). --} +-- | +-- Outputs a list of all available scales and their corresponding notes. For +-- example, its first entry is @("minPent",[0,3,5,7,10]@) which means that +-- a minor pentatonic scale is formed by the root (0), the minor third (3 semitones +-- above the root), the perfect fourth (5 semitones above the root), etc. +-- +-- As the list is big, you can use the Haskell function lookup to look up a +-- specific scale: @lookup "phrygian" scaleTable@. This will output +-- @Just [0.0,1.0,3.0,5.0,7.0,8.0,10.0]@. +-- +-- You can also do a reverse lookup into the scale table. For example: +-- +-- > filter ( \(_, x) -> take 3 x == [0,2,4] ) scaleTable +-- +-- The above example will output all scales of which the first three notes are +-- the root, the major second (2 semitones above the fundamental), and the major +-- third (4 semitones above the root). 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) - ] +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/src/Sound/Tidal/Show.hs b/src/Sound/Tidal/Show.hs index 0ad3024e..cb5b417e 100644 --- a/src/Sound/Tidal/Show.hs +++ b/src/Sound/Tidal/Show.hs @@ -1,10 +1,9 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Sound.Tidal.Show (show, showAll, draw, drawLine, drawLineSz, stepcount, showStateful) where - {- Show.hs - Library for visualising Tidal patterns as text Copyright (C) 2020, Alex McLean and contributors @@ -23,49 +22,53 @@ module Sound.Tidal.Show (show, showAll, draw, drawLine, drawLineSz, stepcount, s along with this library. If not, see . -} -import Sound.Tidal.Pattern - -import Data.List (intercalate, sortOn) -import Data.Maybe (fromMaybe, isJust) -import Data.Ratio (denominator, numerator) - -import qualified Data.Map.Strict as Map +import Data.List (intercalate, sortOn) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, isJust) +import Data.Ratio (denominator, numerator) +import Sound.Tidal.Pattern instance (Show a) => Show (Pattern a) where show = showPattern (Arc 0 1) showStateful :: ControlPattern -> String showStateful p = intercalate "\n" evStrings - where (_, evs) = resolveState (Map.empty) $ sortOn part $ queryArc (filterOnsets p) (Arc 0 1) - evs' = map showEvent evs - maxPartLength :: Int - maxPartLength = maximum $ map (length . fst) evs' - evString :: (String, String) -> String - evString ev = ((replicate (maxPartLength - (length (fst ev))) ' ') - ++ fst ev - ++ snd ev - ) - evStrings = map evString evs' + where + (_, evs) = resolveState (Map.empty) $ sortOn part $ queryArc (filterOnsets p) (Arc 0 1) + evs' = map showEvent evs + maxPartLength :: Int + maxPartLength = maximum $ map (length . fst) evs' + evString :: (String, String) -> String + evString ev = + ( (replicate (maxPartLength - (length (fst ev))) ' ') + ++ fst ev + ++ snd ev + ) + 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 - maxPartLength = maximum $ map (length . fst) evs - evString :: (String, String) -> String - evString ev = replicate (maxPartLength - length (fst ev)) ' ' - ++ uncurry (++) ev - evStrings = map evString evs + where + evs = map showEvent $ sortOn part $ queryArc p a + maxPartLength :: Int + maxPartLength = maximum $ map (length . fst) evs + evString :: (String, String) -> String + evString ev = + replicate (maxPartLength - length (fst ev)) ' ' + ++ uncurry (++) ev + evStrings = map evString evs showEvent :: Show a => Event a -> (String, String) showEvent (Event _ (Just (Arc ws we)) a@(Arc ps pe) e) = (h ++ "(" ++ show a ++ ")" ++ t ++ "|", show e) - where h | ws == ps = "" - | otherwise = prettyRat ws ++ "-" - t | we == pe = "" - | otherwise = "-" ++ prettyRat we - + where + h + | ws == ps = "" + | otherwise = prettyRat ws ++ "-" + t + | we == pe = "" + | otherwise = "-" ++ prettyRat we showEvent (Event _ Nothing a e) = ("~" ++ show a ++ "~|", show e) @@ -81,16 +84,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 @@ -102,10 +105,12 @@ instance {-# OVERLAPPING #-} Show a => Show (Event a) where show e = uncurry (++) (showEvent e) prettyRat :: Rational -> String -prettyRat r | unit == 0 && frac > 0 = showFrac (numerator frac) (denominator frac) - | otherwise = show unit ++ showFrac (numerator frac) (denominator frac) - where unit = floor r :: Int - frac = r - toRational unit +prettyRat r + | unit == 0 && frac > 0 = showFrac (numerator frac) (denominator frac) + | otherwise = show unit ++ showFrac (numerator frac) (denominator frac) + where + unit = floor r :: Int + frac = r - toRational unit showFrac :: Integer -> Integer -> String showFrac 0 _ = "" @@ -127,44 +132,46 @@ showFrac 5 8 = "⅝" showFrac 7 8 = "⅞" showFrac 1 9 = "⅑" showFrac 1 10 = "⅒" - -showFrac n d = fromMaybe plain $ do n' <- up n - d' <- down d - return $ n' ++ d' - where plain = show n ++ "/" ++ show d - up 1 = Just "¹" - up 2 = Just "²" - up 3 = Just "³" - up 4 = Just "⁴" - up 5 = Just "⁵" - up 6 = Just "⁶" - up 7 = Just "⁷" - up 8 = Just "⁸" - up 9 = Just "⁹" - up 0 = Just "⁰" - up _ = Nothing - down 1 = Just "₁" - down 2 = Just "₂" - down 3 = Just "₃" - down 4 = Just "₄" - down 5 = Just "₅" - down 6 = Just "₆" - down 7 = Just "₇" - down 8 = Just "₈" - down 9 = Just "₉" - down 0 = Just "₀" - down _ = Nothing +showFrac n d = fromMaybe plain $ do + n' <- up n + d' <- down d + return $ n' ++ d' + where + plain = show n ++ "/" ++ show d + up 1 = Just "¹" + up 2 = Just "²" + up 3 = Just "³" + up 4 = Just "⁴" + up 5 = Just "⁵" + up 6 = Just "⁶" + up 7 = Just "⁷" + up 8 = Just "⁸" + up 9 = Just "⁹" + up 0 = Just "⁰" + up _ = Nothing + down 1 = Just "₁" + down 2 = Just "₂" + down 3 = Just "₃" + down 4 = Just "₄" + down 5 = Just "₅" + down 6 = Just "₆" + down 7 = Just "₇" + down 8 = Just "₈" + down 9 = Just "₉" + down 0 = Just "₀" + down _ = Nothing stepcount :: Pattern a -> Int stepcount pat = fromIntegral $ eventSteps $ concatMap ((\ev -> [start ev, stop ev]) . part) (filter eventHasOnset $ queryArc pat (Arc 0 1)) - where eventSteps xs = foldr (lcm . denominator) 1 xs + where + eventSteps xs = foldr (lcm . denominator) 1 xs data Render = Render Int Int String instance Show Render where - show (Render cyc i render) | i <= 1024 = "\n[" ++ show cyc ++ (if cyc == 1 then " cycle" else " cycles") ++ "]\n" ++ render - | otherwise = "That pattern is too complex to draw." - + show (Render cyc i render) + | i <= 1024 = "\n[" ++ show cyc ++ (if cyc == 1 then " cycle" else " cycles") ++ "]\n" ++ render + | otherwise = "That pattern is too complex to draw." drawLine :: Pattern Char -> Render drawLine = drawLineSz 78 @@ -173,36 +180,41 @@ drawLineSz :: Int -> Pattern Char -> Render drawLineSz sz pat = joinCycles sz $ drawCycles pat where drawCycles :: Pattern Char -> [Render] - drawCycles pat' = draw pat':drawCycles (rotL 1 pat') + drawCycles pat' = draw pat' : drawCycles (rotL 1 pat') joinCycles :: Int -> [Render] -> Render joinCycles _ [] = Render 0 0 "" - joinCycles n ((Render cyc l s):cs) | l > n = Render 0 0 "" - | otherwise = Render (cyc+cyc') (l + l' + 1) $ intercalate "\n" $ map (uncurry (++)) lineZip + joinCycles n ((Render cyc l s) : cs) + | l > n = Render 0 0 "" + | otherwise = Render (cyc + cyc') (l + l' + 1) $ intercalate "\n" $ map (uncurry (++)) lineZip where - (Render cyc' l' s') = joinCycles (n-l-1) cs + (Render cyc' l' s') = joinCycles (n - l - 1) cs linesN = max (length $ lines s) (length $ lines s') - lineZip = take linesN $ - zip (lines s ++ repeat (replicate l ' ')) + lineZip = + take linesN $ + zip + (lines s ++ repeat (replicate l ' ')) (lines s' ++ repeat (replicate l' ' ')) - -- where maximum (map (length . head . (++ [""]) . lines) cs) - +-- where maximum (map (length . head . (++ [""]) . lines) cs) draw :: Pattern Char -> Render -draw pat = Render 1 s (intercalate "\n" $ map (('|' :) .drawLevel) ls) - where ls = levels pat - s = stepcount pat - rs = toRational s - drawLevel :: [Event Char] -> String - drawLevel [] = replicate s '.' - drawLevel (e:es) = map f $ take s $ zip (drawLevel es ++ repeat '.') (drawEvent e ++ repeat '.') - f ('.', x) = x - f (x, _) = x - drawEvent :: Event Char -> String - drawEvent ev = replicate (floor $ rs * evStart) '.' - ++ (value ev:replicate (floor (rs * (evStop - evStart)) - 1) '-') - where evStart = start $ wholeOrPart ev - evStop = stop $ wholeOrPart ev +draw pat = Render 1 s (intercalate "\n" $ map (('|' :) . drawLevel) ls) + where + ls = levels pat + s = stepcount pat + rs = toRational s + drawLevel :: [Event Char] -> String + drawLevel [] = replicate s '.' + drawLevel (e : es) = map f $ take s $ zip (drawLevel es ++ repeat '.') (drawEvent e ++ repeat '.') + f ('.', x) = x + f (x, _) = x + drawEvent :: Event Char -> String + drawEvent ev = + replicate (floor $ rs * evStart) '.' + ++ (value ev : replicate (floor (rs * (evStop - evStart)) - 1) '-') + where + evStart = start $ wholeOrPart ev + evStop = stop $ wholeOrPart ev {- fitsWhole :: Event b -> [Event b] -> Bool @@ -227,13 +239,13 @@ sortOn' f = map snd . sortOn fst . map (\x -> let y = f x in y `seq` (y, x)) -} fits :: Event b -> [Event b] -> Bool -fits (Event _ _ part' _) events = not $ any (\Event{..} -> isJust $ subArc part' part) events +fits (Event _ _ part' _) events = not $ any (\Event {..} -> isJust $ subArc part' part) events addEvent :: Event b -> [[Event b]] -> [[Event b]] addEvent e [] = [[e]] -addEvent e (level:ls) - | fits e level = (e:level) : ls - | otherwise = level : addEvent e ls +addEvent e (level : ls) + | fits e level = (e : level) : ls + | otherwise = level : addEvent e ls arrangeEvents :: [Event b] -> [[Event b]] arrangeEvents = foldr addEvent [] diff --git a/src/Sound/Tidal/Simple.hs b/src/Sound/Tidal/Simple.hs index 2bc622be..48d6b8c1 100644 --- a/src/Sound/Tidal/Simple.hs +++ b/src/Sound/Tidal/Simple.hs @@ -21,12 +21,12 @@ module Sound.Tidal.Simple where +import GHC.Exts (IsString (..)) import Sound.Tidal.Control (chop, hurry) -import Sound.Tidal.Core ((#), (|*), (<~)) -import Sound.Tidal.Params (crush, gain, pan, speed, s) +import Sound.Tidal.Core ((#), (<~), (|*)) +import Sound.Tidal.Params (crush, gain, pan, s, speed) import Sound.Tidal.ParseBP (parseBP_E) -import Sound.Tidal.Pattern (ControlPattern, silence, rev) -import GHC.Exts ( IsString(..) ) +import Sound.Tidal.Pattern (ControlPattern, rev, silence) instance {-# OVERLAPPING #-} IsString ControlPattern where fromString = s . parseBP_E diff --git a/src/Sound/Tidal/Stepwise.hs b/src/Sound/Tidal/Stepwise.hs index e52bd683..370c55c7 100644 --- a/src/Sound/Tidal/Stepwise.hs +++ b/src/Sound/Tidal/Stepwise.hs @@ -16,16 +16,14 @@ along with this library. If not, see . -} - module Sound.Tidal.Stepwise where -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, nubOrd, pairs) +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, nubOrd, pairs) _lcmtactus :: [Pattern a] -> Maybe Time _lcmtactus pats = foldl1 lcmr <$> (sequence $ map tactus pats) @@ -39,17 +37,18 @@ _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 + | r < 0 = zoom (1 - ((abs r) / t), 1) pat + | otherwise = zoom (0, (r / t)) pat s_add :: Pattern Rational -> Pattern a -> Pattern a s_add = s_patternify _s_add _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 +_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 s_sub :: Pattern Rational -> Pattern a -> Pattern a s_sub = s_patternify _s_sub @@ -57,14 +56,15 @@ 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 -- TODO raise exception? -s_while _ _ 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 | 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 + | 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_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 @@ -92,20 +92,20 @@ s_everycycle = s_nthcycle' s_taperlist :: Pattern a -> [Pattern a] s_taperlist pat@(Pattern _ (Just t) _) = pat : map (\r -> _s_sub r pat) [1 .. t] -- TODO exception? -s_taperlist pat = [pat] - +s_taperlist pat = [pat] s_taperlistBy :: Int -> Int -> Pattern a -> [Pattern a] -s_taperlistBy amount times pat@(Pattern _ (Just t) _) +s_taperlistBy amount times pat@(Pattern _ (Just t) _) | times == 1 = [pat] | times <= 0 = [] | amount == 0 = [pat] | backwards = reverse l | otherwise = l - where backwards = amount > 0 - n = toRational $ abs amount - start = t - (toRational $ max 0 $ n * (toRational $ times - 1)) - l = (map (\i -> zoom (0, (start + (n * (toRational i))) / t) pat) [0 .. times-2]) ++ [pat] + where + backwards = amount > 0 + n = toRational $ abs amount + start = t - (toRational $ max 0 $ n * (toRational $ times - 1)) + l = (map (\i -> zoom (0, (start + (n * (toRational i))) / t) pat) [0 .. times - 2]) ++ [pat] -- | Plays one fewer step from the pattern each repetition, down to nothing s_taper :: Pattern a -> Pattern a @@ -122,7 +122,8 @@ s_taperBy = s_patternify2 _s_taperBy -- | Successively plays a pattern from each group in turn 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 + where + c = foldl1 lcm $ map length groups _s_expand :: Rational -> Pattern a -> Pattern a _s_expand factor pat = withTactus (* factor) pat @@ -138,30 +139,33 @@ 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 = stepJoin $ (`f` p) <$> pa +s_patternify f pa p = stepJoin $ (`f` p) <$> pa s_patternify2 :: (a -> b -> c -> Pattern d) -> Pattern a -> Pattern b -> c -> Pattern d s_patternify2 f a b p = stepJoin $ (\x y -> f x y p) <$> a <*> b stepJoin :: Pattern (Pattern a) -> Pattern a 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 - 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 (\x -> withContext (\c -> combineContexts [c, context x]) $ value x) $ 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} + 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 + 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 (\x -> withContext (\c -> combineContexts [c, context x]) $ value x) $ 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/Stream.hs b/src/Sound/Tidal/Stream.hs index 973cf09f..dc5b245e 100644 --- a/src/Sound/Tidal/Stream.hs +++ b/src/Sound/Tidal/Stream.hs @@ -1,20 +1,21 @@ module Sound.Tidal.Stream - (module Sound.Tidal.Stream.Config - ,module Sound.Tidal.Stream.Types - ,module Sound.Tidal.Stream.Process - ,module Sound.Tidal.Stream.Target - ,module Sound.Tidal.Stream.UI - ,module Sound.Tidal.Stream.Listen - ,module Sound.Tidal.Stream.Main - ) where + ( module Sound.Tidal.Stream.Config, + module Sound.Tidal.Stream.Types, + module Sound.Tidal.Stream.Process, + module Sound.Tidal.Stream.Target, + module Sound.Tidal.Stream.UI, + module Sound.Tidal.Stream.Listen, + module Sound.Tidal.Stream.Main, + ) +where -import Sound.Tidal.Stream.Config -import Sound.Tidal.Stream.Listen -import Sound.Tidal.Stream.Main -import Sound.Tidal.Stream.Process -import Sound.Tidal.Stream.Target -import Sound.Tidal.Stream.Types -import Sound.Tidal.Stream.UI +import Sound.Tidal.Stream.Config +import Sound.Tidal.Stream.Listen +import Sound.Tidal.Stream.Main +import Sound.Tidal.Stream.Process +import Sound.Tidal.Stream.Target +import Sound.Tidal.Stream.Types +import Sound.Tidal.Stream.UI {- Stream.hs - re-exports of all stream modules diff --git a/src/Sound/Tidal/Stream/Config.hs b/src/Sound/Tidal/Stream/Config.hs index 295c41c4..15e7d9f8 100644 --- a/src/Sound/Tidal/Stream/Config.hs +++ b/src/Sound/Tidal/Stream/Config.hs @@ -20,25 +20,28 @@ import qualified Sound.Tidal.Clock as Clock along with this library. If not, see . -} -data Config = Config {cCtrlListen :: Bool, - cCtrlAddr :: String, - cCtrlPort :: Int, - cCtrlBroadcast :: Bool, - -- cTempoAddr :: String, - -- cTempoPort :: Int, - -- cTempoClientPort :: Int, - cVerbose :: Bool, - cClockConfig :: Clock.ClockConfig - } +data Config = Config + { cCtrlListen :: Bool, + cCtrlAddr :: String, + cCtrlPort :: Int, + cCtrlBroadcast :: Bool, + -- cTempoAddr :: String, + -- cTempoPort :: Int, + -- cTempoClientPort :: Int, + cVerbose :: Bool, + cClockConfig :: Clock.ClockConfig + } defaultConfig :: Config -defaultConfig = Config {cCtrlListen = True, - cCtrlAddr ="127.0.0.1", - cCtrlPort = 6010, - cCtrlBroadcast = False, - -- cTempoAddr = "127.0.0.1", - -- cTempoPort = 9160, - -- cTempoClientPort = 0, -- choose at random - cVerbose = True, - cClockConfig = Clock.defaultConfig - } +defaultConfig = + Config + { cCtrlListen = True, + cCtrlAddr = "127.0.0.1", + cCtrlPort = 6010, + cCtrlBroadcast = False, + -- cTempoAddr = "127.0.0.1", + -- cTempoPort = 9160, + -- cTempoClientPort = 0, -- choose at random + cVerbose = True, + cClockConfig = Clock.defaultConfig + } diff --git a/src/Sound/Tidal/Stream/Listen.hs b/src/Sound/Tidal/Stream/Listen.hs index 832b9ab8..76d25bb6 100644 --- a/src/Sound/Tidal/Stream/Listen.hs +++ b/src/Sound/Tidal/Stream/Listen.hs @@ -1,22 +1,20 @@ module Sound.Tidal.Stream.Listen where -import Data.Maybe (fromJust, catMaybes, isJust) -import Control.Concurrent.MVar -import Control.Monad (when) -import System.IO (hPutStrLn, stderr) +import Control.Concurrent.MVar +import qualified Control.Exception as E +import Control.Monad (when) import qualified Data.Map as Map +import Data.Maybe (catMaybes, fromJust, isJust) +import qualified Network.Socket as N import qualified Sound.Osc.Fd as O import qualified Sound.Osc.Time.Timeout as O import qualified Sound.Osc.Transport.Fd.Udp as O -import qualified Network.Socket as N -import qualified Control.Exception as E - -import Sound.Tidal.ID -import Sound.Tidal.Pattern - -import Sound.Tidal.Stream.Config -import Sound.Tidal.Stream.Types -import Sound.Tidal.Stream.UI +import Sound.Tidal.ID +import Sound.Tidal.Pattern +import Sound.Tidal.Stream.Config +import Sound.Tidal.Stream.Types +import Sound.Tidal.Stream.UI +import System.IO (hPutStrLn, stderr) {- Listen.hs - logic for listening and acting on incoming OSC messages @@ -36,92 +34,104 @@ import Sound.Tidal.Stream.UI along with this library. If not, see . -} - openListener :: Config -> IO (Maybe O.Udp) openListener c - | cCtrlListen c = catchAny run (\_ -> do verbose c "That port isn't available, perhaps another Tidal instance is already listening on that port?" - return Nothing - ) - | otherwise = return Nothing + | cCtrlListen c = + catchAny + run + ( \_ -> do + verbose c "That port isn't available, perhaps another Tidal instance is already listening on that port?" + return Nothing + ) + | otherwise = return Nothing where - run = do sock <- O.udpServer (cCtrlAddr c) (cCtrlPort c) - when (cCtrlBroadcast c) $ N.setSocketOption (O.udpSocket sock) N.Broadcast 1 - return $ Just sock - catchAny :: IO a -> (E.SomeException -> IO a) -> IO a - catchAny = E.catch + run = do + sock <- O.udpServer (cCtrlAddr c) (cCtrlPort c) + when (cCtrlBroadcast c) $ N.setSocketOption (O.udpSocket sock) N.Broadcast 1 + return $ Just sock + catchAny :: IO a -> (E.SomeException -> IO a) -> IO a + catchAny = E.catch -- Listen to and act on OSC control messages ctrlResponder :: Int -> Config -> Stream -> IO () -ctrlResponder waits c (stream@(Stream {sListen = Just sock})) - = do ms <- recvMessagesTimeout 2 sock - if (null ms) - then do checkHandshake -- there was a timeout, check handshake - ctrlResponder (waits+1) c stream - else do mapM_ act ms - ctrlResponder 0 c stream - where - checkHandshake = do busses <- readMVar (sBusses stream) - when (null busses) $ do when (waits == 0) $ verbose c $ "Waiting for SuperDirt (v.1.7.2 or higher).." - sendHandshakes stream +ctrlResponder waits c (stream@(Stream {sListen = Just sock})) = + do + ms <- recvMessagesTimeout 2 sock + if (null ms) + then do + checkHandshake -- there was a timeout, check handshake + ctrlResponder (waits + 1) c stream + else do + mapM_ act ms + ctrlResponder 0 c stream + where + checkHandshake = do + busses <- readMVar (sBusses stream) + when (null busses) $ do + when (waits == 0) $ verbose c $ "Waiting for SuperDirt (v.1.7.2 or higher).." + sendHandshakes stream - act (O.Message "/dirt/hello" _) = sendHandshakes stream - act (O.Message "/dirt/handshake/reply" xs) = do prev <- swapMVar (sBusses stream) $ bufferIndices xs - -- Only report the first time.. - when (null prev) $ verbose c $ "Connected to SuperDirt." - return () - where - bufferIndices [] = [] - bufferIndices (x:xs') | x == (O.AsciiString $ O.ascii "&controlBusIndices") = catMaybes $ takeWhile isJust $ map O.datum_integral xs' - | otherwise = bufferIndices xs' - -- External controller commands - act (O.Message "/ctrl" (O.Int32 k:v:[])) - = act (O.Message "/ctrl" [O.string $ show k,v]) - act (O.Message "/ctrl" (O.AsciiString k:v@(O.Float _):[])) - = add (O.ascii_to_string k) (VF (fromJust $ O.datum_floating v)) - act (O.Message "/ctrl" (O.AsciiString k:O.AsciiString v:[])) - = add (O.ascii_to_string k) (VS (O.ascii_to_string v)) - act (O.Message "/ctrl" (O.AsciiString k:O.Int32 v:[])) - = add (O.ascii_to_string k) (VI (fromIntegral v)) - -- Stream playback commands - act (O.Message "/mute" (k:[])) - = withID k $ streamMute stream - act (O.Message "/unmute" (k:[])) - = withID k $ streamUnmute stream - act (O.Message "/solo" (k:[])) - = withID k $ streamSolo stream - act (O.Message "/unsolo" (k:[])) - = withID k $ streamUnsolo stream - act (O.Message "/muteAll" []) - = streamMuteAll stream - act (O.Message "/unmuteAll" []) - = streamUnmuteAll stream - act (O.Message "/unsoloAll" []) - = streamUnsoloAll stream - act (O.Message "/hush" []) - = streamHush stream - act (O.Message "/silence" (k:[])) - = withID k $ streamSilence stream - -- Cycle properties commands - act (O.Message "/setcps" [O.Float k]) - = streamSetCPS stream $ toTime k - act (O.Message "/setbpm" [O.Float k]) - = streamSetBPM stream $ toTime k - act (O.Message "/setCycle" [O.Float k]) - = streamSetCycle stream $ toTime k - act (O.Message "/resetCycles" _) - = streamResetCycles stream - -- Nudge all command - act (O.Message "/nudgeAll" [O.Double k]) - = streamNudgeAll stream k - act m = hPutStrLn stderr $ "Unhandled OSC: " ++ show m - add :: String -> Value -> IO () - add k v = do sMap <- takeMVar (sStateMV stream) - putMVar (sStateMV stream) $ Map.insert k v sMap - 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 () + act (O.Message "/dirt/hello" _) = sendHandshakes stream + act (O.Message "/dirt/handshake/reply" xs) = do + prev <- swapMVar (sBusses stream) $ bufferIndices xs + -- Only report the first time.. + when (null prev) $ verbose c $ "Connected to SuperDirt." + return () + where + bufferIndices [] = [] + bufferIndices (x : xs') + | x == (O.AsciiString $ O.ascii "&controlBusIndices") = catMaybes $ takeWhile isJust $ map O.datum_integral xs' + | otherwise = bufferIndices xs' + -- External controller commands + act (O.Message "/ctrl" (O.Int32 k : v : [])) = + act (O.Message "/ctrl" [O.string $ show k, v]) + act (O.Message "/ctrl" (O.AsciiString k : v@(O.Float _) : [])) = + add (O.ascii_to_string k) (VF (fromJust $ O.datum_floating v)) + act (O.Message "/ctrl" (O.AsciiString k : O.AsciiString v : [])) = + add (O.ascii_to_string k) (VS (O.ascii_to_string v)) + act (O.Message "/ctrl" (O.AsciiString k : O.Int32 v : [])) = + add (O.ascii_to_string k) (VI (fromIntegral v)) + -- Stream playback commands + act (O.Message "/mute" (k : [])) = + withID k $ streamMute stream + act (O.Message "/unmute" (k : [])) = + withID k $ streamUnmute stream + act (O.Message "/solo" (k : [])) = + withID k $ streamSolo stream + act (O.Message "/unsolo" (k : [])) = + withID k $ streamUnsolo stream + act (O.Message "/muteAll" []) = + streamMuteAll stream + act (O.Message "/unmuteAll" []) = + streamUnmuteAll stream + act (O.Message "/unsoloAll" []) = + streamUnsoloAll stream + act (O.Message "/hush" []) = + streamHush stream + act (O.Message "/silence" (k : [])) = + withID k $ streamSilence stream + -- Cycle properties commands + act (O.Message "/setcps" [O.Float k]) = + streamSetCPS stream $ toTime k + act (O.Message "/setbpm" [O.Float k]) = + streamSetBPM stream $ toTime k + act (O.Message "/setCycle" [O.Float k]) = + streamSetCycle stream $ toTime k + act (O.Message "/resetCycles" _) = + streamResetCycles stream + -- Nudge all command + act (O.Message "/nudgeAll" [O.Double k]) = + streamNudgeAll stream k + act m = hPutStrLn stderr $ "Unhandled OSC: " ++ show m + add :: String -> Value -> IO () + add k v = do + sMap <- takeMVar (sStateMV stream) + putMVar (sStateMV stream) $ Map.insert k v sMap + 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 () ctrlResponder _ _ _ = return () verbose :: Config -> String -> IO () diff --git a/src/Sound/Tidal/Stream/Main.hs b/src/Sound/Tidal/Stream/Main.hs index e4dd41c0..74c07741 100644 --- a/src/Sound/Tidal/Stream/Main.hs +++ b/src/Sound/Tidal/Stream/Main.hs @@ -1,19 +1,17 @@ module Sound.Tidal.Stream.Main where +import Control.Concurrent +import Control.Concurrent.MVar import qualified Data.Map as Map import qualified Sound.Tidal.Clock as Clock -import Control.Concurrent.MVar -import Control.Concurrent -import System.IO (hPutStrLn, stderr) - - -import Sound.Tidal.Version (tidal_status_string) -import Sound.Tidal.Stream.Config -import Sound.Tidal.Stream.Types -import Sound.Tidal.Stream.Listen -import Sound.Tidal.Stream.Target -import Sound.Tidal.Stream.Process -import Sound.Tidal.Stream.UI +import Sound.Tidal.Stream.Config +import Sound.Tidal.Stream.Listen +import Sound.Tidal.Stream.Process +import Sound.Tidal.Stream.Target +import Sound.Tidal.Stream.Types +import Sound.Tidal.Stream.UI +import Sound.Tidal.Version (tidal_status_string) +import System.IO (hPutStrLn, stderr) {- Main.hs - Start tidals stream, listen and act on incoming messages @@ -33,7 +31,6 @@ import Sound.Tidal.Stream.UI along with this library. If not, see . -} - -- Start an instance of Tidal with superdirt OSC startTidal :: Target -> Config -> IO Stream startTidal target config = startStream config [(target, [superdirtShape])] @@ -43,36 +40,38 @@ startTidal target config = startStream config [(target, [superdirtShape])] -- Spawns a thread that listens to and acts on OSC control messages startStream :: Config -> [(Target, [OSC])] -> IO Stream startStream config oscmap = do - sMapMV <- newMVar Map.empty - pMapMV <- newMVar Map.empty - bussesMV <- newMVar [] - globalFMV <- newMVar id - - tidal_status_string >>= verbose config - verbose config $ "Listening for external controls on " ++ cCtrlAddr config ++ ":" ++ show (cCtrlPort config) - listen <- openListener config - - cxs <- getCXs config oscmap - - clockRef <- Clock.clocked (cClockConfig config) (doTick sMapMV bussesMV pMapMV globalFMV cxs listen) - - let stream = Stream {sConfig = config, - sBusses = bussesMV, - sStateMV = sMapMV, - sClockRef = clockRef, - -- sLink = abletonLink, - sListen = listen, - sPMapMV = pMapMV, - -- sActionsMV = actionsMV, - sGlobalFMV = globalFMV, - sCxs = cxs - } - - sendHandshakes stream - - -- Spawn a thread to handle OSC control messages - _ <- forkIO $ ctrlResponder 0 config stream - return stream + sMapMV <- newMVar Map.empty + pMapMV <- newMVar Map.empty + bussesMV <- newMVar [] + globalFMV <- newMVar id + + tidal_status_string >>= verbose config + verbose config $ "Listening for external controls on " ++ cCtrlAddr config ++ ":" ++ show (cCtrlPort config) + listen <- openListener config + + cxs <- getCXs config oscmap + + clockRef <- Clock.clocked (cClockConfig config) (doTick sMapMV bussesMV pMapMV globalFMV cxs listen) + + let stream = + Stream + { sConfig = config, + sBusses = bussesMV, + sStateMV = sMapMV, + sClockRef = clockRef, + -- sLink = abletonLink, + sListen = listen, + sPMapMV = pMapMV, + -- sActionsMV = actionsMV, + sGlobalFMV = globalFMV, + sCxs = cxs + } + + sendHandshakes stream + + -- Spawn a thread to handle OSC control messages + _ <- forkIO $ ctrlResponder 0 config stream + return stream startMulti :: [Target] -> Config -> IO () startMulti _ _ = hPutStrLn stderr $ "startMulti has been removed, please check the latest documentation on tidalcycles.org" diff --git a/src/Sound/Tidal/Stream/Process.hs b/src/Sound/Tidal/Stream/Process.hs index 2b1a7198..bb1cc913 100644 --- a/src/Sound/Tidal/Stream/Process.hs +++ b/src/Sound/Tidal/Stream/Process.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE StandaloneDeriving #-} module Sound.Tidal.Stream.Process where @@ -27,42 +27,38 @@ module Sound.Tidal.Stream.Process where along with this library. If not, see . -} -import Control.Applicative ((<|>)) -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) -import System.IO (hPutStrLn, stderr) - -import qualified Sound.Osc.Fd as O +import Control.Applicative ((<|>)) +import Control.Concurrent.MVar +import qualified Control.Exception as E +import Control.Monad (forM_, when) +import Data.Coerce (coerce) +import Data.List (sortOn) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes, fromJust, fromMaybe) +import qualified Sound.Osc.Fd as O import qualified Sound.Osc.Transport.Fd.Udp as O +import qualified Sound.Tidal.Clock as Clock +import Sound.Tidal.Core (stack, (#)) +import Sound.Tidal.ID +import qualified Sound.Tidal.Link as Link +import Sound.Tidal.Params (pS) +import Sound.Tidal.Pattern +import Sound.Tidal.Show () +import Sound.Tidal.Stream.Target +import Sound.Tidal.Stream.Types +import Sound.Tidal.Utils ((!!!)) +import System.IO (hPutStrLn, stderr) -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 Sound.Tidal.Params (pS) -import Sound.Tidal.Pattern -import Sound.Tidal.Show () -import Sound.Tidal.Utils ((!!!)) - -import Sound.Tidal.Stream.Target -import Sound.Tidal.Stream.Types - -data ProcessedEvent = - ProcessedEvent { - peHasOnset :: Bool, - peEvent :: Event ValueMap, - peCps :: Double, - peDelta :: Link.Micros, - peCycle :: Time, - peOnWholeOrPart :: Link.Micros, +data ProcessedEvent = ProcessedEvent + { peHasOnset :: Bool, + peEvent :: Event ValueMap, + peCps :: Double, + 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@) @@ -78,48 +74,53 @@ data ProcessedEvent = -- this function prints a warning and resets the current pattern -- to the previous one (or to silence if there isn't one) and continues, -- because the likely reason is that something is wrong with the current pattern. - -doTick :: MVar ValueMap -- pattern state - -> MVar [Int] -- busses - -> MVar PlayMap -- currently playing - -> MVar (ControlPattern -> ControlPattern) -- current global fx - -> [Cx] -- target addresses - -> Maybe O.Udp -- network socket - -> (Time,Time) -- current arc - -> Double -- nudge - -> Clock.ClockConfig -- config of the clock - -> Clock.ClockRef -- reference to the clock - -> (Link.SessionState, Link.SessionState) -- second session state is for keeping track of tempo changes - -> IO () -doTick stateMV busMV playMV globalFMV cxs listen (st,end) nudge cconf cref (ss, temposs) = +doTick :: + MVar ValueMap -> -- pattern state + MVar [Int] -> -- busses + MVar PlayMap -> -- currently playing + MVar (ControlPattern -> ControlPattern) -> -- current global fx + [Cx] -> -- target addresses + Maybe O.Udp -> -- network socket + (Time, Time) -> -- current arc + Double -> -- nudge + Clock.ClockConfig -> -- config of the clock + Clock.ClockRef -> -- reference to the clock + (Link.SessionState, Link.SessionState) -> -- second session state is for keeping track of tempo changes + IO () +doTick stateMV busMV playMV globalFMV cxs listen (st, end) nudge cconf cref (ss, temposs) = E.handle handleException $ do modifyMVar_ stateMV $ \sMap -> do pMap <- readMVar playMV busses <- readMVar busMV sGlobalF <- readMVar globalFMV bpm <- Clock.getTempo ss - let - patstack = sGlobalF $ playStack pMap - cps = ((Clock.beatToCycles cconf) $ fromRational bpm) / 60 - sMap' = Map.insert "_cps" (VF $ coerce cps) sMap - extraLatency = nudge - -- First the state is used to query the pattern - es = sortOn (start . part) $ query patstack (State {arc = Arc st end, - controls = sMap' - } - ) - -- Then it's passed through the events - (sMap'', es') = resolveState sMap' es + let patstack = sGlobalF $ playStack pMap + cps = ((Clock.beatToCycles cconf) $ fromRational bpm) / 60 + sMap' = Map.insert "_cps" (VF $ coerce cps) sMap + extraLatency = nudge + -- First the state is used to query the pattern + es = + sortOn (start . part) $ + query + patstack + ( State + { arc = Arc st end, + controls = sMap' + } + ) + -- Then it's passed through the events + (sMap'', es') = resolveState sMap' es tes <- processCps cconf cref (ss, temposs) es' -- For each OSC target forM_ cxs $ \cx@(Cx target _ oscs _ _) -> do - -- Latency is configurable per target. - -- Latency is only used when sending events live. - let latency = oLatency target - ms = concatMap (\e -> concatMap (toOSC busses e) oscs) tes - -- send the events to the OSC target - forM_ ms $ \m -> (send listen cx latency extraLatency m) `E.catch` \(e :: E.SomeException) -> - hPutStrLn stderr $ "Failed to send. Is the '" ++ oName target ++ "' target running? " ++ show e + -- Latency is configurable per target. + -- Latency is only used when sending events live. + let latency = oLatency target + ms = concatMap (\e -> concatMap (toOSC busses e) oscs) tes + -- send the events to the OSC target + forM_ ms $ \m -> + (send listen cx latency extraLatency m) `E.catch` \(e :: E.SomeException) -> + hPutStrLn stderr $ "Failed to send. Is the '" ++ oName target ++ "' target running? " ++ show e return sMap'' where handleException :: E.SomeException -> IO () @@ -131,7 +132,7 @@ doTick stateMV busMV playMV globalFMV cxs listen (st,end) nudge cconf cref (ss, processCps :: Clock.ClockConfig -> Clock.ClockRef -> (Link.SessionState, Link.SessionState) -> [Event ValueMap] -> IO [ProcessedEvent] processCps cconf cref (ss, temposs) = mapM processEvent where - processEvent :: Event ValueMap -> IO ProcessedEvent + processEvent :: Event ValueMap -> IO ProcessedEvent processEvent e = do let wope = wholeOrPart e partStartCycle = start $ part e @@ -142,9 +143,11 @@ processCps cconf cref (ss, temposs) = mapM processEvent offBeat = (Clock.cyclesToBeat cconf) (realToFrac offCycle) on <- Clock.timeAtBeat cconf ss onBeat onPart <- Clock.timeAtBeat cconf ss partStartBeat - when (eventHasOnset e) (do - let cps' = Map.lookup "cps" (value e) >>= getF - maybe (return ()) (\newCps -> Clock.setTempoCPS newCps on cconf temposs) (fmap toRational cps') + when + (eventHasOnset e) + ( do + let cps' = Map.lookup "cps" (value e) >>= getF + maybe (return ()) (\newCps -> Clock.setTempoCPS newCps on cconf temposs) (fmap toRational cps') ) off <- Clock.timeAtBeat cconf ss offBeat bpm <- Clock.getTempo ss @@ -152,155 +155,178 @@ processCps cconf cref (ss, temposs) = mapM processEvent onPartOsc <- Clock.linkToOscTime cref onPart let cps = ((Clock.beatToCycles cconf) $ fromRational bpm) / 60 let delta = off - on - return $! ProcessedEvent { - peHasOnset = eventHasOnset e, - peEvent = e, - peCps = cps, - peDelta = delta, - peCycle = onCycle, - peOnWholeOrPart = on, - peOnWholeOrPartOsc = wholeOrPartOsc, - peOnPart = onPart, - peOnPartOsc = onPartOsc - } - + return + $! ProcessedEvent + { peHasOnset = eventHasOnset e, + peEvent = e, + peCps = cps, + peDelta = delta, + peCycle = onCycle, + peOnWholeOrPart = on, + peOnWholeOrPartOsc = wholeOrPartOsc, + peOnPart = onPart, + peOnPartOsc = onPartOsc + } toOSC :: [Int] -> ProcessedEvent -> OSC -> [(Double, Bool, O.Message)] -toOSC busses pe osc@(OSC _ _) - = catMaybes (playmsg:busmsgs) - -- playmap is a ValueMap where the keys don't start with ^ and are not "" - -- busmap is a ValueMap containing the rest of the keys from the event value - -- The partition is performed in order to have special handling of bus ids. +toOSC busses pe osc@(OSC _ _) = + catMaybes (playmsg : busmsgs) + where + -- playmap is a ValueMap where the keys don't start with ^ and are not "" + -- busmap is a ValueMap containing the rest of the keys from the event value + -- The partition is performed in order to have special handling of bus ids. + + (playmap, busmap) = Map.partitionWithKey (\k _ -> null k || head k /= '^') $ val pe + -- Map in bus ids where needed. + -- + -- Bus ids are integers + -- If busses is empty, the ids to send are directly contained in the the values of the busmap. + -- Otherwise, the ids to send are contained in busses at the indices of the values of the busmap. + -- Both cases require that the values of the busmap are only ever integers, + -- that is, they are Values with constructor VI + -- (but perhaps we should explicitly crash with an error message if it contains something else?). + -- Map.mapKeys tail is used to remove ^ from the keys. + -- In case (value e) has the key "", we will get a crash here. + playmap' = Map.union (Map.mapKeys tail $ Map.map (\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 + -- If there is already cps in the event, the union will preserve that. + let extra = + Map.fromList + [ ("cps", (VF (peCps pe))), + ("delta", VF (Clock.addMicrosToOsc (peDelta pe) 0)), + ("cycle", VF (fromRational (peCycle pe))) + ] + addExtra = Map.union playmap' extra + ts = (peOnWholeOrPartOsc pe) + nudge -- + latency + vs <- toData osc ((peEvent pe) {value = addExtra}) + mungedPath <- substitutePath (path osc) playmap' + return + ( ts, + False, -- bus message ? + O.Message mungedPath vs + ) + | otherwise = Nothing + toBus n + | null busses = n + | otherwise = busses !!! n + busmsgs = + map + ( \(k, 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 - (playmap, busmap) = Map.partitionWithKey (\k _ -> null k || head k /= '^') $ val pe - -- Map in bus ids where needed. - -- - -- Bus ids are integers - -- If busses is empty, the ids to send are directly contained in the the values of the busmap. - -- Otherwise, the ids to send are contained in busses at the indices of the values of the busmap. - -- Both cases require that the values of the busmap are only ever integers, - -- that is, they are Values with constructor VI - -- (but perhaps we should explicitly crash with an error message if it contains something else?). - -- Map.mapKeys tail is used to remove ^ from the keys. - -- In case (value e) has the key "", we will get a crash here. - playmap' = Map.union (Map.mapKeys tail $ Map.map (\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 - -- If there is already cps in the event, the union will preserve that. - let extra = Map.fromList [("cps", (VF (peCps pe))), - ("delta", VF (Clock.addMicrosToOsc (peDelta pe) 0)), - ("cycle", VF (fromRational (peCycle pe))) - ] - addExtra = Map.union playmap' extra - ts = (peOnWholeOrPartOsc pe) + nudge -- + latency - vs <- toData osc ((peEvent pe) {value = addExtra}) - mungedPath <- substitutePath (path osc) playmap' - return (ts, - False, -- bus message ? - O.Message mungedPath vs - ) - | otherwise = Nothing - toBus n | null busses = n - | otherwise = busses !!! n - busmsgs = map - (\(k, 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 - tsPart = (peOnPartOsc pe) + nudge -- + latency - nudge = fromJust $ getF $ fromMaybe (VF 0) $ Map.lookup "nudge" $ playmap -toOSC _ pe (OSCContext oscpath) - = map cToM $ contextPosition $ context $ peEvent pe - where cToM :: ((Int,Int),(Int,Int)) -> (Double, Bool, O.Message) - cToM ((x, y), (x',y')) = (ts, - False, -- bus message ? - O.Message oscpath $ (O.string ident):(O.float (peDelta pe)):(O.float cyc):(map O.int32 [x,y,x',y']) - ) - cyc :: Double - cyc = fromRational $ peCycle pe - nudge = fromMaybe 0 $ Map.lookup "nudge" (value $ peEvent pe) >>= getF - ident = fromMaybe "unknown" $ Map.lookup "_id_" (value $ peEvent pe) >>= getS - ts = (peOnWholeOrPartOsc pe) + nudge -- + latency + tsPart = (peOnPartOsc pe) + nudge -- + latency + nudge = fromJust $ getF $ fromMaybe (VF 0) $ Map.lookup "nudge" $ playmap +toOSC _ pe (OSCContext oscpath) = + map cToM $ contextPosition $ context $ peEvent pe + where + cToM :: ((Int, Int), (Int, Int)) -> (Double, Bool, O.Message) + cToM ((x, y), (x', y')) = + ( ts, + False, -- bus message ? + O.Message oscpath $ (O.string ident) : (O.float (peDelta pe)) : (O.float cyc) : (map O.int32 [x, y, x', y']) + ) + cyc :: Double + cyc = fromRational $ peCycle pe + nudge = fromMaybe 0 $ Map.lookup "nudge" (value $ peEvent pe) >>= getF + ident = fromMaybe "unknown" $ Map.lookup "_id_" (value $ peEvent pe) >>= getS + ts = (peOnWholeOrPartOsc pe) + nudge -- + latency 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 +toData (OSC {args = ArgList as}) e = fmap (fmap (toDatum)) $ sequence $ map (\(n, v) -> Map.lookup n (value e) <|> v) as toData (OSC {args = Named rqrd}) e - | hasRequired rqrd = Just $ concatMap (\(n,v) -> [O.string n, toDatum v]) $ Map.toList $ value e + | hasRequired rqrd = Just $ concatMap (\(n, v) -> [O.string n, toDatum v]) $ Map.toList $ value e | otherwise = Nothing - where hasRequired [] = True - hasRequired xs = null $ filter (not . (`elem` ks)) xs - ks = Map.keys (value e) + where + hasRequired [] = True + hasRequired xs = null $ filter (not . (`elem` ks)) xs + ks = Map.keys (value 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 - where parse [] = Just [] - parse ('{':xs) = parseWord xs - parse (x:xs) = do xs' <- parse xs - return (x:xs') - parseWord xs | b == [] = getString cm a - | otherwise = do v <- getString cm a - xs' <- parse (tail b) - return $ v ++ xs' - where (a,b) = break (== '}') xs + where + parse [] = Just [] + parse ('{' : xs) = parseWord xs + parse (x : xs) = do + xs' <- parse xs + return (x : xs') + parseWord xs + | b == [] = getString cm a + | otherwise = do + v <- getString cm a + xs' <- parse (tail b) + return $ v ++ xs' + where + (a, b) = break (== '}') xs 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 (VPattern _) = show "" - simpleShow (VList _) = show "" - defaultValue :: String -> Maybe String - defaultValue ('=':dfltVal) = Just dfltVal - defaultValue _ = Nothing + 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 (VPattern _) = show "" + simpleShow (VList _) = show "" + defaultValue :: String -> Maybe String + defaultValue ('=' : dfltVal) = Just dfltVal + defaultValue _ = Nothing playStack :: PlayMap -> ControlPattern playStack pMap = stack . (map psPattern) . (filter active) . Map.elems $ pMap - where active pState = if hasSolo pMap - then psSolo pState - else not (psMute pState) + where + active pState = + if hasSolo pMap + then psSolo pState + else not (psMute pState) hasSolo :: Map.Map k PlayState -> Bool hasSolo = (>= 1) . length . filter psSolo . Map.elems onSingleTick :: Clock.ClockConfig -> Clock.ClockRef -> MVar ValueMap -> MVar [Int] -> MVar PlayMap -> MVar (ControlPattern -> ControlPattern) -> [Cx] -> Maybe O.Udp -> ControlPattern -> IO () onSingleTick clockConfig clockRef stateMV busMV _ globalFMV cxs listen pat = do - pMapMV <- newMVar $ Map.singleton "fake" - (PlayState {psPattern = pat, - psMute = False, - psSolo = False, - psHistory = [] - } - ) + pMapMV <- + newMVar $ + Map.singleton + "fake" + ( PlayState + { psPattern = pat, + psMute = False, + psSolo = False, + psHistory = [] + } + ) Clock.clockOnce (doTick stateMV busMV pMapMV globalFMV cxs listen) clockConfig clockRef - -- Used for Tempo callback updatePattern :: Stream -> ID -> Time -> ControlPattern -> IO () updatePattern stream k !t pat = do @@ -308,16 +334,20 @@ 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 {psPattern = pat', psHistory = pat:(psHistory playState)} - updatePS Nothing = PlayState pat' False False [pat'] - patControls = Map.singleton patternTimeID (VR t) - pat' = withQueryControls (Map.union patControls) - $ pat # pS "_id_" (pure $ fromID k) + 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) $ + pat # pS "_id_" (pure $ fromID k) setPreviousPatternOrSilence :: MVar PlayMap -> IO () setPreviousPatternOrSilence playMV = - modifyMVar_ playMV $ return - . Map.map ( \ pMap -> case psHistory pMap of - _:p:ps -> pMap { psPattern = p, psHistory = p:ps } - _ -> pMap { psPattern = silence, psHistory = [silence] } - ) + modifyMVar_ playMV $ + return + . 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/Target.hs b/src/Sound/Tidal/Stream/Target.hs index 03406102..8a81127b 100644 --- a/src/Sound/Tidal/Stream/Target.hs +++ b/src/Sound/Tidal/Stream/Target.hs @@ -1,15 +1,14 @@ module Sound.Tidal.Stream.Target where -import qualified Sound.Osc.Fd as O +import Control.Concurrent (forkOS, threadDelay) +import Data.Maybe (fromJust, isJust) +import Foreign (Word8) +import qualified Network.Socket as N +import qualified Sound.Osc.Fd as O import qualified Sound.Osc.Transport.Fd.Udp as O -import qualified Network.Socket as N -import Data.Maybe (fromJust, isJust) -import Control.Concurrent (forkOS, threadDelay) -import Foreign (Word8) - -import Sound.Tidal.Pattern -import Sound.Tidal.Stream.Types -import Sound.Tidal.Stream.Config +import Sound.Tidal.Pattern +import Sound.Tidal.Stream.Config +import Sound.Tidal.Stream.Types {- Target.hs - Create and send to OSC targets @@ -29,24 +28,33 @@ import Sound.Tidal.Stream.Config along with this library. If not, see . -} - getCXs :: Config -> [(Target, [OSC])] -> IO [Cx] -getCXs config oscmap = mapM (\(target, os) -> do - remote_addr <- resolve (oAddress target) (show $ oPort target) - remote_bus_addr <- if isJust $ oBusPort target - then Just <$> resolve (oAddress target) (show $ fromJust $ oBusPort target) - else return Nothing - let broadcast = if cCtrlBroadcast config then 1 else 0 - u <- O.udp_socket (\sock sockaddr -> do N.setSocketOption sock N.Broadcast broadcast - N.connect sock sockaddr - ) (oAddress target) (oPort target) - return $ Cx {cxUDP = u, cxAddr = remote_addr, cxBusAddr = remote_bus_addr, cxTarget = target, cxOSCs = os} - ) oscmap +getCXs config oscmap = + mapM + ( \(target, os) -> do + remote_addr <- resolve (oAddress target) (show $ oPort target) + remote_bus_addr <- + if isJust $ oBusPort target + then Just <$> resolve (oAddress target) (show $ fromJust $ oBusPort target) + else return Nothing + let broadcast = if cCtrlBroadcast config then 1 else 0 + u <- + O.udp_socket + ( \sock sockaddr -> do + N.setSocketOption sock N.Broadcast broadcast + N.connect sock sockaddr + ) + (oAddress target) + (oPort target) + return $ Cx {cxUDP = u, cxAddr = remote_addr, cxBusAddr = remote_bus_addr, cxTarget = target, cxOSCs = os} + ) + oscmap resolve :: String -> String -> IO N.AddrInfo -resolve host port = do let hints = N.defaultHints { N.addrSocketType = N.Stream } - addr:_ <- N.getAddrInfo (Just hints) (Just host) (Just port) - return addr +resolve host port = do + let hints = N.defaultHints {N.addrSocketType = N.Stream} + addr : _ <- N.getAddrInfo (Just hints) (Just host) (Just port) + return addr -- send has three modes: -- Send events early using timestamp in the OSC bundle - used by Superdirt @@ -56,102 +64,120 @@ send :: Maybe O.Udp -> Cx -> Double -> Double -> (Double, Bool, O.Message) -> IO send listen cx latency extraLatency (time, isBusMsg, m) | oSchedule target == Pre BundleStamp = sendBndl isBusMsg listen cx $ O.Bundle timeWithLatency [m] | oSchedule target == Pre MessageStamp = sendO isBusMsg listen cx $ addtime m - | otherwise = do _ <- forkOS $ do now <- O.time - threadDelay $ floor $ (timeWithLatency - now) * 1000000 - sendO isBusMsg listen cx m - return () - where addtime (O.Message mpath params) = O.Message mpath ((O.int32 sec):((O.int32 usec):params)) - ut = O.ntpr_to_posix timeWithLatency - sec :: Int - sec = floor ut - usec :: Int - usec = floor $ 1000000 * (ut - (fromIntegral sec)) - target = cxTarget cx - timeWithLatency = time - latency + extraLatency + | otherwise = do + _ <- forkOS $ do + now <- O.time + threadDelay $ floor $ (timeWithLatency - now) * 1000000 + sendO isBusMsg listen cx m + return () + where + addtime (O.Message mpath params) = O.Message mpath ((O.int32 sec) : ((O.int32 usec) : params)) + ut = O.ntpr_to_posix timeWithLatency + sec :: Int + sec = floor ut + usec :: Int + usec = floor $ 1000000 * (ut - (fromIntegral sec)) + target = cxTarget cx + timeWithLatency = time - latency + extraLatency sendBndl :: Bool -> (Maybe O.Udp) -> Cx -> O.Bundle -> IO () sendBndl isBusMsg (Just listen) cx bndl = O.sendTo listen (O.Packet_Bundle bndl) (N.addrAddress addr) - where addr | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx - | otherwise = cxAddr cx + where + addr + | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx + | otherwise = cxAddr cx sendBndl _ Nothing cx bndl = O.sendBundle (cxUDP cx) bndl sendO :: Bool -> (Maybe O.Udp) -> Cx -> O.Message -> IO () sendO isBusMsg (Just listen) cx msg = O.sendTo listen (O.Packet_Message msg) (N.addrAddress addr) - where addr | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx - | otherwise = cxAddr cx + where + addr + | isBusMsg && isJust (cxBusAddr cx) = fromJust $ cxBusAddr cx + | otherwise = cxAddr cx sendO _ Nothing cx msg = O.sendMessage (cxUDP cx) msg - superdirtTarget :: Target -superdirtTarget = Target {oName = "SuperDirt", - oAddress = "127.0.0.1", - oPort = 57120, - oBusPort = Just 57110, - oLatency = 0.2, - oWindow = Nothing, - oSchedule = Pre BundleStamp, - oHandshake = True - } +superdirtTarget = + Target + { oName = "SuperDirt", + oAddress = "127.0.0.1", + oPort = 57120, + oBusPort = Just 57110, + oLatency = 0.2, + oWindow = Nothing, + oSchedule = Pre BundleStamp, + oHandshake = True + } superdirtShape :: OSC superdirtShape = OSC "/dirt/play" $ Named {requiredArgs = ["s"]} dirtTarget :: Target -dirtTarget = Target {oName = "Dirt", - oAddress = "127.0.0.1", - oPort = 7771, - oBusPort = Nothing, - oLatency = 0.02, - oWindow = Nothing, - oSchedule = Pre MessageStamp, - oHandshake = False - } +dirtTarget = + Target + { oName = "Dirt", + oAddress = "127.0.0.1", + oPort = 7771, + oBusPort = Nothing, + oLatency = 0.02, + oWindow = Nothing, + oSchedule = Pre MessageStamp, + oHandshake = False + } dirtShape :: OSC -dirtShape = OSC "/play" $ ArgList [("cps", fDefault 0), - ("s", Nothing), - ("offset", fDefault 0), - ("begin", fDefault 0), - ("end", fDefault 1), - ("speed", fDefault 1), - ("pan", fDefault 0.5), - ("velocity", fDefault 0.5), - ("vowel", sDefault ""), - ("cutoff", fDefault 0), - ("resonance", fDefault 0), - ("accelerate", fDefault 0), - ("shape", fDefault 0), - ("kriole", iDefault 0), - ("gain", fDefault 1), - ("cut", iDefault 0), - ("delay", fDefault 0), - ("delaytime", fDefault (-1)), - ("delayfeedback", fDefault (-1)), - ("crush", fDefault 0), - ("coarse", iDefault 0), - ("hcutoff", fDefault 0), - ("hresonance", fDefault 0), - ("bandf", fDefault 0), - ("bandq", fDefault 0), - ("unit", sDefault "rate"), - ("loop", fDefault 0), - ("n", fDefault 0), - ("attack", fDefault (-1)), - ("hold", fDefault 0), - ("release", fDefault (-1)), - ("orbit", iDefault 0) -- , - -- ("id", iDefault 0) - ] +dirtShape = + OSC "/play" $ + ArgList + [ ("cps", fDefault 0), + ("s", Nothing), + ("offset", fDefault 0), + ("begin", fDefault 0), + ("end", fDefault 1), + ("speed", fDefault 1), + ("pan", fDefault 0.5), + ("velocity", fDefault 0.5), + ("vowel", sDefault ""), + ("cutoff", fDefault 0), + ("resonance", fDefault 0), + ("accelerate", fDefault 0), + ("shape", fDefault 0), + ("kriole", iDefault 0), + ("gain", fDefault 1), + ("cut", iDefault 0), + ("delay", fDefault 0), + ("delaytime", fDefault (-1)), + ("delayfeedback", fDefault (-1)), + ("crush", fDefault 0), + ("coarse", iDefault 0), + ("hcutoff", fDefault 0), + ("hresonance", fDefault 0), + ("bandf", fDefault 0), + ("bandq", fDefault 0), + ("unit", sDefault "rate"), + ("loop", fDefault 0), + ("n", fDefault 0), + ("attack", fDefault (-1)), + ("hold", fDefault 0), + ("release", fDefault (-1)), + ("orbit", iDefault 0) -- , + -- ("id", iDefault 0) + ] sDefault :: String -> Maybe Value sDefault x = Just $ VS x + fDefault :: Double -> Maybe Value fDefault x = Just $ VF x + rDefault :: Rational -> Maybe Value rDefault x = Just $ VR x + iDefault :: Int -> Maybe Value iDefault x = Just $ VI x + bDefault :: Bool -> Maybe Value bDefault x = Just $ VB x + xDefault :: [Word8] -> Maybe Value xDefault x = Just $ VX x diff --git a/src/Sound/Tidal/Stream/Types.hs b/src/Sound/Tidal/Stream/Types.hs index 1e65c2aa..2b3d8a54 100644 --- a/src/Sound/Tidal/Stream/Types.hs +++ b/src/Sound/Tidal/Stream/Types.hs @@ -1,72 +1,79 @@ 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 Network.Socket as N +import Control.Concurrent.MVar +import qualified Data.Map.Strict as Map +import qualified Network.Socket as N import qualified Sound.Osc.Transport.Fd.Udp as O +import qualified Sound.Tidal.Clock as Clock +import Sound.Tidal.Pattern +import Sound.Tidal.Show () +import Sound.Tidal.Stream.Config -import qualified Sound.Tidal.Clock as Clock - -import Sound.Tidal.Stream.Config +data Stream = Stream + { sConfig :: Config, + sBusses :: MVar [Int], + sStateMV :: MVar ValueMap, + -- sOutput :: MVar ControlPattern, + sClockRef :: Clock.ClockRef, + sListen :: Maybe O.Udp, + sPMapMV :: MVar PlayMap, + sGlobalFMV :: MVar (ControlPattern -> ControlPattern), + sCxs :: [Cx] + } -data Stream = Stream {sConfig :: Config, - sBusses :: MVar [Int], - sStateMV :: MVar ValueMap, - -- sOutput :: MVar ControlPattern, - sClockRef :: Clock.ClockRef, - sListen :: Maybe O.Udp, - sPMapMV :: MVar PlayMap, - sGlobalFMV :: MVar (ControlPattern -> ControlPattern), - sCxs :: [Cx] - } +data Cx = Cx + { cxTarget :: Target, + cxUDP :: O.Udp, + cxOSCs :: [OSC], + cxAddr :: N.AddrInfo, + cxBusAddr :: Maybe N.AddrInfo + } -data Cx = Cx {cxTarget :: Target, - cxUDP :: O.Udp, - cxOSCs :: [OSC], - cxAddr :: N.AddrInfo, - cxBusAddr :: Maybe N.AddrInfo - } - -data StampStyle = BundleStamp - | MessageStamp +data StampStyle + = BundleStamp + | MessageStamp deriving (Eq, Show) -data Schedule = Pre StampStyle - | Live +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, - oHandshake :: Bool - } - deriving Show +data Target = Target + { oName :: String, + oAddress :: String, + oPort :: Int, + oBusPort :: Maybe Int, + oLatency :: Double, + oWindow :: Maybe Arc, + oSchedule :: Schedule, + oHandshake :: Bool + } + deriving (Show) -data Args = Named {requiredArgs :: [String]} - | ArgList [(String, Maybe Value)] - deriving Show +data Args + = Named {requiredArgs :: [String]} + | ArgList [(String, Maybe Value)] + deriving (Show) -data OSC = OSC {path :: String, - args :: Args - } - | OSCContext {path :: String} - deriving Show +data OSC + = OSC + { path :: String, + args :: Args + } + | OSCContext {path :: String} + deriving (Show) -data PlayState = PlayState {psPattern :: ControlPattern, - psMute :: Bool, - psSolo :: Bool, - psHistory :: [ControlPattern] - } - deriving Show +data PlayState = PlayState + { psPattern :: ControlPattern, + psMute :: Bool, + psSolo :: Bool, + psHistory :: [ControlPattern] + } + deriving (Show) type PatId = String + type PlayMap = Map.Map PatId PlayState -- data TickState = TickState { diff --git a/src/Sound/Tidal/Stream/UI.hs b/src/Sound/Tidal/Stream/UI.hs index 1c160b1b..0cb3c224 100644 --- a/src/Sound/Tidal/Stream/UI.hs +++ b/src/Sound/Tidal/Stream/UI.hs @@ -1,23 +1,22 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} -module Sound.Tidal.Stream.UI where - -import Control.Concurrent.MVar -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 +module Sound.Tidal.Stream.UI where -import Sound.Tidal.ID -import Sound.Tidal.Pattern +import Control.Concurrent.MVar +import qualified Control.Exception as E +import qualified Data.Map as Map +import Data.Maybe (isJust) +import qualified Sound.Osc.Fd as O +import qualified Sound.Tidal.Clock as Clock +import Sound.Tidal.ID +import Sound.Tidal.Pattern +import Sound.Tidal.Stream.Config +import Sound.Tidal.Stream.Process +import Sound.Tidal.Stream.Target +import Sound.Tidal.Stream.Types +import System.IO (hPutStrLn, stderr) +import System.Random (getStdRandom, randomR) streamNudgeAll :: Stream -> Double -> IO () streamNudgeAll s = Clock.setNudge (sClockRef s) @@ -35,13 +34,13 @@ streamSetBPM :: Stream -> Time -> IO () streamSetBPM s = Clock.setBPM (sClockRef s) streamGetCPS :: Stream -> IO Time -streamGetCPS s = Clock.getCPS (cClockConfig $ sConfig s)(sClockRef s) +streamGetCPS s = Clock.getCPS (cClockConfig $ sConfig s) (sClockRef s) streamGetBPM :: Stream -> IO Time streamGetBPM s = Clock.getBPM (sClockRef s) streamGetNow :: Stream -> IO Time -streamGetNow s = Clock.getCycleTime (cClockConfig $ sConfig s)(sClockRef s) +streamGetNow s = Clock.getCycleTime (cClockConfig $ sConfig s) (sClockRef s) streamEnableLink :: Stream -> IO () streamEnableLink s = Clock.enableLink (sClockRef s) @@ -50,27 +49,33 @@ streamDisableLink :: Stream -> IO () streamDisableLink s = Clock.disableLink (sClockRef s) 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 {psSolo = True})) = k ++ " - solo\n" - showKV True (k, _) = "(" ++ k ++ ")\n" - showKV False (k, (PlayState {psSolo = False})) = k ++ "\n" - showKV False (k, _) = "(" ++ k ++ ") - muted\n" +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 {psSolo = True})) = k ++ " - solo\n" + showKV True (k, _) = "(" ++ k ++ ")\n" + showKV False (k, (PlayState {psSolo = False})) = k ++ "\n" + showKV False (k, _) = "(" ++ k ++ ") - muted\n" streamReplace :: Stream -> ID -> ControlPattern -> IO () streamReplace stream k !pat = do - t <- Clock.getCycleTime (cClockConfig $ sConfig stream) (sClockRef stream) - E.handle (\ (e :: E.SomeException) -> do - hPutStrLn stderr $ "Failed to Stream.streamReplace: " ++ show e - hPutStrLn stderr $ "Return to previous pattern." - setPreviousPatternOrSilence (sPMapMV stream)) (updatePattern stream k t pat) + t <- Clock.getCycleTime (cClockConfig $ sConfig stream) (sClockRef stream) + E.handle + ( \(e :: E.SomeException) -> do + hPutStrLn stderr $ "Failed to Stream.streamReplace: " ++ show e + hPutStrLn stderr $ "Return to previous pattern." + setPreviousPatternOrSilence (sPMapMV stream) + ) + (updatePattern stream k t pat) -- streamFirst but with random cycle instead of always first cicle streamOnce :: Stream -> ControlPattern -> IO () -streamOnce st p = do i <- getStdRandom $ randomR (0, 8192) - streamFirst st $ rotL (toRational (i :: Int)) p +streamOnce st p = do + i <- getStdRandom $ randomR (0, 8192) + streamFirst st $ rotL (toRational (i :: Int)) p streamFirst :: Stream -> ControlPattern -> IO () streamFirst stream pat = onSingleTick (cClockConfig $ sConfig stream) (sClockRef stream) (sStateMV stream) (sBusses stream) (sPMapMV stream) (sGlobalFMV stream) (sCxs stream) (sListen stream) pat @@ -91,18 +96,19 @@ streamUnsolo :: Stream -> ID -> IO () streamUnsolo s k = withPatIds s [k] (\x -> x {psSolo = False}) withPatIds :: Stream -> [ID] -> (PlayState -> PlayState) -> IO () -withPatIds s ks f - = do playMap <- takeMVar $ sPMapMV s - let pMap' = foldr (Map.update (\x -> Just $ f x)) playMap (map fromID ks) - putMVar (sPMapMV s) pMap' - return () +withPatIds s ks f = + do + playMap <- takeMVar $ sPMapMV s + let pMap' = foldr (Map.update (\x -> Just $ f x)) playMap (map fromID ks) + putMVar (sPMapMV s) pMap' + return () -- TODO - is there a race condition here? streamMuteAll :: Stream -> IO () streamMuteAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {psMute = True}) streamHush :: Stream -> IO () -streamHush s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {psPattern = silence, psHistory = silence:psHistory 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 {psMute = False}) @@ -111,20 +117,22 @@ streamUnsoloAll :: Stream -> IO () streamUnsoloAll s = modifyMVar_ (sPMapMV s) $ return . fmap (\x -> x {psSolo = False}) streamSilence :: Stream -> ID -> IO () -streamSilence s k = withPatIds s [k] (\x -> x {psPattern = silence, psHistory = silence:psHistory 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 - return () +streamAll s f = do + _ <- swapMVar (sGlobalFMV s) f + return () streamGet :: Stream -> String -> IO (Maybe Value) streamGet s k = Map.lookup k <$> readMVar (sStateMV s) streamSet :: Valuable a => Stream -> String -> Pattern a -> IO () -streamSet s k pat = do sMap <- takeMVar $ sStateMV s - let pat' = toValue <$> pat - sMap' = Map.insert k (VPattern pat') sMap - putMVar (sStateMV s) $ sMap' +streamSet s k pat = do + sMap <- takeMVar $ sStateMV s + let pat' = toValue <$> pat + sMap' = Map.insert k (VPattern pat') sMap + putMVar (sStateMV s) $ sMap' streamSetI :: Stream -> String -> Pattern Int -> IO () streamSetI = streamSet @@ -144,10 +152,11 @@ streamSetR = streamSet -- It only really works to handshake with one target at the moment.. sendHandshakes :: Stream -> IO () sendHandshakes stream = mapM_ sendHandshake $ filter (oHandshake . cxTarget) (sCxs stream) - where sendHandshake cx = if (isJust $ sListen stream) - then - do -- send it _from_ the udp socket we're listening to, so the - -- replies go back there - sendO False (sListen stream) cx $ O.Message "/dirt/handshake" [] - else - hPutStrLn stderr "Can't handshake with SuperCollider without control port." + where + sendHandshake cx = + if (isJust $ sListen stream) + then do + -- send it _from_ the udp socket we're listening to, so the + -- replies go back there + sendO False (sListen stream) cx $ O.Message "/dirt/handshake" [] + else hPutStrLn stderr "Can't handshake with SuperCollider without control port." diff --git a/src/Sound/Tidal/TH.hs b/src/Sound/Tidal/TH.hs index 85520a4e..c3467ed5 100644 --- a/src/Sound/Tidal/TH.hs +++ b/src/Sound/Tidal/TH.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} module Sound.Tidal.TH where @@ -24,14 +25,17 @@ import Language.Haskell.TH.Quote -} bp :: QuasiQuoter -bp = QuasiQuoter { - quoteExp = compile, - quotePat = notHandled "patterns", - quoteType = notHandled "types", - quoteDec = notHandled "declarations" -} - where notHandled things = error $ - things ++ " are not handled by the bp quasiquoter." +bp = + QuasiQuoter + { quoteExp = compile, + quotePat = notHandled "patterns", + quoteType = notHandled "types", + quoteDec = notHandled "declarations" + } + where + notHandled things = + error $ + things ++ " are not handled by the bp quasiquoter." compile :: String -> Q Exp -compile s = [e| parseBP_E s |] +compile s = [e|parseBP_E s|] diff --git a/src/Sound/Tidal/Time.hs b/src/Sound/Tidal/Time.hs index da3dfd60..0d09ca01 100644 --- a/src/Sound/Tidal/Time.hs +++ b/src/Sound/Tidal/Time.hs @@ -3,19 +3,20 @@ module Sound.Tidal.Time where -import Control.Applicative -import Control.DeepSeq (NFData) -import Data.Ratio -import GHC.Generics +import Control.Applicative +import Control.DeepSeq (NFData) +import Data.Ratio +import GHC.Generics -- | Time is rational 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 - } deriving (Eq, Ord, Functor, Show, Generic) + { start :: a, + stop :: a + } + deriving (Eq, Ord, Functor, Show, Generic) type Arc = ArcF Time @@ -26,15 +27,15 @@ instance Applicative ArcF where instance NFData a => NFData (ArcF a) instance Num a => Num (ArcF a) where - negate = fmap negate - (+) = liftA2 (+) - (*) = liftA2 (*) + negate = fmap negate + (+) = liftA2 (+) + (*) = liftA2 (*) fromInteger = pure . fromInteger - abs = fmap abs - signum = fmap signum + abs = fmap abs + signum = fmap signum instance (Fractional a) => Fractional (ArcF a) where - recip = fmap recip + recip = fmap recip fromRational = pure . fromRational -- * Utility functions - Time @@ -54,7 +55,7 @@ fromTime = fromRational -- | The end point of the current cycle (and starting point of the next cycle) nextSam :: Time -> Time -nextSam = (1+) . sam +nextSam = (1 +) . sam -- | The position of a time value relative to the start of its cycle. cyclePos :: Time -> Time @@ -77,12 +78,15 @@ subArc a@(Arc s e) b@(Arc s' e') | and [s'' == e'', s'' == e', s' < e'] = Nothing | s'' <= e'' = Just (Arc s'' e'') | otherwise = Nothing - where (Arc s'' e'') = sect a b + where + (Arc s'' e'') = sect a b subMaybeArc :: Maybe Arc -> Maybe Arc -> Maybe (Maybe Arc) -subMaybeArc (Just a) (Just b) = do sa <- subArc a b - return $ Just sa +subMaybeArc (Just a) (Just b) = do + sa <- subArc a b + return $ Just sa subMaybeArc _ _ = Just Nothing + -- subMaybeArc = liftA2 subArc -- this typechecks, but doesn't work the same way.. hmm -- | Simple intersection of two arcs @@ -101,7 +105,7 @@ timeToCycleArc t = Arc (sam t) (sam t + 1) -- (Note that the output Arc probably does not start *at* Time 0 -- -- that only happens when the input Arc starts at an integral Time.) cycleArc :: Arc -> Arc -cycleArc (Arc s e) = Arc (cyclePos s) (cyclePos s + (e-s)) +cycleArc (Arc s e) = Arc (cyclePos s) (cyclePos s + (e - s)) -- | Returns the numbers of the cycles that the input @Arc@ overlaps -- (excluding the input @Arc@'s endpoint, unless it has duration 0 -- @@ -122,7 +126,7 @@ cyclesInArc :: Integral a => Arc -> [a] cyclesInArc (Arc s e) | s > e = [] | s == e = [floor s] - | otherwise = [floor s .. ceiling e-1] + | otherwise = [floor s .. ceiling e - 1] -- | This provides exactly the same information as @cyclesInArc@, -- except that this represents its output as @Arc@s, @@ -134,20 +138,23 @@ cycleArcsInArc = map (timeToCycleArc . (toTime :: Int -> Time)) . cyclesInArc -- | Splits the given @Arc@ into a list of @Arc@s, at cycle boundaries. arcCycles :: Arc -> [Arc] -arcCycles (Arc s e) | s >= e = [] - | sam s == sam e = [Arc s e] - | otherwise = Arc s (nextSam s) : arcCycles (Arc (nextSam s) e) +arcCycles (Arc s e) + | s >= e = [] + | sam s == sam e = [Arc s e] + | otherwise = Arc s (nextSam s) : arcCycles (Arc (nextSam s) e) -- | Like arcCycles, but returns zero-width arcs arcCyclesZW :: Arc -> [Arc] -arcCyclesZW (Arc s e) | s == e = [Arc s e] - | otherwise = arcCycles (Arc s e) +arcCyclesZW (Arc s e) + | s == e = [Arc s e] + | otherwise = arcCycles (Arc s e) -- | Similar to @fmap@ but time is relative to the cycle (i.e. the -- sam of the start of the arc) mapCycle :: (Time -> Time) -> Arc -> Arc mapCycle f (Arc s e) = Arc (sam' + f (s - sam')) (sam' + f (e - sam')) - where sam' = sam s + where + sam' = sam s -- | @isIn a t@ is @True@ if @t@ is inside -- the arc represented by @a@. diff --git a/src/Sound/Tidal/Transition.hs b/src/Sound/Tidal/Transition.hs index baf07586..425ed49f 100644 --- a/src/Sound/Tidal/Transition.hs +++ b/src/Sound/Tidal/Transition.hs @@ -2,24 +2,22 @@ module Sound.Tidal.Transition where -import Prelude hiding ((*>), (<*)) - -import Control.Concurrent.MVar (readMVar, swapMVar) - -import qualified Data.Map.Strict as Map +import Control.Concurrent.MVar (readMVar, swapMVar) +import qualified Data.Map.Strict as Map -- import Data.Maybe (fromJust) -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 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 (fadeInFrom, fadeOutFrom) -import Sound.Tidal.Utils (enumerate) +import Sound.Tidal.UI (fadeInFrom, fadeOutFrom) +import Sound.Tidal.Utils (enumerate) +import Prelude hiding ((*>), (<*)) {- Transition.hs - A library for handling transitions between patterns @@ -45,179 +43,179 @@ type TransitionMapper = Time -> [ControlPattern] -> ControlPattern -- the "historyFlag" determines if the new pattern should be placed on the history stack or not 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 {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) (psHistory playState) - let pMap' = Map.insert (fromID patId) (playState {psPattern = pat'}) pMap - _ <- swapMVar (sPMapMV stream) pMap' - return () - + let appendPat flag = if flag then (pat :) else id + 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) (psHistory playState) + let pMap' = Map.insert (fromID patId) (playState {psPattern = pat'}) pMap + _ <- swapMVar (sPMapMV stream) pMap' + return () 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 (x:_) = x - s = sam (now - fromIntegral (floor now `mod` floor t :: Int)) + sam t - -{-| Washes away the current pattern after a certain delay by applying a - function to it over time, then switching over to the next pattern to - which another function is applied. --} +mortalOverlay t now (pat : ps) = overlay (pop ps) (playFor s (s + t) pat) + where + pop [] = silence + pop (x : _) = x + s = sam (now - fromIntegral (floor now `mod` floor t :: Int)) + sam t + +-- | Washes away the current pattern after a certain delay by applying a +-- function to it over time, then switching over to the next pattern to +-- which another function is applied. wash :: (Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Time -> Time -> Time -> Time -> [Pattern a] -> Pattern a wash _ _ _ _ _ _ [] = silence -wash _ _ _ _ _ _ (pat:[]) = pat -wash fout fin delay durin durout now (pat:pat':_) = - stack [(filterWhen (< (now + delay)) pat'), - (filterWhen (between (now + delay) (now + delay + durin)) $ fout pat'), - (filterWhen (between (now + delay + durin) (now + delay + durin + durout)) $ fin pat), - (filterWhen (>= (now + delay + durin + durout)) $ pat) - ] - where - between lo hi x = (x >= lo) && (x < hi) +wash _ _ _ _ _ _ (pat : []) = pat +wash fout fin delay durin durout now (pat : pat' : _) = + stack + [ (filterWhen (< (now + delay)) pat'), + (filterWhen (between (now + delay) (now + delay + durin)) $ fout pat'), + (filterWhen (between (now + delay + durin) (now + delay + durin + durout)) $ fin pat), + (filterWhen (>= (now + delay + durin + durout)) $ pat) + ] + where + between lo hi x = (x >= lo) && (x < hi) washIn :: (Pattern a -> Pattern a) -> Time -> Time -> [Pattern a] -> Pattern a washIn f durin now pats = wash f id 0 durin 0 now pats xfadeIn :: Time -> Time -> [ControlPattern] -> ControlPattern xfadeIn _ _ [] = silence -xfadeIn _ _ (pat:[]) = pat -xfadeIn t now (pat:pat':_) = overlay (pat |* gain (now `rotR` (_slow t envEqR))) (pat' |* gain (now `rotR` (_slow t (envEq)))) +xfadeIn _ _ (pat : []) = pat +xfadeIn t now (pat : pat' : _) = overlay (pat |* gain (now `rotR` (_slow t envEqR))) (pat' |* gain (now `rotR` (_slow t (envEq)))) -- | Pans the last n versions of the pattern across the field histpan :: Int -> Time -> [ControlPattern] -> ControlPattern histpan _ _ [] = silence histpan 0 _ _ = silence -histpan n _ ps = stack $ map (\(i,pat) -> pat # pan (pure $ (fromIntegral i) / (fromIntegral n'))) (enumerate ps') - where ps' = take n ps - n' = length ps' -- in case there's fewer patterns than requested +histpan n _ ps = stack $ map (\(i, pat) -> pat # pan (pure $ (fromIntegral i) / (fromIntegral n'))) (enumerate ps') + where + ps' = take n ps + n' = length ps' -- in case there's fewer patterns than requested -- | Just stop for a bit before playing new pattern wait :: Time -> Time -> [ControlPattern] -> ControlPattern -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 - -@ -d1 $ sound "bd" - -t1 (waitT (xfadeIn 8) 4) $ sound "hh*8" -@ --} +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 +-- +-- @ +-- d1 $ sound "bd" +-- +-- t1 (waitT (xfadeIn 8) 4) $ sound "hh*8" +-- @ waitT :: (Time -> [ControlPattern] -> ControlPattern) -> Time -> Time -> [ControlPattern] -> ControlPattern -waitT _ _ _ [] = silence -waitT f t now pats = filterWhen (>= (nextSam (now+t-1))) (f (now + t) pats) +waitT _ _ _ [] = silence +waitT f t now pats = filterWhen (>= (nextSam (now + t - 1))) (f (now + t) pats) -{- | -Jumps directly into the given pattern, this is essentially the _no transition_-transition. - -Variants of @jump@ provide more useful capabilities, see @jumpIn@ and @jumpMod@ --} +-- | +-- Jumps directly into the given pattern, this is essentially the _no transition_-transition. +-- +-- Variants of @jump@ provide more useful capabilities, see @jumpIn@ and @jumpMod@ jump :: Time -> [ControlPattern] -> ControlPattern jump = jumpIn 0 -{- | Sharp `jump` transition after the specified number of cycles have passed. - -@ -t1 (jumpIn 2) $ sound "kick(3,8)" -@ --} +-- | Sharp `jump` transition after the specified number of cycles have passed. +-- +-- @ +-- t1 (jumpIn 2) $ sound "kick(3,8)" +-- @ jumpIn :: Int -> Time -> [ControlPattern] -> ControlPattern jumpIn n = wash id id (fromIntegral n) 0 0 -{- | Unlike `jumpIn` the variant `jumpIn'` will only transition at cycle boundary (e.g. when the cycle count is an integer). --} +-- | Unlike `jumpIn` the variant `jumpIn'` will only transition at cycle boundary (e.g. when the cycle count is an integer). jumpIn' :: Int -> Time -> [ControlPattern] -> ControlPattern jumpIn' n now = wash id id ((nextSam now) - now + (fromIntegral n)) 0 0 now -- | Sharp `jump` transition at next cycle boundary where cycle mod n == 0 jumpMod :: Int -> Time -> [ControlPattern] -> ControlPattern -jumpMod n now = jumpIn' ((n-1) - ((floor now) `mod` n)) now +jumpMod n now = jumpIn' ((n - 1) - ((floor now) `mod` n)) now -- | Sharp `jump` transition at next cycle boundary where cycle mod n == p jumpMod' :: Int -> Int -> Time -> [ControlPattern] -> ControlPattern -jumpMod' n p now = Sound.Tidal.Transition.jumpIn' ((n-1) - ((floor now) `mod` n) + p) now +jumpMod' n p now = Sound.Tidal.Transition.jumpIn' ((n - 1) - ((floor now) `mod` n) + p) now -- | Degrade the new pattern over time until it ends in silence mortal :: Time -> Time -> Time -> [ControlPattern] -> ControlPattern mortal _ _ _ [] = silence -mortal lifespan release now (p:_) = overlay (filterWhen (<(now+lifespan)) p) (filterWhen (>= (now+lifespan)) (fadeOutFrom (now + lifespan) release p)) - +mortal lifespan release now (p : _) = overlay (filterWhen (< (now + lifespan)) p) (filterWhen (>= (now + lifespan)) (fadeOutFrom (now + lifespan) release p)) interpolate :: Time -> [ControlPattern] -> ControlPattern interpolate = interpolateIn 4 interpolateIn :: Time -> Time -> [ControlPattern] -> ControlPattern interpolateIn _ _ [] = silence -interpolateIn _ _ (p:[]) = p -interpolateIn t now (pat:pat':_) = f <$> pat' *> pat <* automation - where automation = now `rotR` (_slow t envL) - f = (\a b x -> Map.unionWith (fNum2 (\a' b' -> floor $ (fromIntegral a') * x + (fromIntegral b') * (1-x)) - (\a' b' -> a' * x + b' * (1-x)) - ) - b a +interpolateIn _ _ (p : []) = p +interpolateIn t now (pat : pat' : _) = f <$> pat' *> pat <* automation + where + automation = now `rotR` (_slow t envL) + f = + ( \a b x -> + Map.unionWith + ( fNum2 + (\a' b' -> floor $ (fromIntegral a') * x + (fromIntegral b') * (1 - x)) + (\a' b' -> a' * x + b' * (1 - x)) ) - -{-| -Degrades the current pattern while undegrading the next. - -This is like @xfade@ but not by gain of samples but by randomly removing events from the current pattern and slowly adding back in missing events from the next one. - -@ -d1 $ sound "bd(3,8)" - -t1 clutch $ sound "[hh*4, odx(3,8)]" -@ - -@clutch@ takes two cycles for the transition, essentially this is @clutchIn 2@. --} + b + a + ) + +-- | +-- Degrades the current pattern while undegrading the next. +-- +-- This is like @xfade@ but not by gain of samples but by randomly removing events from the current pattern and slowly adding back in missing events from the next one. +-- +-- @ +-- d1 $ sound "bd(3,8)" +-- +-- t1 clutch $ sound "[hh*4, odx(3,8)]" +-- @ +-- +-- @clutch@ takes two cycles for the transition, essentially this is @clutchIn 2@. clutch :: Time -> [Pattern a] -> Pattern a clutch = clutchIn 2 -{-| -Also degrades the current pattern and undegrades the next. -To change the number of cycles the transition takes, you can use @clutchIn@ like so: - -@ -d1 $ sound "bd(5,8)" - -t1 (clutchIn 8) $ sound "[hh*4, odx(3,8)]" -@ - -will take 8 cycles for the transition. --} +-- | +-- Also degrades the current pattern and undegrades the next. +-- To change the number of cycles the transition takes, you can use @clutchIn@ like so: +-- +-- @ +-- d1 $ sound "bd(5,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 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.: - -@ -d1 $ sound "jvbass(3,8)" - -t1 (anticipateIn 4) $ sound "jvbass(5,8)" -@-} +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.: +-- +-- @ +-- d1 $ sound "jvbass(3,8)" +-- +-- t1 (anticipateIn 4) $ sound "jvbass(5,8)" +-- @ anticipateIn :: Time -> Time -> [ControlPattern] -> ControlPattern anticipateIn t now pats = washIn (innerJoin . (\pat -> (\v -> _stut 8 0.2 v pat) <$> (now `rotR` (_slow t $ toRational <$> envLR)))) t now pats -- wash :: (Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Time -> Time -> Time -> Time -> [Pattern a] -> Pattern a -{- | `anticipate` is an increasing comb filter. - -Build up some tension, culminating in a _drop_ to the new pattern after 8 cycles. --} +-- | `anticipate` is an increasing comb filter. +-- +-- Build up some tension, culminating in a _drop_ to the new pattern after 8 cycles. anticipate :: Time -> [ControlPattern] -> ControlPattern anticipate = anticipateIn 8 diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs index a297d271..70900fa7 100644 --- a/src/Sound/Tidal/UI.hs +++ b/src/Sound/Tidal/UI.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} {- @@ -21,67 +21,71 @@ along with this library. If not, see . -} -{-| - This module provides the main user interface functions, including sources - of randomness and transformations of patterns. All these functions are available - in the context of the TidalCycles REPL. - - Many functions in this module taking 'Pattern' values as arguments have a - corresponding function with an underscore prepended to its name (e.g. - 'degradeBy' and '_degradeBy'). These functions accept plain values, not - 'Pattern's, and are generally intended for those developing or extending Tidal. - --} - +-- | +-- This module provides the main user interface functions, including sources +-- of randomness and transformations of patterns. All these functions are available +-- in the context of the TidalCycles REPL. +-- +-- Many functions in this module taking 'Pattern' values as arguments have a +-- corresponding function with an underscore prepended to its name (e.g. +-- 'degradeBy' and '_degradeBy'). These functions accept plain values, not +-- 'Pattern's, and are generally intended for those developing or extending Tidal. module Sound.Tidal.UI where -import Prelude hiding ((*>), (<*)) - -import Data.Bits (Bits, shiftL, shiftR, testBit, xor) -import Data.Char (digitToInt, isDigit, ord) - -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 Sound.Tidal.Pattern -import Sound.Tidal.Utils +import Data.Bits (Bits, shiftL, shiftR, testBit, xor) +import Data.Bool (bool) +import Data.Char (digitToInt, isDigit, ord) +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 Sound.Tidal.Pattern +import Sound.Tidal.Utils +import Prelude hiding ((*>), (<*)) ------------------------------------------------------------------------ + -- * UI -- ** Randomisation - -{-| -An implementation of the well-known @xorshift@ random number generator. -Given a seed number, generates a reasonably random number out of it. -This is an efficient algorithm suitable for use in tight loops and used -to implement the below functions, which are used to implement 'rand'. - -See George Marsaglia (2003). ["Xorshift RNGs"](https://www.jstatsoft.org/article/view/v008i14), -in Journal of Statistical Software, pages 8–14. - --} +-- | +-- An implementation of the well-known @xorshift@ random number generator. +-- Given a seed number, generates a reasonably random number out of it. +-- This is an efficient algorithm suitable for use in tight loops and used +-- to implement the below functions, which are used to implement 'rand'. +-- +-- See George Marsaglia (2003). ["Xorshift RNGs"](https://www.jstatsoft.org/article/view/v008i14), +-- in Journal of Statistical Software, pages 8–14. xorwise :: Int -> Int xorwise x = let a = xor (shiftL x 13) x b = xor (shiftR a 17) a - in xor (shiftL b 5) b + in xor (shiftL b 5) b -- stretch 300 cycles over the range of [0,2**29 == 536870912) then apply the xorshift algorithm timeToIntSeed :: RealFrac a => a -> Int -timeToIntSeed = xorwise . truncate . (* 536870912) . snd . (properFraction :: (RealFrac a => a -> (Int,a))) . (/ 300) +timeToIntSeed = xorwise . truncate . (* 536870912) . snd . (properFraction :: (RealFrac a => a -> (Int, a))) . (/ 300) intSeedToRand :: Fractional a => Int -> a intSeedToRand = (/ 536870912) . realToFrac . (`mod` 536870912) @@ -95,41 +99,40 @@ timeToRands t n = timeToRands' (timeToIntSeed t) n timeToRands' :: Fractional a => Int -> Int -> [a] timeToRands' seed n | n <= 0 = [] - | otherwise = (intSeedToRand seed) : (timeToRands' (xorwise seed) (n-1)) + | otherwise = (intSeedToRand seed) : (timeToRands' (xorwise seed) (n - 1)) -{-| - -@rand@ is an oscillator that generates a continuous pattern of (pseudo-)random -numbers between 0 and 1. - -For example, to randomly pan around the stereo field: - -> d1 $ sound "bd*8" # pan rand - -Or to enjoy a randomised speed from 0.5 to 1.5, add 0.5 to it: - -> d1 $ sound "arpy*4" # speed (rand + 0.5) - -To make the snares randomly loud and quiet: - -> sound "sn sn ~ sn" # gain rand - -Numbers coming from this pattern are \'seeded\' by time. So if you reset time -(using 'resetCycles', 'setCycle', or 'cps') the random pattern will emit the -exact same _random_ numbers again. - -In cases where you need two different random patterns, you can shift -one of them around to change the time from which the _random_ pattern -is read, note the difference: - -> jux (# gain rand) $ sound "sn sn ~ sn" # gain rand - -and with the juxed version shifted backwards for 1024 cycles: - -> jux (# ((1024 <~) $ gain rand)) $ sound "sn sn ~ sn" # gain rand --} +-- | +-- +-- @rand@ is an oscillator that generates a continuous pattern of (pseudo-)random +-- numbers between 0 and 1. +-- +-- For example, to randomly pan around the stereo field: +-- +-- > d1 $ sound "bd*8" # pan rand +-- +-- Or to enjoy a randomised speed from 0.5 to 1.5, add 0.5 to it: +-- +-- > d1 $ sound "arpy*4" # speed (rand + 0.5) +-- +-- To make the snares randomly loud and quiet: +-- +-- > sound "sn sn ~ sn" # gain rand +-- +-- Numbers coming from this pattern are \'seeded\' by time. So if you reset time +-- (using 'resetCycles', 'setCycle', or 'cps') the random pattern will emit the +-- exact same _random_ numbers again. +-- +-- In cases where you need two different random patterns, you can shift +-- one of them around to change the time from which the _random_ pattern +-- is read, note the difference: +-- +-- > jux (# gain rand) $ sound "sn sn ~ sn" # gain rand +-- +-- 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 @@ -142,220 +145,210 @@ brandBy probpat = innerJoin $ (\prob -> _brandBy prob) <$> probpat _brandBy :: Double -> Pattern Bool _brandBy prob = fmap (< prob) rand -{- | Just like `rand` but for whole numbers, @irand n@ generates a pattern of (pseudo-) random whole numbers between @0@ to @n-1@ inclusive. Notably used to pick a random -samples from a folder: - -@ -d1 $ segment 4 $ n (irand 5) # sound "drum" -@ --} +-- | Just like `rand` but for whole numbers, @irand n@ generates a pattern of (pseudo-) random whole numbers between @0@ to @n-1@ inclusive. Notably used to pick a random +-- samples from a folder: +-- +-- @ +-- d1 $ segment 4 $ n (irand 5) # sound "drum" +-- @ irand :: Num a => Pattern Int -> Pattern a irand = (>>= _irand) _irand :: Num a => Int -> Pattern a _irand i = fromIntegral . (floor :: Double -> Int) . (* fromIntegral i) <$> rand -{- | 1D Perlin (smooth) noise, works like 'rand' but smoothly moves between random -values each cycle. @perlinWith@ takes a pattern as the random number generator's -"input" instead of automatically using the cycle count. - -> d1 $ s "arpy*32" # cutoff (perlinWith (saw * 4) * 2000) - -will generate a smooth random pattern for the cutoff frequency which will -repeat every cycle (because the saw does). - -The `perlin` function uses the cycle count as input and can be used much like @rand@. --} +-- | 1D Perlin (smooth) noise, works like 'rand' but smoothly moves between random +-- values each cycle. @perlinWith@ takes a pattern as the random number generator's +-- "input" instead of automatically using the cycle count. +-- +-- > d1 $ s "arpy*32" # cutoff (perlinWith (saw * 4) * 2000) +-- +-- will generate a smooth random pattern for the cutoff frequency which will +-- repeat every cycle (because the saw does). +-- +-- The `perlin` function uses the cycle count as input and can be used much like @rand@. perlinWith :: Fractional a => Pattern Double -> Pattern a -perlinWith p = fmap realToFrac $ (interp) <$> (p-pa) <*> (timeToRand <$> pa) <*> (timeToRand <$> pb) where - pa = (fromIntegral :: Int -> Double) . floor <$> p - pb = (fromIntegral :: Int -> Double) . (+1) . floor <$> p - interp x a b = a + smootherStep x * (b-a) - smootherStep x = 6.0 * x**5 - 15.0 * x**4 + 10.0 * x**3 - -{- | As 'perlin' with a suitable choice of input pattern (@'sig' 'fromRational'@). - - The @perlin@ function produces a new random value to move to every cycle. If - you want a new random value to be generated more or less frequently, you can use - fast or slow, respectively: +perlinWith p = fmap realToFrac $ (interp) <$> (p - pa) <*> (timeToRand <$> pa) <*> (timeToRand <$> pb) + where + pa = (fromIntegral :: Int -> Double) . floor <$> p + pb = (fromIntegral :: Int -> Double) . (+ 1) . floor <$> p + interp x a b = a + smootherStep x * (b - a) + smootherStep x = 6.0 * x ** 5 - 15.0 * x ** 4 + 10.0 * x ** 3 - > d1 $ sound "bd*32" # speed (fast 4 $ perlin + 0.5) - > d1 $ sound "bd*32" # speed (slow 4 $ perlin + 0.5) --} +-- | As 'perlin' with a suitable choice of input pattern (@'sig' 'fromRational'@). +-- +-- The @perlin@ function produces a new random value to move to every cycle. If +-- you want a new random value to be generated more or less frequently, you can use +-- fast or slow, respectively: +-- +-- > d1 $ sound "bd*32" # speed (fast 4 $ perlin + 0.5) +-- > d1 $ sound "bd*32" # speed (slow 4 $ perlin + 0.5) perlin :: Fractional a => Pattern a perlin = perlinWith (sig fromRational) -{-| @perlin2With@ is Perlin noise with a 2-dimensional input. This can be -useful for more control over how the randomness repeats (or doesn't). - -@ -d1 - $ s "[supersaw:-12*32]" - # lpf (rangex 60 5000 $ perlin2With (cosine*2) (sine*2)) - # lpq 0.3 -@ - -The above will generate a smooth random cutoff pattern that repeats every cycle -without any reversals or discontinuities (because the 2D path is a circle). - -See also: `perlin2`, which only needs one input because it uses the cycle count -as the second input. --} +-- | @perlin2With@ is Perlin noise with a 2-dimensional input. This can be +-- useful for more control over how the randomness repeats (or doesn't). +-- +-- @ +-- d1 +-- $ s "[supersaw:-12*32]" +-- # lpf (rangex 60 5000 $ perlin2With (cosine*2) (sine*2)) +-- # lpq 0.3 +-- @ +-- +-- The above will generate a smooth random cutoff pattern that repeats every cycle +-- without any reversals or discontinuities (because the 2D path is a circle). +-- +-- See also: `perlin2`, which only needs one input because it uses the cycle count +-- as the second input. perlin2With :: Pattern Double -> Pattern Double -> Pattern Double -perlin2With x y = (/2) . (+1) $ interp2 <$> xfrac <*> yfrac <*> dota <*> dotb <*> dotc <*> dotd where - fl = fmap ((fromIntegral :: Int -> Double) . floor) - ce = fmap ((fromIntegral :: Int -> Double) . (+1) . floor) - xfrac = x - fl x - yfrac = y - fl y - randAngle a b = 2 * pi * timeToRand (a + 0.0001 * b) - pcos x' y' = cos $ randAngle <$> x' <*> y' - psin x' y' = sin $ randAngle <$> x' <*> y' - dota = pcos (fl x) (fl y) * xfrac + psin (fl x) (fl y) * yfrac - dotb = pcos (ce x) (fl y) * (xfrac - 1) + psin (ce x) (fl y) * yfrac - dotc = pcos (fl x) (ce y) * xfrac + psin (fl x) (ce y) * (yfrac - 1) - dotd = pcos (ce x) (ce y) * (xfrac - 1) + psin (ce x) (ce y) * (yfrac - 1) - interp2 x' y' a b c d = (1.0 - s x') * (1.0 - s y') * a + s x' * (1.0 - s y') * b - + (1.0 - s x') * s y' * c + s x' * s y' * d - s x' = 6.0 * x'**5 - 15.0 * x'**4 + 10.0 * x'**3 +perlin2With x y = (/ 2) . (+ 1) $ interp2 <$> xfrac <*> yfrac <*> dota <*> dotb <*> dotc <*> dotd + where + fl = fmap ((fromIntegral :: Int -> Double) . floor) + ce = fmap ((fromIntegral :: Int -> Double) . (+ 1) . floor) + xfrac = x - fl x + yfrac = y - fl y + randAngle a b = 2 * pi * timeToRand (a + 0.0001 * b) + pcos x' y' = cos $ randAngle <$> x' <*> y' + psin x' y' = sin $ randAngle <$> x' <*> y' + dota = pcos (fl x) (fl y) * xfrac + psin (fl x) (fl y) * yfrac + dotb = pcos (ce x) (fl y) * (xfrac - 1) + psin (ce x) (fl y) * yfrac + dotc = pcos (fl x) (ce y) * xfrac + psin (fl x) (ce y) * (yfrac - 1) + dotd = pcos (ce x) (ce y) * (xfrac - 1) + psin (ce x) (ce y) * (yfrac - 1) + interp2 x' y' a b c d = + (1.0 - s x') * (1.0 - s y') * a + s x' * (1.0 - s y') * b + + (1.0 - s x') * s y' * c + + s x' * s y' * d + s x' = 6.0 * x' ** 5 - 15.0 * x' ** 4 + 10.0 * x' ** 3 -- | As 'perlin2' with a suitable choice of input pattern (@'sig' 'fromRational'@). perlin2 :: Pattern Double -> Pattern Double perlin2 = perlin2With (sig fromRational) -{- | Generates values in [0,1] that follows a normal (bell-curve) distribution. -One possible application is to "humanize" drums with a slight random delay: -@ -d1 $ - s "bd sn bd sn" - # nudge (segment 4 (0.01 * normal)) -@ -Implemented with the Box-Muller transform. - * the max ensures we don't calculate log 0 - * the rot in u2 ensures we don't just get the same value as u1 - * clamp the Box-Muller generated values in a [-3,3] range --} +-- | Generates values in [0,1] that follows a normal (bell-curve) distribution. +-- One possible application is to "humanize" drums with a slight random delay: +-- @ +-- d1 $ +-- s "bd sn bd sn" +-- # nudge (segment 4 (0.01 * normal)) +-- @ +-- Implemented with the Box-Muller transform. +-- * the max ensures we don't calculate log 0 +-- * the rot in u2 ensures we don't just get the same value as u1 +-- * clamp the Box-Muller generated values in a [-3,3] range normal :: (Floating a, Ord a) => Pattern a normal = do u1 <- max 0.001 <$> rand u2 <- rotL 1000 rand - let r1 = sqrt $ - (2 * log u1) + let r1 = sqrt $ -(2 * log u1) r2 = cos (2 * pi * u2) clamp n = max (-3) (min 3 n) pure $ clamp (r1 * r2 + 3) / 6 -{- | Randomly picks an element from the given list. - -@ -sound "superpiano(3,8)" # note (choose ["a", "e", "g", "c"]) -@ - -plays a melody randomly choosing one of the four notes \"a\", \"e\", \"g\", \"c\". - -As with all continuous patterns, you have to be careful to give them structure; in this case choose gives you an infinitely detailed stream of random choices. - -> choose = 'chooseBy' 'rand' --} +-- | Randomly picks an element from the given list. +-- +-- @ +-- sound "superpiano(3,8)" # note (choose ["a", "e", "g", "c"]) +-- @ +-- +-- plays a melody randomly choosing one of the four notes \"a\", \"e\", \"g\", \"c\". +-- +-- As with all continuous patterns, you have to be careful to give them structure; in this case choose gives you an infinitely detailed stream of random choices. +-- +-- > choose = 'chooseBy' 'rand' choose :: [a] -> Pattern a choose = chooseBy rand - -{- | Given a pattern of doubles, @chooseBy@ normalizes them so that each -corresponds to an index in the provided list. The returned pattern -contains the corresponding elements in the list. - -It is like choose, but instead of selecting elements of the list randomly, it -uses the given pattern to select elements. - -@'choose' = chooseBy 'rand'@ - -The following results in the pattern @"a b c"@: - -> chooseBy "0 0.25 0.5" ["a","b","c","d"] --} +-- | Given a pattern of doubles, @chooseBy@ normalizes them so that each +-- corresponds to an index in the provided list. The returned pattern +-- contains the corresponding elements in the list. +-- +-- It is like choose, but instead of selecting elements of the list randomly, it +-- uses the given pattern to select elements. +-- +-- @'choose' = chooseBy 'rand'@ +-- +-- The following results in the pattern @"a b c"@: +-- +-- > chooseBy "0 0.25 0.5" ["a","b","c","d"] chooseBy :: Pattern Double -> [a] -> Pattern a chooseBy _ [] = silence chooseBy f xs = (xs !!!) . floor <$> range 0 (fromIntegral $ length xs) f -{- | Like @choose@, but works on an a list of tuples of values and weights - -@ -sound "superpiano(3,8)" # note (wchoose [("a",1), ("e",0.5), ("g",2), ("c",1)]) -@ - -In the above example, the "a" and "c" notes are twice as likely to -play as the "e" note, and half as likely to play as the "g" note. - -> wchoose = 'wchooseBy' 'rand' --} -wchoose :: [(a,Double)] -> Pattern a +-- | Like @choose@, but works on an a list of tuples of values and weights +-- +-- @ +-- sound "superpiano(3,8)" # note (wchoose [("a",1), ("e",0.5), ("g",2), ("c",1)]) +-- @ +-- +-- In the above example, the "a" and "c" notes are twice as likely to +-- play as the "e" note, and half as likely to play as the "g" note. +-- +-- > wchoose = 'wchooseBy' 'rand' +wchoose :: [(a, Double)] -> Pattern a wchoose = wchooseBy rand -{- | Given a pattern of probabilities and a list of @(value, weight)@ pairs, -@wchooseBy@ creates a @'Pattern' value@ by choosing values based on those -probabilities and weighted appropriately by the weights in the list of pairs. --} -wchooseBy :: Pattern Double -> [(a,Double)] -> Pattern a +-- | Given a pattern of probabilities and a list of @(value, weight)@ pairs, +-- @wchooseBy@ creates a @'Pattern' value@ by choosing values based on those +-- probabilities and weighted appropriately by the weights in the list of pairs. +wchooseBy :: Pattern Double -> [(a, Double)] -> Pattern a wchooseBy pat pairs = match <$> pat where - match r = values !! head (findIndices (> (r*total)) cweights) + match r = values !! head (findIndices (> (r * total)) cweights) cweights = scanl1 (+) (map snd pairs) values = map fst pairs total = sum $ map snd pairs -{-| @randcat ps@: does a @slowcat@ on the list of patterns @ps@ but - randomises the order in which they are played. - - > d1 $ sound (randcat ["bd*2 sn", "jvbass*3", "drum*2", "ht mt"]) --} +-- | @randcat ps@: does a @slowcat@ on the list of patterns @ps@ but +-- randomises the order in which they are played. +-- +-- > d1 $ sound (randcat ["bd*2 sn", "jvbass*3", "drum*2", "ht mt"]) randcat :: [Pattern a] -> Pattern a randcat ps = spread' rotL (_segment 1 $ (% 1) . fromIntegral <$> (_irand (length ps) :: Pattern Int)) (slowcat ps) -{-| As 'randcat', but allowing weighted choice. - - In the following, the first pattern is the most likely and will play about half the time, and the last pattern is the less likely, with only a 10% probability. - - > d1 $ sound - > $ wrandcat - > [ ("bd*2 sn", 5), ("jvbass*3", 2), ("drum*2", 2), ("ht mt", 1) ] --} +-- | As 'randcat', but allowing weighted choice. +-- +-- In the following, the first pattern is the most likely and will play about half the time, and the last pattern is the less likely, with only a 10% probability. +-- +-- > d1 $ sound +-- > $ wrandcat +-- > [ ("bd*2 sn", 5), ("jvbass*3", 2), ("drum*2", 2), ("ht mt", 1) ] wrandcat :: [(Pattern a, Double)] -> Pattern a wrandcat ps = unwrap $ wchooseBy (segment 1 rand) ps -{- | @degrade@ randomly removes events from a pattern 50% of the time: - -> d1 $ slow 2 $ degrade $ sound "[[[feel:5*8,feel*3] feel:3*8], feel*4]" -> # accelerate "-6" -> # speed "2" - -The shorthand syntax for @degrade@ is a question mark: @?@. Using @?@ -will allow you to randomly remove events from a portion of a pattern: - -> d1 $ slow 2 $ sound "bd ~ sn bd ~ bd? [sn bd?] ~" - -You can also use @?@ to randomly remove events from entire sub-patterns: - -> d1 $ slow 2 $ sound "[[[feel:5*8,feel*3] feel:3*8]?, feel*4]" --} +-- | @degrade@ randomly removes events from a pattern 50% of the time: +-- +-- > d1 $ slow 2 $ degrade $ sound "[[[feel:5*8,feel*3] feel:3*8], feel*4]" +-- > # accelerate "-6" +-- > # speed "2" +-- +-- The shorthand syntax for @degrade@ is a question mark: @?@. Using @?@ +-- will allow you to randomly remove events from a portion of a pattern: +-- +-- > d1 $ slow 2 $ sound "bd ~ sn bd ~ bd? [sn bd?] ~" +-- +-- You can also use @?@ to randomly remove events from entire sub-patterns: +-- +-- > d1 $ slow 2 $ sound "[[[feel:5*8,feel*3] feel:3*8]?, feel*4]" degrade :: Pattern a -> Pattern a degrade = _degradeBy 0.5 -{- | -Similar to `degrade`, @degradeBy@ allows you to control the percentage of events that -are removed. For example, to remove events 90% of the time: - -@ -d1 $ slow 2 $ degradeBy 0.9 $ sound "[[[feel:5*8,feel*3] feel:3*8], feel*4]" - # accelerate "-6" - # speed "2" -@ - -You can also invoke this behavior in the shorthand notation by specifying a percentage, as a -number between 0 and 1, after the question mark: - -@ -d1 $ s "bd hh?0.8 bd hh?0.4" -@ --} +-- | +-- Similar to `degrade`, @degradeBy@ allows you to control the percentage of events that +-- are removed. For example, to remove events 90% of the time: +-- +-- @ +-- d1 $ slow 2 $ degradeBy 0.9 $ sound "[[[feel:5*8,feel*3] feel:3*8], feel*4]" +-- # accelerate "-6" +-- # speed "2" +-- @ +-- +-- You can also invoke this behavior in the shorthand notation by specifying a percentage, as a +-- number between 0 and 1, after the question mark: +-- +-- @ +-- d1 $ s "bd hh?0.8 bd hh?0.4" +-- @ degradeBy :: Pattern Double -> Pattern a -> Pattern a degradeBy = patternify' _degradeBy @@ -366,10 +359,9 @@ _degradeBy = _degradeByUsing rand _degradeByUsing :: Pattern Double -> Double -> Pattern a -> Pattern a _degradeByUsing prand x p = fmap fst $ filterValues ((> x) . snd) $ (,) <$> p <* prand -{-| -As 'degradeBy', but the pattern of probabilities represents the chances to retain rather -than remove the corresponding element. --} +-- | +-- As 'degradeBy', but the pattern of probabilities represents the chances to retain rather +-- than remove the corresponding element. unDegradeBy :: Pattern Double -> Pattern a -> Pattern a unDegradeBy = patternify' _unDegradeBy @@ -379,40 +371,37 @@ _unDegradeBy x p = fmap fst $ filterValues ((<= x) . snd) $ (,) <$> p <* rand degradeOverBy :: Int -> Pattern Double -> Pattern a -> Pattern a degradeOverBy i tx p = unwrap $ (\x -> fmap fst $ filterValues ((> x) . snd) $ (,) <$> p <* fastRepeatCycles i rand) <$> slow (fromIntegral i) tx - -{- | Use @sometimesBy@ to apply a given function "sometimes". For example, the -following code results in @density 2@ being applied about 25% of the time: - -@ -d1 $ sometimesBy 0.25 (density 2) $ sound "bd*8" -@ - -There are some aliases as well: - -@ -'sometimes' = sometimesBy 0.5 -'often' = sometimesBy 0.75 -'rarely' = sometimesBy 0.25 -'almostNever' = sometimesBy 0.1 -'almostAlways' = sometimesBy 0.9 -@ --} +-- | Use @sometimesBy@ to apply a given function "sometimes". For example, the +-- following code results in @density 2@ being applied about 25% of the time: +-- +-- @ +-- d1 $ sometimesBy 0.25 (density 2) $ sound "bd*8" +-- @ +-- +-- There are some aliases as well: +-- +-- @ +-- 'sometimes' = sometimesBy 0.5 +-- 'often' = sometimesBy 0.75 +-- 'rarely' = sometimesBy 0.25 +-- 'almostNever' = sometimesBy 0.1 +-- 'almostAlways' = sometimesBy 0.9 +-- @ sometimesBy :: Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a sometimesBy x f pat = overlay (degradeBy x pat) (f $ unDegradeBy x pat) -{- | As 'sometimesBy', but applies the given transformation to the pattern in its entirety -before filtering its actual appearances. Less efficient than 'sometimesBy' but may -be useful when the passed pattern transformation depends on properties of the -pattern before probabilities are taken into account. - -@ -'sometimes'' = sometimesBy' 0.5 -'often'' = sometimesBy' 0.75 -'rarely'' = sometimesBy' 0.25 -'almostNever'' = sometimesBy' 0.1 -'almostAlways'' = sometimesBy' 0.9 -@ --} +-- | As 'sometimesBy', but applies the given transformation to the pattern in its entirety +-- before filtering its actual appearances. Less efficient than 'sometimesBy' but may +-- be useful when the passed pattern transformation depends on properties of the +-- pattern before probabilities are taken into account. +-- +-- @ +-- 'sometimes'' = sometimesBy' 0.5 +-- 'often'' = sometimesBy' 0.75 +-- 'rarely'' = sometimesBy' 0.25 +-- 'almostNever'' = sometimesBy' 0.1 +-- 'almostAlways'' = sometimesBy' 0.9 +-- @ sometimesBy' :: Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a sometimesBy' x f pat = overlay (degradeBy x pat) (unDegradeBy x $ f pat) @@ -456,36 +445,33 @@ almostAlways = sometimesBy 0.9 almostAlways' :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a almostAlways' = sometimesBy' 0.9 -{-| -Never apply a transformation, returning the pattern unmodified. - -@never = flip const@ --} - +-- | +-- Never apply a transformation, returning the pattern unmodified. +-- +-- @never = flip const@ never :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a never = flip const -{-| -Apply the transformation to the pattern unconditionally. - -@always = id@ --} +-- | +-- Apply the transformation to the pattern unconditionally. +-- +-- @always = id@ always :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a always = id -{- | @someCyclesBy@ is a cycle-by-cycle version of @'sometimesBy'@. - - For example the following will either distort all of the events in a cycle, or - none of them: - - > d1 $ someCyclesBy 0.5 (# crush 2) $ n "0 1 [~ 2] 3" # sound "arpy" --} +-- | @someCyclesBy@ is a cycle-by-cycle version of @'sometimesBy'@. +-- +-- For example the following will either distort all of the events in a cycle, or +-- none of them: +-- +-- > d1 $ someCyclesBy 0.5 (# crush 2) $ n "0 1 [~ 2] 3" # sound "arpy" someCyclesBy :: Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a someCyclesBy pd f pat = innerJoin $ (\d -> _someCyclesBy d f pat) <$> pd _someCyclesBy :: Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a _someCyclesBy x = when test - where test c = timeToRand (fromIntegral c :: Double) < x + where + test c = timeToRand (fromIntegral c :: Double) < x -- | Alias of 'someCyclesBy'. somecyclesBy :: Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a @@ -500,85 +486,82 @@ somecycles :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a somecycles = someCycles -- ** Pattern transformations + -- + -- $patternTransformations -- -- Pattern transformations are functions generally of type -- @'Pattern' a -> 'Pattern' a@. This means they take a pattern of any type -- and return a pattern of that type. -{-| -@brak@ makes a pattern sound a bit like a breakbeat. It does this by, every -other cycle, squashing the pattern to fit half a cycle, and offsetting it by a -quarter of a cycle. - -@ -d1 $ sound (brak "bd sn kurt") -d1 $ brak $ sound "[feel feel:3, hc:3 hc:2 hc:4 ho:1]" -@ --} +-- | +-- @brak@ makes a pattern sound a bit like a breakbeat. It does this by, every +-- other cycle, squashing the pattern to fit half a cycle, and offsetting it by a +-- quarter of a cycle. +-- +-- @ +-- d1 $ sound (brak "bd sn kurt") +-- d1 $ brak $ sound "[feel feel:3, hc:3 hc:2 hc:4 ho:1]" +-- @ brak :: Pattern a -> Pattern a -brak = when ((== 1) . (`mod` 2)) (((1%4) `rotR`) . (\x -> fastcat [x, silence])) +brak = when ((== 1) . (`mod` 2)) (((1 % 4) `rotR`) . (\x -> fastcat [x, silence])) -{- | Divides a pattern into a given number of subdivisions, plays the subdivisions -in order, but increments the starting subdivision each cycle. The pattern -wraps to the first subdivision after the last subdivision is played. - -Example: - -@ -d1 $ iter 4 $ sound "bd hh sn cp" -@ - -This will produce the following over four cycles: - -@ -bd hh sn cp -hh sn cp bd -sn cp bd hh -cp bd hh sn -@ - -There is also `iter'`, which shifts the pattern in the opposite direction. - --} +-- | Divides a pattern into a given number of subdivisions, plays the subdivisions +-- in order, but increments the starting subdivision each cycle. The pattern +-- wraps to the first subdivision after the last subdivision is played. +-- +-- Example: +-- +-- @ +-- d1 $ iter 4 $ sound "bd hh sn cp" +-- @ +-- +-- This will produce the following over four cycles: +-- +-- @ +-- bd hh sn cp +-- hh sn cp bd +-- sn cp bd hh +-- cp bd hh sn +-- @ +-- +-- There is also `iter'`, which shifts the pattern in the opposite direction. iter :: Pattern Int -> Pattern c -> Pattern c 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)] +_iter n p = slowcat $ map (\i -> (fromIntegral i % fromIntegral n) `rotL` p) [0 .. (n - 1)] -{- | @iter'@ is the same as @iter@, but decrements the starting -subdivision instead of incrementing it. For example, - -@ -d1 $ iter' 4 $ sound "bd hh sn cp" -@ - -produces - -@ -bd hh sn cp -cp bd hh sn -sn cp bd hh -hh sn cp bd -@ --} +-- | @iter'@ is the same as @iter@, but decrements the starting +-- subdivision instead of incrementing it. For example, +-- +-- @ +-- d1 $ iter' 4 $ sound "bd hh sn cp" +-- @ +-- +-- produces +-- +-- @ +-- bd hh sn cp +-- cp bd hh sn +-- sn cp bd hh +-- hh sn cp bd +-- @ iter' :: Pattern Int -> Pattern c -> Pattern c iter' = patternify' _iter' _iter' :: Int -> Pattern a -> Pattern a -_iter' n p = slowcat $ map (\i -> (fromIntegral i % fromIntegral n) `rotR` p) [0 .. (n-1)] - -{- | @palindrome p@ applies @rev@ to @p@ every other cycle, so that the pattern -alternates between forwards and backwards. For example, these are equivalent: +_iter' n p = slowcat $ map (\i -> (fromIntegral i % fromIntegral n) `rotR` p) [0 .. (n - 1)] -@ -d1 $ palindrome $ sound "arpy:0 arpy:1 arpy:2 arpy:3" -d1 $ slow 2 $ sound "arpy:0 arpy:1 arpy:2 arpy:3 arpy:3 arpy:2 arpy:1 arpy:0" -d1 $ every 2 rev $ sound "arpy:0 arpy:1 arpy:2 arpy:3" -@ --} +-- | @palindrome p@ applies @rev@ to @p@ every other cycle, so that the pattern +-- alternates between forwards and backwards. For example, these are equivalent: +-- +-- @ +-- d1 $ palindrome $ sound "arpy:0 arpy:1 arpy:2 arpy:3" +-- d1 $ slow 2 $ sound "arpy:0 arpy:1 arpy:2 arpy:3 arpy:3 arpy:2 arpy:1 arpy:0" +-- d1 $ every 2 rev $ sound "arpy:0 arpy:1 arpy:2 arpy:3" +-- @ palindrome :: Pattern a -> Pattern a palindrome p = slowAppend p (rev p) @@ -599,46 +582,45 @@ fadeIn dur p = innerJoin $ (`_degradeBy` p) <$> _slow dur envLR fadeInFrom :: Time -> Time -> Pattern a -> Pattern a fadeInFrom from dur p = innerJoin $ (`_degradeBy` p) <$> (from `rotR` _slow dur envLR) -{- | The 'spread' function allows you to take a pattern transformation -which takes a parameter, such as `slow`, and provide several -parameters which are switched between. In other words it "spreads" a -function across several values. - -Taking a simple high hat loop as an example: - -> d1 $ sound "ho ho:2 ho:3 hc" - -We can slow it down by different amounts, such as by a half: - -> d1 $ slow 2 $ sound "ho ho:2 ho:3 hc" - -Or by four thirds (i.e. speeding it up by a third; @4%3@ means four over -three): - -> d1 $ slow (4%3) $ sound "ho ho:2 ho:3 hc" - -But if we use `spread`, we can make a pattern which alternates between -the two speeds: - -> d1 $ spread slow [2,4%3] $ sound "ho ho:2 ho:3 hc" - -Note that if you pass @($)@ as the function to spread values over, you -can put functions as the list of values. ('spreadf' is an alias for @spread ($)@.) -For example: - -> d1 $ spread ($) [density 2, rev, slow 2, striate 3, (# speed "0.8")] -> $ sound "[bd*2 [~ bd]] [sn future]*2 cp jvbass*4" - -Above, the pattern will have these transforms applied to it, one at a time, per cycle: - -* cycle 1: @density 2@ - pattern will increase in speed -* cycle 2: @rev@ - pattern will be reversed -* cycle 3: @slow 2@ - pattern will decrease in speed -* cycle 4: @striate 3@ - pattern will be granualized -* cycle 5: @(# speed "0.8")@ - pattern samples will be played back more slowly - -After @(# speed "0.8")@, the transforms will repeat and start at @density 2@ again. --} +-- | The 'spread' function allows you to take a pattern transformation +-- which takes a parameter, such as `slow`, and provide several +-- parameters which are switched between. In other words it "spreads" a +-- function across several values. +-- +-- Taking a simple high hat loop as an example: +-- +-- > d1 $ sound "ho ho:2 ho:3 hc" +-- +-- We can slow it down by different amounts, such as by a half: +-- +-- > d1 $ slow 2 $ sound "ho ho:2 ho:3 hc" +-- +-- Or by four thirds (i.e. speeding it up by a third; @4%3@ means four over +-- three): +-- +-- > d1 $ slow (4%3) $ sound "ho ho:2 ho:3 hc" +-- +-- But if we use `spread`, we can make a pattern which alternates between +-- the two speeds: +-- +-- > d1 $ spread slow [2,4%3] $ sound "ho ho:2 ho:3 hc" +-- +-- Note that if you pass @($)@ as the function to spread values over, you +-- can put functions as the list of values. ('spreadf' is an alias for @spread ($)@.) +-- For example: +-- +-- > d1 $ spread ($) [density 2, rev, slow 2, striate 3, (# speed "0.8")] +-- > $ sound "[bd*2 [~ bd]] [sn future]*2 cp jvbass*4" +-- +-- Above, the pattern will have these transforms applied to it, one at a time, per cycle: +-- +-- * cycle 1: @density 2@ - pattern will increase in speed +-- * cycle 2: @rev@ - pattern will be reversed +-- * cycle 3: @slow 2@ - pattern will decrease in speed +-- * cycle 4: @striate 3@ - pattern will be granualized +-- * cycle 5: @(# speed "0.8")@ - pattern samples will be played back more slowly +-- +-- After @(# speed "0.8")@, the transforms will repeat and start at @density 2@ again. spread :: (a -> t -> Pattern b) -> [a] -> t -> Pattern b spread f xs p = slowcat $ map (`f` p) xs @@ -646,65 +628,64 @@ spread f xs p = slowcat $ map (`f` p) xs slowspread :: (a -> t -> Pattern b) -> [a] -> t -> Pattern b slowspread = spread -{- | @fastspread@ works the same as `spread`, but the result is squashed into a single cycle. If you gave four values to @spread@, then the result would seem to speed up by a factor of four. Compare these two: - -> d1 $ spread chop [4,64,32,16] $ sound "ho ho:2 ho:3 hc" -> d1 $ fastspread chop [4,64,32,16] $ sound "ho ho:2 ho:3 hc" - -There is also `slowspread`, which is an alias of @spread@. --} +-- | @fastspread@ works the same as `spread`, but the result is squashed into a single cycle. If you gave four values to @spread@, then the result would seem to speed up by a factor of four. Compare these two: +-- +-- > d1 $ spread chop [4,64,32,16] $ sound "ho ho:2 ho:3 hc" +-- > d1 $ fastspread chop [4,64,32,16] $ sound "ho ho:2 ho:3 hc" +-- +-- There is also `slowspread`, which is an alias of @spread@. fastspread :: (a -> t -> Pattern b) -> [a] -> t -> Pattern b fastspread f xs p = fastcat $ map (`f` p) xs -{- | There's a version of this function, `spread'` (pronounced "spread prime"), which takes a /pattern/ of parameters, instead of a list: - -> d1 $ spread' slow "2 4%3" $ sound "ho ho:2 ho:3 hc" - -This is quite a messy area of Tidal—due to a slight difference of -implementation this sounds completely different! One advantage of -using `spread'` though is that you can provide polyphonic parameters, e.g.: - -> d1 $ spread' slow "[2 4%3, 3]" $ sound "ho ho:2 ho:3 hc" --} +-- | There's a version of this function, `spread'` (pronounced "spread prime"), which takes a /pattern/ of parameters, instead of a list: +-- +-- > d1 $ spread' slow "2 4%3" $ sound "ho ho:2 ho:3 hc" +-- +-- This is quite a messy area of Tidal—due to a slight difference of +-- implementation this sounds completely different! One advantage of +-- using `spread'` though is that you can provide polyphonic parameters, e.g.: +-- +-- > d1 $ spread' slow "[2 4%3, 3]" $ sound "ho ho:2 ho:3 hc" spread' :: Monad m => (a -> b -> m c) -> m a -> b -> m c spread' f vpat pat = vpat >>= \v -> f v pat -{- | @spreadChoose f xs p@ is similar to `slowspread` but picks values from -@xs@ at random, rather than cycling through them in order. - -> d1 $ spreadChoose ($) [gap 4, striate 4] $ sound "ho ho:2 ho:3 hc" --} +-- | @spreadChoose f xs p@ is similar to `slowspread` but picks values from +-- @xs@ at random, rather than cycling through them in order. +-- +-- > d1 $ spreadChoose ($) [gap 4, striate 4] $ sound "ho ho:2 ho:3 hc" spreadChoose :: (t -> t1 -> Pattern b) -> [t] -> t1 -> Pattern b -spreadChoose f vs p = do v <- _segment 1 (choose vs) - f v p +spreadChoose f vs p = do + v <- _segment 1 (choose vs) + f v p -- | A shorter alias for 'spreadChoose'. spreadr :: (t -> t1 -> Pattern b) -> [t] -> t1 -> Pattern b spreadr = spreadChoose -{-| Decide whether to apply one or another function depending on the result of a test function, which is passed the current cycle as a number. - -@ -d1 $ ifp ((== 0) . flip mod 2) - (striate 4) - (# coarse "24 48") - $ sound "hh hc" -@ - -This will apply @'striate' 4@ for every /even/ cycle and apply @# coarse "24 48"@ for every /odd/. - -Detail: As you can see the test function is arbitrary and does not rely on -anything Tidal specific. In fact it uses only plain Haskell functionality, that -is: it calculates the modulo of 2 of the current cycle which is either 0 (for -even cycles) or 1. It then compares this value against 0 and returns the result, -which is either @True@ or @False@. This is what the @ifp@ signature's first part -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, pureValue = Nothing} - where q a | test (floor $ start $ arc a) = query (f1 p) a - | otherwise = query (f2 p) a +-- | Decide whether to apply one or another function depending on the result of a test function, which is passed the current cycle as a number. +-- +-- @ +-- d1 $ ifp ((== 0) . flip mod 2) +-- (striate 4) +-- (# coarse "24 48") +-- $ sound "hh hc" +-- @ +-- +-- This will apply @'striate' 4@ for every /even/ cycle and apply @# coarse "24 48"@ for every /odd/. +-- +-- Detail: As you can see the test function is arbitrary and does not rely on +-- anything Tidal specific. In fact it uses only plain Haskell functionality, that +-- is: it calculates the modulo of 2 of the current cycle which is either 0 (for +-- even cycles) or 1. It then compares this value against 0 and returns the result, +-- which is either @True@ or @False@. This is what the @ifp@ signature's first part +-- 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, pureValue = Nothing} + where + q a + | test (floor $ start $ arc a) = query (f1 p) a + | otherwise = query (f2 p) a -- | @wedge t p p'@ combines patterns @p@ and @p'@ by squashing the -- @p@ into the portion of each cycle given by @t@, and @p'@ into the @@ -715,266 +696,257 @@ 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 t p p' = overlay (_fastGap (1/t) p) (t `rotR` _fastGap (1/(1-t)) p') - - -{- | @whenmod@ has a similar form and behavior to `every`, but requires an -additional number. It applies the function to the pattern when the -remainder of the current loop number divided by the first parameter -is greater or equal than the second parameter. - -For example, the following makes every other block of four loops twice -as dense: +_wedge 1 p _ = p +_wedge t p p' = overlay (_fastGap (1 / t) p) (t `rotR` _fastGap (1 / (1 - t)) p') -> d1 $ whenmod 8 4 (density 2) (sound "bd sn kurt") --} +-- | @whenmod@ has a similar form and behavior to `every`, but requires an +-- additional number. It applies the function to the pattern when the +-- remainder of the current loop number divided by the first parameter +-- is greater or equal than the second parameter. +-- +-- For example, the following makes every other block of four loops twice +-- as dense: +-- +-- > d1 $ whenmod 8 4 (density 2) (sound "bd sn kurt") whenmod :: Pattern Time -> Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a whenmod a b f pat = innerJoin $ (\a' b' -> _whenmod a' b' f pat) <$> a <*> b _whenmod :: Time -> Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -_whenmod a b = whenT (\t -> ((t `mod'` a) >= b )) +_whenmod a b = whenT (\t -> ((t `mod'` a) >= b)) - -{- | -> superimpose f p = stack [p, f p] - -@superimpose@ plays a modified version of a pattern at the same time as the -original pattern, resulting in two patterns being played at the same time. The -following are equivalent: - -> d1 $ superimpose (fast 2) $ sound "bd sn [cp ht] hh" -> d1 $ stack [sound "bd sn [cp ht] hh", -> fast 2 $ sound "bd sn [cp ht] hh" -> ] - -More examples: - -> d1 $ superimpose (density 2) $ sound "bd sn [cp ht] hh" -> d1 $ superimpose ((# speed "2") . (0.125 <~)) $ sound "bd sn cp hh" - --} +-- | +-- > superimpose f p = stack [p, f p] +-- +-- @superimpose@ plays a modified version of a pattern at the same time as the +-- original pattern, resulting in two patterns being played at the same time. The +-- following are equivalent: +-- +-- > d1 $ superimpose (fast 2) $ sound "bd sn [cp ht] hh" +-- > d1 $ stack [sound "bd sn [cp ht] hh", +-- > fast 2 $ sound "bd sn [cp ht] hh" +-- > ] +-- +-- More examples: +-- +-- > d1 $ superimpose (density 2) $ sound "bd sn [cp ht] hh" +-- > d1 $ superimpose ((# speed "2") . (0.125 <~)) $ sound "bd sn cp hh" superimpose :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a superimpose f p = stack [p, f p] -{- | @trunc@ truncates a pattern so that only a fraction of the pattern is played. -The following example plays only the first quarter of the pattern: - -> d1 $ trunc 0.25 $ sound "bd sn*2 cp hh*4 arpy bd*2 cp bd*2" - -You can also pattern the first parameter, for example to cycle through three values, one per cycle: - -> d1 $ trunc "<0.75 0.25 1>" $ sound "bd sn:2 [mt rs] hc" --} +-- | @trunc@ truncates a pattern so that only a fraction of the pattern is played. +-- The following example plays only the first quarter of the pattern: +-- +-- > d1 $ trunc 0.25 $ sound "bd sn*2 cp hh*4 arpy bd*2 cp bd*2" +-- +-- You can also pattern the first parameter, for example to cycle through three values, one per cycle: +-- +-- > d1 $ trunc "<0.75 0.25 1>" $ sound "bd sn:2 [mt rs] hc" trunc :: Pattern Time -> Pattern a -> Pattern a trunc = patternify' _trunc _trunc :: Time -> Pattern a -> Pattern a _trunc t = compress (0, t) . zoomArc (Arc 0 t) -{- | @linger@ is similar to `trunc`, in that it truncates a pattern so that -only the first fraction of the pattern is played, but the truncated part of the -pattern loops to fill the remainder of the cycle. - -> d1 $ linger 0.25 $ sound "bd sn*2 cp hh*4 arpy bd*2 cp bd*2" - -For example this repeats the first quarter, so you only hear a single repeating note: - -> d1 $ linger 0.25 $ n "0 2 [3 4] 2" # sound "arpy" - -or slightly more interesting, applied only every fourth cycle: - -> d1 $ every 4 (linger 0.25) $ n "0 2 [3 4] 2" # sound "arpy" - -or to a chopped-up sample: - -> d1 $ every 2 (linger 0.25) $ loopAt 2 $ chop 8 $ sound "breaks125" - -You can also pattern the first parameter, for example to cycle through three -values, one per cycle: - -> d1 $ linger "<0.75 0.25 1>" $ sound "bd sn:2 [mt rs] hc" -> d1 $ linger "<0.25 0.5 1>" $ loopAt 2 $ chop 8 $ sound "breaks125" - -If you give it a negative number, it will linger on the last part of -the pattern, instead of the start of it. E.g. to linger on the last -quarter: - -> d1 $ linger (-0.25) $ sound "bd sn*2 cp hh*4 arpy bd*2 cp bd*2" --} +-- | @linger@ is similar to `trunc`, in that it truncates a pattern so that +-- only the first fraction of the pattern is played, but the truncated part of the +-- pattern loops to fill the remainder of the cycle. +-- +-- > d1 $ linger 0.25 $ sound "bd sn*2 cp hh*4 arpy bd*2 cp bd*2" +-- +-- For example this repeats the first quarter, so you only hear a single repeating note: +-- +-- > d1 $ linger 0.25 $ n "0 2 [3 4] 2" # sound "arpy" +-- +-- or slightly more interesting, applied only every fourth cycle: +-- +-- > d1 $ every 4 (linger 0.25) $ n "0 2 [3 4] 2" # sound "arpy" +-- +-- or to a chopped-up sample: +-- +-- > d1 $ every 2 (linger 0.25) $ loopAt 2 $ chop 8 $ sound "breaks125" +-- +-- You can also pattern the first parameter, for example to cycle through three +-- values, one per cycle: +-- +-- > d1 $ linger "<0.75 0.25 1>" $ sound "bd sn:2 [mt rs] hc" +-- > d1 $ linger "<0.25 0.5 1>" $ loopAt 2 $ chop 8 $ sound "breaks125" +-- +-- If you give it a negative number, it will linger on the last part of +-- the pattern, instead of the start of it. E.g. to linger on the last +-- 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 = patternify' _linger _linger :: Time -> Pattern a -> Pattern a -_linger n p | n < 0 = _fast (1/n) $ zoomArc (Arc (1 + n) 1) p - | otherwise = _fast (1/n) $ zoomArc (Arc 0 n) p - -{- | -Use @within@ to apply a function to only a part of a pattern. It takes two -arguments: a start time and an end time, specified as floats between 0 and 1, -which are applied to the relevant pattern. Note that the second argument must be -greater than the first for the function to have any effect. - -For example, to apply @'fast' 2@ to only the first half of a pattern: - -> d1 $ within (0, 0.5) (fast 2) $ sound "bd*2 sn lt mt hh hh hh hh" - -Or, to apply @(# 'speed' "0.5")@ to only the last quarter of a pattern: - -> d1 $ within (0.75, 1) (# speed "0.5") $ sound "bd*2 sn lt mt hh hh hh hh" --} +_linger n p + | n < 0 = _fast (1 / n) $ zoomArc (Arc (1 + n) 1) p + | otherwise = _fast (1 / n) $ zoomArc (Arc 0 n) p + +-- | +-- Use @within@ to apply a function to only a part of a pattern. It takes two +-- arguments: a start time and an end time, specified as floats between 0 and 1, +-- which are applied to the relevant pattern. Note that the second argument must be +-- greater than the first for the function to have any effect. +-- +-- For example, to apply @'fast' 2@ to only the first half of a pattern: +-- +-- > d1 $ within (0, 0.5) (fast 2) $ sound "bd*2 sn lt mt hh hh hh hh" +-- +-- Or, to apply @(# 'speed' "0.5")@ to only the last quarter of a pattern: +-- +-- > d1 $ within (0.75, 1) (# speed "0.5") $ sound "bd*2 sn lt mt hh hh hh hh" within :: (Time, Time) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -within (s, e) f p = stack [filterWhen (\t -> cyclePos t >= s && cyclePos t < e) $ f p, - filterWhen (\t -> not $ cyclePos t >= s && cyclePos t < e) p - ] +within (s, e) f p = + stack + [ filterWhen (\t -> cyclePos t >= s && cyclePos t < e) $ f p, + filterWhen (\t -> not $ cyclePos t >= s && cyclePos t < e) p + ] withinArc :: Arc -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a withinArc (Arc s e) = within (s, e) -{- | -For many cases, @within'@ will function exactly as within. -The difference between the two occurs when applying functions that change the timing of notes such as 'fast' or '<~'. -within first applies the function to all notes in the cycle, then keeps the results in the specified interval, and then combines it with the old cycle (an "apply split combine" paradigm). -within' first keeps notes in the specified interval, then applies the function to these notes, and then combines it with the old cycle (a "split apply combine" paradigm). - -For example, whereas using the standard version of within - -> d1 $ within (0, 0.25) (fast 2) $ sound "bd hh cp sd" - -sounds like: - -> d1 $ sound "[bd hh] hh cp sd" - -using this alternative version, within' - -> d1 $ within' (0, 0.25) (fast 2) $ sound "bd hh cp sd" - -sounds like: - -> d1 $ sound "[bd bd] hh cp sd" - --} +-- | +-- For many cases, @within'@ will function exactly as within. +-- The difference between the two occurs when applying functions that change the timing of notes such as 'fast' or '<~'. +-- within first applies the function to all notes in the cycle, then keeps the results in the specified interval, and then combines it with the old cycle (an "apply split combine" paradigm). +-- within' first keeps notes in the specified interval, then applies the function to these notes, and then combines it with the old cycle (a "split apply combine" paradigm). +-- +-- For example, whereas using the standard version of within +-- +-- > d1 $ within (0, 0.25) (fast 2) $ sound "bd hh cp sd" +-- +-- sounds like: +-- +-- > d1 $ sound "[bd hh] hh cp sd" +-- +-- using this alternative version, within' +-- +-- > d1 $ within' (0, 0.25) (fast 2) $ sound "bd hh cp sd" +-- +-- sounds like: +-- +-- > d1 $ sound "[bd bd] hh cp sd" within' :: (Time, Time) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a within' a@(s, e) f p = - stack [ filterWhen (\t -> cyclePos t >= s && cyclePos t < e) $ compress a $ f $ zoom a p - , filterWhen (\t -> not $ cyclePos t >= s && cyclePos t < e) p - ] + stack + [ filterWhen (\t -> cyclePos t >= s && cyclePos t < e) $ compress a $ f $ zoom a p, + filterWhen (\t -> not $ cyclePos t >= s && cyclePos t < e) p + ] -{-| -Reverse the part of the pattern sliced out by the @(start, end)@ pair. - -@revArc a = within a rev@ --} +-- | +-- Reverse the part of the pattern sliced out by the @(start, end)@ pair. +-- +-- @revArc a = within a rev@ revArc :: (Time, Time) -> Pattern a -> Pattern a revArc a = within a rev -{- | You can use the @euclid@ function to apply a Euclidean algorithm over a -complex pattern, although the structure of that pattern will be lost: - -> d1 $ euclid 3 8 $ sound "bd*2 [sn cp]" - -In the above, three sounds are picked from the pattern on the right according -to the structure given by the @euclid 3 8@. It ends up picking two @bd@ sounds, a -@cp@ and missing the @sn@ entirely. - -A negative first argument provides the inverse of the euclidean pattern. - -These types of sequences use "Bjorklund's algorithm", which wasn't made for -music but for an application in nuclear physics, which is exciting. More -exciting still is that it is very similar in structure to the one of the first -known algorithms written in Euclid's book of elements in 300 BC. You can read -more about this in the paper -[The Euclidean Algorithm Generates Traditional Musical Rhythms](http://cgm.cs.mcgill.ca/~godfried/publications/banff.pdf) -by Toussaint. Some examples from this paper are included below, -including rotation as a third parameter in some cases (see 'euclidOff'). - -+------------+-----------------------------------------------------------------+ -| Pattern | Example | -+============+=================================================================+ -| (2,5) | A thirteenth century Persian rhythm called Khafif-e-ramal. | -+------------+-----------------------------------------------------------------+ -| (3,4) | The archetypal pattern of the Cumbia from Colombia, as well as | -| | a Calypso rhythm from Trinidad. | -+------------+-----------------------------------------------------------------+ -| (3,5,2) | Another thirteenth century Persian rhythm by the name of | -| | Khafif-e-ramal, as well as a Rumanian folk-dance rhythm. | -+------------+-----------------------------------------------------------------+ -| (3,7) | A Ruchenitza rhythm used in a Bulgarian folk-dance. | -+------------+-----------------------------------------------------------------+ -| (3,8) | The Cuban tresillo pattern. | -+------------+-----------------------------------------------------------------+ -| (4,7) | Another Ruchenitza Bulgarian folk-dance rhythm. | -+------------+-----------------------------------------------------------------+ -| (4,9) | The Aksak rhythm of Turkey. | -+------------+-----------------------------------------------------------------+ -| (4,11) | The metric pattern used by Frank Zappa in his piece titled | -| | Outside Now. | -+------------+-----------------------------------------------------------------+ -| (5,6) | Yields the York-Samai pattern, a popular Arab rhythm. | -+------------+-----------------------------------------------------------------+ -| (5,7) | The Nawakhat pattern, another popular Arab rhythm. | -+------------+-----------------------------------------------------------------+ -| (5,8) | The Cuban cinquillo pattern. | -+------------+-----------------------------------------------------------------+ -| (5,9) | A popular Arab rhythm called Agsag-Samai. | -+------------+-----------------------------------------------------------------+ -| (5,11) | The metric pattern used by Moussorgsky in | -| | Pictures at an Exhibition. | -+------------+-----------------------------------------------------------------+ -| (5,12) | The Venda clapping pattern of a South African children’s song. | -+------------+-----------------------------------------------------------------+ -| (5,16) | The Bossa-Nova rhythm necklace of Brazil. | -+------------+-----------------------------------------------------------------+ -| (7,8) | A typical rhythm played on the Bendir (frame drum). | -+------------+-----------------------------------------------------------------+ -| (7,12) | A common West African bell pattern. | -+------------+-----------------------------------------------------------------+ -| (7,16,14) | A Samba rhythm necklace from Brazil. | -+------------+-----------------------------------------------------------------+ -| (9,16) | A rhythm necklace used in the Central African Republic. | -+------------+-----------------------------------------------------------------+ -| (11,24,14) | A rhythm necklace of the Aka Pygmies of Central Africa. | -+------------+-----------------------------------------------------------------+ -| (13,24,5) | Another rhythm necklace of the Aka Pygmies of the upper Sangha. | -+------------+-----------------------------------------------------------------+ - -There was once a shorter alias @e@ for this function. It has been removed, but you -may see references to it in older Tidal code. --} +-- | You can use the @euclid@ function to apply a Euclidean algorithm over a +-- complex pattern, although the structure of that pattern will be lost: +-- +-- > d1 $ euclid 3 8 $ sound "bd*2 [sn cp]" +-- +-- In the above, three sounds are picked from the pattern on the right according +-- to the structure given by the @euclid 3 8@. It ends up picking two @bd@ sounds, a +-- @cp@ and missing the @sn@ entirely. +-- +-- A negative first argument provides the inverse of the euclidean pattern. +-- +-- These types of sequences use "Bjorklund's algorithm", which wasn't made for +-- music but for an application in nuclear physics, which is exciting. More +-- exciting still is that it is very similar in structure to the one of the first +-- known algorithms written in Euclid's book of elements in 300 BC. You can read +-- more about this in the paper +-- [The Euclidean Algorithm Generates Traditional Musical Rhythms](http://cgm.cs.mcgill.ca/~godfried/publications/banff.pdf) +-- by Toussaint. Some examples from this paper are included below, +-- including rotation as a third parameter in some cases (see 'euclidOff'). +-- +-- +------------+-----------------------------------------------------------------+ +-- | Pattern | Example | +-- +============+=================================================================+ +-- | (2,5) | A thirteenth century Persian rhythm called Khafif-e-ramal. | +-- +------------+-----------------------------------------------------------------+ +-- | (3,4) | The archetypal pattern of the Cumbia from Colombia, as well as | +-- | | a Calypso rhythm from Trinidad. | +-- +------------+-----------------------------------------------------------------+ +-- | (3,5,2) | Another thirteenth century Persian rhythm by the name of | +-- | | Khafif-e-ramal, as well as a Rumanian folk-dance rhythm. | +-- +------------+-----------------------------------------------------------------+ +-- | (3,7) | A Ruchenitza rhythm used in a Bulgarian folk-dance. | +-- +------------+-----------------------------------------------------------------+ +-- | (3,8) | The Cuban tresillo pattern. | +-- +------------+-----------------------------------------------------------------+ +-- | (4,7) | Another Ruchenitza Bulgarian folk-dance rhythm. | +-- +------------+-----------------------------------------------------------------+ +-- | (4,9) | The Aksak rhythm of Turkey. | +-- +------------+-----------------------------------------------------------------+ +-- | (4,11) | The metric pattern used by Frank Zappa in his piece titled | +-- | | Outside Now. | +-- +------------+-----------------------------------------------------------------+ +-- | (5,6) | Yields the York-Samai pattern, a popular Arab rhythm. | +-- +------------+-----------------------------------------------------------------+ +-- | (5,7) | The Nawakhat pattern, another popular Arab rhythm. | +-- +------------+-----------------------------------------------------------------+ +-- | (5,8) | The Cuban cinquillo pattern. | +-- +------------+-----------------------------------------------------------------+ +-- | (5,9) | A popular Arab rhythm called Agsag-Samai. | +-- +------------+-----------------------------------------------------------------+ +-- | (5,11) | The metric pattern used by Moussorgsky in | +-- | | Pictures at an Exhibition. | +-- +------------+-----------------------------------------------------------------+ +-- | (5,12) | The Venda clapping pattern of a South African children’s song. | +-- +------------+-----------------------------------------------------------------+ +-- | (5,16) | The Bossa-Nova rhythm necklace of Brazil. | +-- +------------+-----------------------------------------------------------------+ +-- | (7,8) | A typical rhythm played on the Bendir (frame drum). | +-- +------------+-----------------------------------------------------------------+ +-- | (7,12) | A common West African bell pattern. | +-- +------------+-----------------------------------------------------------------+ +-- | (7,16,14) | A Samba rhythm necklace from Brazil. | +-- +------------+-----------------------------------------------------------------+ +-- | (9,16) | A rhythm necklace used in the Central African Republic. | +-- +------------+-----------------------------------------------------------------+ +-- | (11,24,14) | A rhythm necklace of the Aka Pygmies of Central Africa. | +-- +------------+-----------------------------------------------------------------+ +-- | (13,24,5) | Another rhythm necklace of the Aka Pygmies of the upper Sangha. | +-- +------------+-----------------------------------------------------------------+ +-- +-- There was once a shorter alias @e@ for this function. It has been removed, but you +-- may see references to it in older Tidal code. euclid :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a euclid = patternify2 _euclid _euclid :: Int -> Int -> Pattern a -> Pattern a -_euclid n k a | n >= 0 = fastcat $ fmap (bool silence a) $ bjorklund (n,k) - | otherwise = fastcat $ fmap (bool a silence) $ bjorklund (-n,k) - -{- | - -@euclidFull n k pa pb@ stacks @'euclid' n k pa@ with @'euclidInv' n k pb@. That -is, it plays one pattern on the euclidean rhythm and a different pattern on -the off-beat. - -For example, to implement the traditional flamenco rhythm, you could use hard -claps for the former and soft claps for the latter: +_euclid n k a + | n >= 0 = fastcat $ fmap (bool silence a) $ bjorklund (n, k) + | otherwise = fastcat $ fmap (bool a silence) $ bjorklund (-n, k) -> d1 $ euclidFull 3 7 "realclaps" ("realclaps" # gain 0.8) - --} +-- | +-- +-- @euclidFull n k pa pb@ stacks @'euclid' n k pa@ with @'euclidInv' n k pb@. That +-- is, it plays one pattern on the euclidean rhythm and a different pattern on +-- the off-beat. +-- +-- For example, to implement the traditional flamenco rhythm, you could use hard +-- claps for the former and soft claps for the latter: +-- +-- > d1 $ euclidFull 3 7 "realclaps" ("realclaps" # gain 0.8) euclidFull :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a -> Pattern a -euclidFull n k pa pb = stack [ euclid n k pa, euclidInv n k pb ] +euclidFull n k pa pb = stack [euclid n k pa, euclidInv n k pb] -- | Less expressive than 'euclid' due to its constrained types, but may be more efficient. _euclidBool :: Int -> Int -> Pattern Bool -- TODO: add 'euclidBool'? -_euclidBool n k | n >= 0 = fastFromList $ bjorklund (n,k) - | otherwise = fastFromList $ fmap (not) $ bjorklund (-n,k) +_euclidBool n k + | n >= 0 = fastFromList $ bjorklund (n, k) + | otherwise = fastFromList $ fmap (not) $ bjorklund (-n, k) _euclid' :: Int -> Int -> Pattern a -> Pattern a -_euclid' n k p = fastcat $ map (\x -> if x then p else silence) (bjorklund (n,k)) +_euclid' n k p = fastcat $ map (\x -> if x then p else silence) (bjorklund (n, k)) -{- | -As 'euclid', but taking a third rotational parameter corresponding to the onset -at which to start the rhythm. --} +-- | +-- 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 = patternify3 _euclidOff @@ -984,7 +956,7 @@ eoff = euclidOff _euclidOff :: Int -> Int -> Int -> Pattern a -> Pattern a _euclidOff _ 0 _ _ = silence -_euclidOff n k s p = (rotL $ fromIntegral s%fromIntegral k) (_euclid n k p) +_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 @@ -995,40 +967,40 @@ _euclidOffBool _ 0 _ _ = silence _euclidOffBool n k s p = ((fromIntegral s % fromIntegral k) `rotL`) ((\a b -> if b then a else not a) <$> _euclidBool n k <*> p) distrib :: [Pattern Int] -> Pattern a -> Pattern a -distrib ps p = do p' <- sequence ps - _distrib p' p +distrib ps p = do + p' <- sequence ps + _distrib p' p _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' (True:a) (x:b) = x : distrib' a b - distrib' (False:a) b = False : distrib' a b - layers = map bjorklund . (zip<*>tail) + distrib' [] _ = [] + distrib' (_ : a) [] = False : distrib' a [] + distrib' (True : a) (x : b) = x : 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' -{-| @euclidInv@ fills in the blanks left by `euclid`, i.e., it inverts the -pattern. - -For example, whereas @euclid 3 8 "x"@ produces - -> "x ~ ~ x ~ ~ x ~" - -@euclidInv 3 8 "x"@ produces - -> "~ x x ~ x x ~ x" - -As another example, in - -> d1 $ stack [ euclid 5 8 $ s "bd" -> , euclidInv 5 8 $ s "hh27" -> ] - -the hi-hat event fires on every one of the eight even beats that the bass drum -does not. --} +-- | @euclidInv@ fills in the blanks left by `euclid`, i.e., it inverts the +-- pattern. +-- +-- For example, whereas @euclid 3 8 "x"@ produces +-- +-- > "x ~ ~ x ~ ~ x ~" +-- +-- @euclidInv 3 8 "x"@ produces +-- +-- > "~ x x ~ x x ~ x" +-- +-- As another example, in +-- +-- > d1 $ stack [ euclid 5 8 $ s "bd" +-- > , euclidInv 5 8 $ s "hh27" +-- > ] +-- +-- 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 = patternify2 _euclidInv @@ -1037,9 +1009,9 @@ _euclidInv n k a = _euclid (-n) k a index :: Real b => b -> Pattern b -> Pattern c -> Pattern c index sz indexpat pat = - spread' (zoom' $ toRational sz) (toRational . (*(1-sz)) <$> indexpat) pat + spread' (zoom' $ toRational sz) (toRational . (* (1 - sz)) <$> indexpat) pat where - zoom' tSz s = zoomArc (Arc s (s+tSz)) + zoom' tSz s = zoomArc (Arc s (s + tSz)) {- -- | @prrw f rot (blen, vlen) beatPattern valuePattern@: pattern rotate/replace. @@ -1142,61 +1114,65 @@ pequal :: Ord a => Time -> Pattern a -> Pattern a -> Bool pequal cycles p1 p2 = (sort $ arc p1 (0, cycles)) == (sort $ arc p2 (0, cycles)) -} -{- | @rot n p@ "rotates" the values in a pattern @p@ by @n@ beats to the left, -preserving its structure. For example, in the following, each value will shift -to its neighbour's position one step to the left, so that @b@ takes the place of -@a@, @a@ of @c@, and @c@ of @b@: - -> rot 1 "a ~ b c" - -The result is equivalent of: - -> "b ~ c a" - -The first parameter is the number of steps, and may be given as a pattern. For example, in - -> d1 $ rot "<0 0 1 3>" $ n "0 ~ 1 2 0 2 ~ 3*2" # sound "drum" - -the pattern will not be rotated for the first two cycles, but will rotate it -by one the third cycle, and by three the fourth cycle. - -Additional example: - -> d1 $ every 4 (rot 2) $ slow 2 $ sound "bd hh hh hh" --} +-- | @rot n p@ "rotates" the values in a pattern @p@ by @n@ beats to the left, +-- preserving its structure. For example, in the following, each value will shift +-- to its neighbour's position one step to the left, so that @b@ takes the place of +-- @a@, @a@ of @c@, and @c@ of @b@: +-- +-- > rot 1 "a ~ b c" +-- +-- The result is equivalent of: +-- +-- > "b ~ c a" +-- +-- The first parameter is the number of steps, and may be given as a pattern. For example, in +-- +-- > d1 $ rot "<0 0 1 3>" $ n "0 ~ 1 2 0 2 ~ 3*2" # sound "drum" +-- +-- the pattern will not be rotated for the first two cycles, but will rotate it +-- by one the third cycle, and by three the fourth cycle. +-- +-- Additional example: +-- +-- > d1 $ every 4 (rot 2) $ slow 2 $ sound "bd hh hh hh" rot :: Ord a => Pattern Int -> Pattern a -> Pattern a 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 _rot i pat = splitQueries $ pat {query = \st -> f st (query pat (st {arc = wholeCycle (arc st)}))} - where -- TODO maybe events with the same arc (part+whole) should be - -- grouped together in the rotation? - f st es = constrainEvents (arc st) $ shiftValues $ sort $ defragParts es - shiftValues es | i >= 0 = - zipWith (\e s -> e {value = s}) es - (drop i $ cycle $ map value es) - | otherwise = - zipWith (\e s -> e{value = s}) es - (drop (length es - abs i) $ cycle $ map value es) - wholeCycle (Arc s _) = Arc (sam s) (nextSam s) - constrainEvents :: Arc -> [Event a] -> [Event a] - constrainEvents a es = mapMaybe (constrainEvent a) es - constrainEvent :: Arc -> Event a -> Maybe (Event a) - constrainEvent a e = - do - p' <- subArc (part e) a - return e {part = p'} - -{-| @segment n p@ ’samples’ the pattern @p@ at a rate of @n@ events per cycle. -Useful for turning a continuous pattern into a discrete one. - -In the following example, the pattern originates from the shape of a sine -wave, a continuous pattern. Without @segment@, the samples will get triggered -at an undefined frequency which may be very high. - -> d1 $ n (slow 2 $ segment 16 $ range 0 32 $ sine) # sound "amencutup" --} + where + -- TODO maybe events with the same arc (part+whole) should be + -- grouped together in the rotation? + f st es = constrainEvents (arc st) $ shiftValues $ sort $ defragParts es + shiftValues es + | i >= 0 = + zipWith + (\e s -> e {value = s}) + es + (drop i $ cycle $ map value es) + | otherwise = + zipWith + (\e s -> e {value = s}) + es + (drop (length es - abs i) $ cycle $ map value es) + wholeCycle (Arc s _) = Arc (sam s) (nextSam s) + constrainEvents :: Arc -> [Event a] -> [Event a] + constrainEvents a es = mapMaybe (constrainEvent a) es + constrainEvent :: Arc -> Event a -> Maybe (Event a) + constrainEvent a e = + do + p' <- subArc (part e) a + return e {part = p'} + +-- | @segment n p@ ’samples’ the pattern @p@ at a rate of @n@ events per cycle. +-- Useful for turning a continuous pattern into a discrete one. +-- +-- In the following example, the pattern originates from the shape of a sine +-- wave, a continuous pattern. Without @segment@, the samples will get triggered +-- 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 = patternify _segment @@ -1242,125 +1218,134 @@ toMIDI p = fromJust <$> (filterValues (isJust) (noteLookup <$> p)) -- @tom p@: Alias for @toMIDI@. -- tom = toMIDI - -{- | The `fit` function takes a pattern of integer numbers, which are used to select values from the given list. What makes this a bit strange is that only a given number of values are selected each cycle. For example: - -> d1 $ sound (fit 3 ["bd", "sn", "arpy", "arpy:1", "casio"] "0 [~ 1] 2 1") - -The above fits three samples into the pattern, i.e. for the first cycle this -will be @"bd"@, @"sn"@ and @"arpy"@, giving the result @"bd [~ sn] arpy sn"@ -(note that we start counting at zero, so that 0 picks the first value). The -following cycle the /next/ three values in the list will be picked, i.e. -@"arpy:1"@, @"casio"@ and @"bd"@, giving the pattern -@"arpy:1 [~ casio] bd casio"@ (note that the list wraps round here). - --} +-- | The `fit` function takes a pattern of integer numbers, which are used to select values from the given list. What makes this a bit strange is that only a given number of values are selected each cycle. For example: +-- +-- > d1 $ sound (fit 3 ["bd", "sn", "arpy", "arpy:1", "casio"] "0 [~ 1] 2 1") +-- +-- The above fits three samples into the pattern, i.e. for the first cycle this +-- will be @"bd"@, @"sn"@ and @"arpy"@, giving the result @"bd [~ sn] arpy sn"@ +-- (note that we start counting at zero, so that 0 picks the first value). The +-- following cycle the /next/ three values in the list will be picked, i.e. +-- @"arpy:1"@, @"casio"@ and @"bd"@, giving the pattern +-- @"arpy:1 [~ casio] bd casio"@ (note that the list wraps round here). fit :: Pattern Int -> [a] -> Pattern Int -> Pattern a -fit pint xs p = (patternify func) pint (xs,p) - where func i (xs',p') = _fit i 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 _fit perCycle xs p = (xs !!!) <$> (p {query = map (\e -> fmap (+ pos e) e) . query p}) - where pos e = perCycle * floor (start $ part e) - + where + pos e = perCycle * floor (start $ part e) permstep :: RealFrac b => Int -> [a] -> Pattern b -> Pattern a permstep nSteps things p = unwrap $ (\n -> fastFromList $ concatMap (\x -> replicate (fst x) (snd x)) $ zip (ps !! floor (n * fromIntegral (length ps - 1))) things) <$> _segment 1 p - where ps = permsort (length things) nSteps - deviance avg xs = sum $ map (abs . (avg-) . fromIntegral) xs - permsort n total = map fst $ sortOn snd $ map (\x -> (x,deviance (fromIntegral total / (fromIntegral n :: Double)) x)) $ perms n total - perms 0 _ = [] - perms 1 n = [[n]] - perms n total = concatMap (\x -> map (x:) $ perms (n-1) (total-x)) [1 .. (total-(n-1))] - -{-| - @struct a b@ structures pattern @b@ in terms of the pattern of boolean - values @a@. Only @True@ values in the boolean pattern are used. - - The following are equivalent: - - > d1 $ struct ("t ~ t*2 ~") $ sound "cp" - > d1 $ sound "cp ~ cp*2 ~" - - The structure comes from a boolean pattern, i.e. a binary pattern containing - true or false values. Above we only used true values, denoted by @t@. It’s also - possible to include false values with @f@, which @struct@ will simply treat as - silence. For example, this would have the same outcome as the above: - - > d1 $ struct ("t f t*2 f") $ sound "cp" - - These true / false binary patterns become useful when you conditionally - manipulate them, for example, ‘inverting’ the values using 'every' and 'inv': - - > d1 $ struct (every 3 inv "t f t*2 f") $ sound "cp" - - In the above, the boolean values will be ‘inverted’ every third cycle, so that - the structure comes from the @f@s rather than @t@. Note that euclidean patterns - also create true/false values, for example: - - > d1 $ struct (every 3 inv "t(3,8)") $ sound "cp" - - In the above, the euclidean pattern creates @"t f t f t f f t"@ which gets - inverted to @"f t f t f t t f"@ every third cycle. Note that if you prefer you - can use 1 and 0 instead of @t@ and @f@. --} + where + ps = permsort (length things) nSteps + deviance avg xs = sum $ map (abs . (avg -) . fromIntegral) xs + permsort n total = map fst $ sortOn snd $ map (\x -> (x, deviance (fromIntegral total / (fromIntegral n :: Double)) x)) $ perms n total + perms 0 _ = [] + perms 1 n = [[n]] + perms n total = concatMap (\x -> map (x :) $ perms (n - 1) (total - x)) [1 .. (total - (n - 1))] + +-- | +-- @struct a b@ structures pattern @b@ in terms of the pattern of boolean +-- values @a@. Only @True@ values in the boolean pattern are used. +-- +-- The following are equivalent: +-- +-- > d1 $ struct ("t ~ t*2 ~") $ sound "cp" +-- > d1 $ sound "cp ~ cp*2 ~" +-- +-- The structure comes from a boolean pattern, i.e. a binary pattern containing +-- true or false values. Above we only used true values, denoted by @t@. It’s also +-- possible to include false values with @f@, which @struct@ will simply treat as +-- silence. For example, this would have the same outcome as the above: +-- +-- > d1 $ struct ("t f t*2 f") $ sound "cp" +-- +-- These true / false binary patterns become useful when you conditionally +-- manipulate them, for example, ‘inverting’ the values using 'every' and 'inv': +-- +-- > d1 $ struct (every 3 inv "t f t*2 f") $ sound "cp" +-- +-- In the above, the boolean values will be ‘inverted’ every third cycle, so that +-- the structure comes from the @f@s rather than @t@. Note that euclidean patterns +-- also create true/false values, for example: +-- +-- > d1 $ struct (every 3 inv "t(3,8)") $ sound "cp" +-- +-- In the above, the euclidean pattern creates @"t f t f t f f t"@ which gets +-- inverted to @"f t f t f t t f"@ every third cycle. Note that if you prefer you +-- can use 1 and 0 instead of @t@ and @f@. struct :: Pattern Bool -> Pattern a -> Pattern a -struct ps pv = filterJust $ (\a b -> if a then Just b else Nothing ) <$> ps <* pv +struct ps pv = filterJust $ (\a b -> if a then Just b else Nothing) <$> ps <* pv -- | @substruct a b@: similar to @struct@, but each event in pattern @a@ gets replaced with pattern @b@, compressed to fit the timespan of the event. substruct :: Pattern Bool -> Pattern b -> Pattern b substruct s p = p {query = f} - where f st = - concatMap ((\a' -> queryArc (compressArcTo a' p) a') . wholeOrPart) $ filter value $ query s st + where + f st = + concatMap ((\a' -> queryArc (compressArcTo a' p) a') . wholeOrPart) $ filter value $ query s st randArcs :: Int -> Pattern [Arc] randArcs n = - do rs <- mapM (\x -> pure (toRational x / toRational n) <~ choose [1 :: Int,2,3]) [0 .. (n-1)] - let rats = map toRational rs - total = sum rats - pairs = pairUp $ accumulate $ map (/total) rats - return pairs - where pairUp [] = [] - pairUp xs = Arc 0 (head xs) : pairUp' xs - pairUp' [] = [] - pairUp' [_] = [] - pairUp' [a, _] = [Arc a 1] - pairUp' (a:b:xs) = Arc a b: pairUp' (b:xs) - + do + rs <- mapM (\x -> pure (toRational x / toRational n) <~ choose [1 :: Int, 2, 3]) [0 .. (n - 1)] + let rats = map toRational rs + total = sum rats + pairs = pairUp $ accumulate $ map (/ total) rats + return pairs + where + pairUp [] = [] + pairUp xs = Arc 0 (head xs) : pairUp' xs + pairUp' [] = [] + pairUp' [_] = [] + pairUp' [a, _] = [Arc a 1] + pairUp' (a : b : xs) = Arc a b : pairUp' (b : xs) -- TODO - what does this do? Something for @stripe@ .. randStruct :: Int -> Pattern Int 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), - subArc (Arc s e) (Arc (s' + sam s) (e' + sam s)), i)) $ - enumerate $ value $ head $ - queryArc (randArcs n) (Arc (sam s) (nextSam s)) - (Arc s e) = arc st + 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), + subArc (Arc s e) (Arc (s' + sam s) (e' + sam s)), + i + ) + ) + $ enumerate $ + value $ + head $ + queryArc (randArcs n) (Arc (sam s) (nextSam s)) + (Arc s e) = arc st -- TODO - what does this do? substruct' :: Pattern Int -> Pattern a -> Pattern a substruct' s p = p {query = \st -> concatMap (f st) (query s st)} - where f st (Event c (Just a') _ i) = map (\e -> e {context = combineContexts [c, context e]}) $ queryArc (compressArcTo a' (inside (pure $ 1/toRational(length (queryArc s (Arc (sam (start $ arc st)) (nextSam (start $ arc st)))))) (rotR (toRational i)) p)) a' - -- Ignore analog events (ones without wholes) - f _ _ = [] - -{- | @stripe n p@: repeats pattern @p@ @n@ times per cycle, i.e., the first -parameter gives the number of cycles to operate over. So, it is similar to -@fast@, but with random durations. For example @stripe 2@ will repeat a pattern -twice, over two cycles - -In the following example, the start of every third repetition of the @d1@ -pattern will match with the clap on the @d2@ pattern. - -> d1 $ stripe 3 $ sound "bd sd ~ [mt ht]" -> d2 $ sound "cp" - -The repetitions will be contiguous (touching, but not overlapping) and the -durations will add up to a single cycle. @n@ can be supplied as a pattern of -integers. --} + where + f st (Event c (Just a') _ i) = map (\e -> e {context = combineContexts [c, context e]}) $ queryArc (compressArcTo a' (inside (pure $ 1 / toRational (length (queryArc s (Arc (sam (start $ arc st)) (nextSam (start $ arc st)))))) (rotR (toRational i)) p)) a' + -- Ignore analog events (ones without wholes) + f _ _ = [] + +-- | @stripe n p@: repeats pattern @p@ @n@ times per cycle, i.e., the first +-- parameter gives the number of cycles to operate over. So, it is similar to +-- @fast@, but with random durations. For example @stripe 2@ will repeat a pattern +-- twice, over two cycles +-- +-- In the following example, the start of every third repetition of the @d1@ +-- pattern will match with the clap on the @d2@ pattern. +-- +-- > d1 $ stripe 3 $ sound "bd sd ~ [mt ht]" +-- > d2 $ sound "cp" +-- +-- The repetitions will be contiguous (touching, but not overlapping) and the +-- 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 = patternify _stripe @@ -1376,140 +1361,146 @@ slowstripe n = slow (toRational <$> n) . stripe n -- Lindenmayer patterns, these go well with the step sequencer -- general rule parser (strings map to strings) -parseLMRule :: String -> [(String,String)] +parseLMRule :: String -> [(String, String)] parseLMRule s = map (splitOn ':') commaSplit - where splitOn sep str = splitAt (fromJust $ elemIndex sep str) - $ filter (/= sep) str - commaSplit = map T.unpack $ T.splitOn (T.pack ",") $ T.pack s + where + splitOn sep str = + splitAt (fromJust $ elemIndex sep str) $ + filter (/= sep) str + commaSplit = map T.unpack $ T.splitOn (T.pack ",") $ T.pack s -- specific parser for step sequencer (chars map to string) -- ruleset in form "a:b,b:ab" parseLMRule' :: String -> [(Char, String)] parseLMRule' str = map fixer $ parseLMRule str - where fixer (c,r) = (head c, r) - -{- | Returns the @n@th iteration of a - [Lindenmayer System](https://en.wikipedia.org/wiki/L-system) - with given start sequence. - - It takes an integer @b@, a Lindenmayer system rule set, and an initiating - string as input in order to generate an L-system tree string of @b@ iterations. - It can be used in conjunction with a step function to convert the generated - string into a playable pattern. For example, - - > d1 $ slow 16 - > $ sound - > $ step' ["feel:0", "sn:1", "bd:0"] - > ( take 512 - > $ lindenmayer 5 "0:1~~~,1:0~~~2~~~~~0~~~2~,2:2~1~,~:~~1~" "0" - > ) - - generates an L-system with initiating string @"0"@ and maps it onto a list - of samples. - - Complex L-system trees with many rules and iterations can sometimes result in unwieldy strings. Using @take n@ to only use the first @n@ elements of the string, along with a 'slow' function, can make the generated values more manageable. + where + fixer (c, r) = (head c, r) --} +-- | Returns the @n@th iteration of a +-- [Lindenmayer System](https://en.wikipedia.org/wiki/L-system) +-- with given start sequence. +-- +-- It takes an integer @b@, a Lindenmayer system rule set, and an initiating +-- string as input in order to generate an L-system tree string of @b@ iterations. +-- It can be used in conjunction with a step function to convert the generated +-- string into a playable pattern. For example, +-- +-- > d1 $ slow 16 +-- > $ sound +-- > $ step' ["feel:0", "sn:1", "bd:0"] +-- > ( take 512 +-- > $ lindenmayer 5 "0:1~~~,1:0~~~2~~~~~0~~~2~,2:2~1~,~:~~1~" "0" +-- > ) +-- +-- generates an L-system with initiating string @"0"@ and maps it onto a list +-- of samples. +-- +-- Complex L-system trees with many rules and iterations can sometimes result in unwieldy strings. Using @take n@ to only use the first @n@ elements of the string, along with a 'slow' function, can make the generated values more manageable. lindenmayer :: Int -> String -> String -> String lindenmayer _ _ [] = [] -lindenmayer 1 r (c:cs) = fromMaybe [c] (lookup c $ parseLMRule' r) - ++ lindenmayer 1 r cs +lindenmayer 1 r (c : cs) = + fromMaybe [c] (lookup c $ parseLMRule' r) + ++ lindenmayer 1 r cs lindenmayer n r s = iterate (lindenmayer 1 r) s !! n -{- | @lindenmayerI@ converts the resulting string into a a list of integers -with @fromIntegral@ applied (so they can be used seamlessly where floats or -rationals are required) -} +-- | @lindenmayerI@ converts the resulting string into a a list of integers +-- with @fromIntegral@ applied (so they can be used seamlessly where floats or +-- rationals are required) lindenmayerI :: Num b => Int -> String -> String -> [b] lindenmayerI n r s = fmap (fromIntegral . digitToInt) $ lindenmayer n r s -{- | @runMarkov n tmat xi seed@ generates a Markov chain (as a list) of length @n@ -using the transition matrix @tmat@ starting from initial state @xi@, starting -with random numbers generated from @seed@ -Each entry in the chain is the index of state (starting from zero). -Each row of the matrix will be automatically normalized. For example: -@ -runMarkov 8 [[2,3], [1,3]] 0 0 -@ -will produce a two-state chain 8 steps long, from initial state @0@, where the -transition probability from state 0->0 is 2/5, 0->1 is 3/5, 1->0 is 1/4, and -1->1 is 3/4. -} +-- | @runMarkov n tmat xi seed@ generates a Markov chain (as a list) of length @n@ +-- using the transition matrix @tmat@ starting from initial state @xi@, starting +-- with random numbers generated from @seed@ +-- Each entry in the chain is the index of state (starting from zero). +-- Each row of the matrix will be automatically normalized. For example: +-- @ +-- runMarkov 8 [[2,3], [1,3]] 0 0 +-- @ +-- will produce a two-state chain 8 steps long, from initial state @0@, where the +-- transition probability from state 0->0 is 2/5, 0->1 is 3/5, 1->0 is 1/4, and +-- 1->1 is 3/4. runMarkov :: Int -> [[Double]] -> Int -> Time -> [Int] -runMarkov n tp xi seed = reverse $ (iterate (markovStep $ renorm) [xi])!! (n-1) where - markovStep tp' xs = (fromJust $ findIndex (r <=) $ scanl1 (+) (tp'!!(head xs))) : xs where - r = timeToRand $ seed + (fromIntegral . length) xs / fromIntegral n - renorm = [ map (/ sum x) x | x <- tp ] - -{- | @markovPat n xi tp@ generates a one-cycle pattern of @n@ steps in a Markov -chain starting from state @xi@ with transition matrix @tp@. Each row of the -transition matrix is automatically normalized. For example: - ->>> markovPat 8 1 [[3,5,2], [4,4,2], [0,1,0]] -(0>⅛)|1 -(⅛>¼)|2 -(¼>⅜)|1 -(⅜>½)|1 -(½>⅝)|2 -(⅝>¾)|1 -(¾>⅞)|1 -(⅞>1)|0 --} +runMarkov n tp xi seed = reverse $ (iterate (markovStep $ renorm) [xi]) !! (n - 1) + where + markovStep tp' xs = (fromJust $ findIndex (r <=) $ scanl1 (+) (tp' !! (head xs))) : xs + where + r = timeToRand $ seed + (fromIntegral . length) xs / fromIntegral n + renorm = [map (/ sum x) x | x <- tp] + +-- | @markovPat n xi tp@ generates a one-cycle pattern of @n@ steps in a Markov +-- chain starting from state @xi@ with transition matrix @tp@. Each row of the +-- transition matrix is automatically normalized. For example: +-- +-- >>> markovPat 8 1 [[3,5,2], [4,4,2], [0,1,0]] +-- (0>⅛)|1 +-- (⅛>¼)|2 +-- (¼>⅜)|1 +-- (⅜>½)|1 +-- (½>⅝)|2 +-- (⅝>¾)|1 +-- (¾>⅞)|1 +-- (⅞>1)|0 markovPat :: Pattern Int -> Pattern Int -> [[Double]] -> Pattern Int markovPat = patternify2 _markovPat _markovPat :: Int -> Int -> [[Double]] -> Pattern Int -_markovPat n xi tp = setTactus (toRational n) $ splitQueries $ pattern (\(State a@(Arc s _) _) -> - queryArc (listToPat $ runMarkov n tp xi (sam s)) a) - -{-| -@beat@ structures a pattern by picking subdivisions of a cycle. -Takes in a pattern that tells it which parts to play (polyphony is recommeded here), -and the number of parts by which to subdivide the cycle (also pattern-able). -For example: -> d1 $ beat "[3,4.2,9,11,14]" 16 $ s "sd" --} +_markovPat n xi tp = + setTactus (toRational n) $ + splitQueries $ + pattern + ( \(State a@(Arc s _) _) -> + queryArc (listToPat $ runMarkov n tp xi (sam s)) a + ) + +-- | +-- @beat@ structures a pattern by picking subdivisions of a cycle. +-- Takes in a pattern that tells it which parts to play (polyphony is recommeded here), +-- and the number of parts by which to subdivide the cycle (also pattern-able). +-- For example: +-- > d1 $ beat "[3,4.2,9,11,14]" 16 $ s "sd" beat :: Pattern Time -> Pattern Time -> Pattern a -> Pattern a beat = patternify2 $ __beat innerJoin __beat :: (Pattern (Pattern a) -> Pattern a) -> Time -> Time -> Pattern a -> Pattern a -__beat join t d p = join $ (compress (s,e) . pure) <$> p - where s = t' / d - e = (t'+1) / d - t' = t `mod'` d - - -{-| -@mask@ takes a boolean pattern and ‘masks’ another pattern with it. That is, -events are only carried over if they match within a ‘true’ event in the binary -pattern, i.e., it removes events from the second pattern that don't start during -an event from the first. - -For example, consider this kind of messy rhythm without any rests. - -> d1 $ sound (slowcat ["sn*8", "[cp*4 bd*4, hc*5]"]) # n (run 8) - -If we apply a mask to it - -@ -d1 $ s ( mask ("1 1 1 ~ 1 1 ~ 1" :: Pattern Bool) - ( slowcat ["sn*8", "[cp*4 bd*4, bass*5]"] ) - ) - # n (run 8) -@ - -Due to the use of `slowcat` here, the same mask is first applied to @"sn*8"@ and -in the next cycle to @"[cp*4 bd*4, hc*5]"@. - -You could achieve the same effect by adding rests within the `slowcat` patterns, -but mask allows you to do this more easily. It kind of keeps the rhythmic -structure and you can change the used samples independently, e.g., - -@ -d1 $ s ( mask ("1 ~ 1 ~ 1 1 ~ 1") - ( slowcat ["can*8", "[cp*4 sn*4, jvbass*16]"] ) - ) - # n (run 8) -@ --} +__beat join t d p = join $ (compress (s, e) . pure) <$> p + where + s = t' / d + e = (t' + 1) / d + t' = t `mod'` d + +-- | +-- @mask@ takes a boolean pattern and ‘masks’ another pattern with it. That is, +-- events are only carried over if they match within a ‘true’ event in the binary +-- pattern, i.e., it removes events from the second pattern that don't start during +-- an event from the first. +-- +-- For example, consider this kind of messy rhythm without any rests. +-- +-- > d1 $ sound (slowcat ["sn*8", "[cp*4 bd*4, hc*5]"]) # n (run 8) +-- +-- If we apply a mask to it +-- +-- @ +-- d1 $ s ( mask ("1 1 1 ~ 1 1 ~ 1" :: Pattern Bool) +-- ( slowcat ["sn*8", "[cp*4 bd*4, bass*5]"] ) +-- ) +-- # n (run 8) +-- @ +-- +-- Due to the use of `slowcat` here, the same mask is first applied to @"sn*8"@ and +-- in the next cycle to @"[cp*4 bd*4, hc*5]"@. +-- +-- You could achieve the same effect by adding rests within the `slowcat` patterns, +-- but mask allows you to do this more easily. It kind of keeps the rhythmic +-- structure and you can change the used samples independently, e.g., +-- +-- @ +-- d1 $ s ( mask ("1 ~ 1 ~ 1 1 ~ 1") +-- ( slowcat ["can*8", "[cp*4 sn*4, jvbass*16]"] ) +-- ) +-- # n (run 8) +-- @ mask :: Pattern Bool -> Pattern a -> Pattern a mask b p = const <$> p <* (filterValues id b) @@ -1518,78 +1509,82 @@ enclosingArc :: [Arc] -> Arc enclosingArc [] = Arc 0 1 enclosingArc as = Arc (minimum (map start as)) (maximum (map stop as)) -{-| - @stretch@ takes a pattern, and if there’s silences at the start or end of the - current cycle, it will zoom in to avoid them. The following are equivalent: - - > d1 $ note (stretch "~ 0 1 5 8*4 ~") # s "superpiano" - > d1 $ note "0 1 5 8*4" # s "superpiano" - - You can pattern silences on the extremes of a cycle to make changes to the rhythm: - - > d1 $ note (stretch "~ <0 ~> 1 5 8*4 ~") # s "superpiano" --} +-- | +-- @stretch@ takes a pattern, and if there’s silences at the start or end of the +-- current cycle, it will zoom in to avoid them. The following are equivalent: +-- +-- > d1 $ note (stretch "~ 0 1 5 8*4 ~") # s "superpiano" +-- > d1 $ note "0 1 5 8*4" # s "superpiano" +-- +-- You can pattern silences on the extremes of a cycle to make changes to the rhythm: +-- +-- > d1 $ note (stretch "~ <0 ~> 1 5 8*4 ~") # s "superpiano" stretch :: Pattern a -> Pattern a -- TODO - should that be whole or part? 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 - -{- | @fit'@ is a generalization of `fit`, where the list is instead constructed -by using another integer pattern to slice up a given pattern. The first argument -is the number of cycles of that latter pattern to use when slicing. It's easier -to understand this with a few examples: - -> d1 $ sound (fit' 1 2 "0 1" "1 0" "bd sn") - -So what does this do? The first @1@ just tells it to slice up a single cycle of -@"bd sn"@. The @2@ tells it to select two values each cycle, just like the first -argument to @fit@. The next pattern @"0 1"@ is the "from" pattern which tells -it how to slice, which in this case means @"0"@ maps to @"bd"@, and @"1"@ maps -to @"sn"@. The next pattern @"1 0"@ is the "to" pattern, which tells it how to -rearrange those slices. So the final result is the pattern @"sn bd"@. - -A more useful example might be something like - -> d1 $ fit' 1 4 (run 4) "[0 3*2 2 1 0 3*2 2 [1*8 ~]]/2" -> $ chop 4 -> $ (sound "breaks152" # unit "c") - -which uses @chop@ to break a single sample into individual pieces, which @fit'@ then puts into a list (using the @run 4@ pattern) and reassembles according to the complicated integer pattern. --} + 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 + +-- | @fit'@ is a generalization of `fit`, where the list is instead constructed +-- by using another integer pattern to slice up a given pattern. The first argument +-- is the number of cycles of that latter pattern to use when slicing. It's easier +-- to understand this with a few examples: +-- +-- > d1 $ sound (fit' 1 2 "0 1" "1 0" "bd sn") +-- +-- So what does this do? The first @1@ just tells it to slice up a single cycle of +-- @"bd sn"@. The @2@ tells it to select two values each cycle, just like the first +-- argument to @fit@. The next pattern @"0 1"@ is the "from" pattern which tells +-- it how to slice, which in this case means @"0"@ maps to @"bd"@, and @"1"@ maps +-- to @"sn"@. The next pattern @"1 0"@ is the "to" pattern, which tells it how to +-- rearrange those slices. So the final result is the pattern @"sn bd"@. +-- +-- A more useful example might be something like +-- +-- > d1 $ fit' 1 4 (run 4) "[0 3*2 2 1 0 3*2 2 [1*8 ~]]/2" +-- > $ chop 4 +-- > $ (sound "breaks152" # unit "c") +-- +-- which uses @chop@ to break a single sample into individual pieces, which @fit'@ then puts into a list (using the @run 4@ pattern) and reassembles according to the complicated integer pattern. fit' :: Pattern Time -> Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a fit' cyc n from to p = squeezeJoin $ _fit n mapMasks to - where mapMasks = [stretch $ mask (const True <$> filterValues (== i) from') p' - | i <- [0..n-1]] - p' = density cyc p - from' = density cyc from - -{-| - Treats the given pattern @p@ as having @n@ chunks, and applies the function @f@ to one of those sections per cycle. - Running: - - from left to right if chunk number is positive - - from right to left if chunk number is negative - - > d1 $ chunk 4 (fast 4) $ sound "cp sn arpy [mt lt]" - - The following: - - > d1 $ chunk 4 (# speed 2) $ sound "bd hh sn cp" - - applies @(# speed 2)@ to the uppercased part of the cycle below: - - > BD hh sn cp - > bd HH sn cp - > bd hh SN cp - > bd hh sn CP --} + where + mapMasks = + [ stretch $ mask (const True <$> filterValues (== i) from') p' + | i <- [0 .. n - 1] + ] + p' = density cyc p + from' = density cyc from + +-- | +-- Treats the given pattern @p@ as having @n@ chunks, and applies the function @f@ to one of those sections per cycle. +-- Running: +-- - from left to right if chunk number is positive +-- - from right to left if chunk number is negative +-- +-- > d1 $ chunk 4 (fast 4) $ sound "cp sn arpy [mt lt]" +-- +-- The following: +-- +-- > d1 $ chunk 4 (# speed 2) $ sound "bd hh sn cp" +-- +-- applies @(# speed 2)@ to the uppercased part of the cycle below: +-- +-- > BD hh sn cp +-- > bd HH sn cp +-- > bd hh SN cp +-- > bd hh sn CP chunk :: Pattern Int -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b chunk npat f p = innerJoin $ (\n -> _chunk n f p) <$> npat _chunk :: Integral a => a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b -_chunk n f p | n >= 0 = cat [withinArc (Arc (i % fromIntegral n) ((i+1) % fromIntegral n)) f p | i <- [0 .. fromIntegral n - 1]] - | otherwise = do i <- _slow (toRational (-n)) $ rev $ run (fromIntegral (-n)) - withinArc (Arc (i % fromIntegral (-n)) ((i+1) % fromIntegral (-n))) f p +_chunk n f p + | n >= 0 = cat [withinArc (Arc (i % fromIntegral n) ((i + 1) % fromIntegral n)) f p | i <- [0 .. fromIntegral n - 1]] + | otherwise = do + i <- _slow (toRational (-n)) $ rev $ run (fromIntegral (-n)) + withinArc (Arc (i % fromIntegral (-n)) ((i + 1) % fromIntegral (-n))) f p -- | DEPRECATED, use 'chunk' with negative numbers instead chunk' :: Integral a1 => Pattern a1 -> (Pattern a2 -> Pattern a2) -> Pattern a2 -> Pattern a2 @@ -1599,368 +1594,364 @@ chunk' npat f p = innerJoin $ (\n -> _chunk' n f p) <$> npat _chunk' :: Integral a => a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b _chunk' n f p = _chunk (-n) f p -{-| -@inside@ carries out an operation /inside/ a cycle. -For example, while @rev "0 1 2 3 4 5 6 7"@ is the same as @"7 6 5 4 3 2 1 0"@, -@inside 2 rev "0 1 2 3 4 5 6 7"@ gives @"3 2 1 0 7 6 5 4"@. - -What this function is really doing is ‘slowing down’ the pattern by a given -factor, applying the given function to it, and then ‘speeding it up’ by the same -factor. In other words, this: - -> inside 2 rev "0 1 2 3 4 5 6 7" - -Is doing this: - -> fast 2 $ rev $ slow 2 "0 1 2 3 4 5 6 7" - -so rather than whole cycles, each half of a cycle is reversed. --} +-- | +-- @inside@ carries out an operation /inside/ a cycle. +-- For example, while @rev "0 1 2 3 4 5 6 7"@ is the same as @"7 6 5 4 3 2 1 0"@, +-- @inside 2 rev "0 1 2 3 4 5 6 7"@ gives @"3 2 1 0 7 6 5 4"@. +-- +-- What this function is really doing is ‘slowing down’ the pattern by a given +-- factor, applying the given function to it, and then ‘speeding it up’ by the same +-- factor. In other words, this: +-- +-- > inside 2 rev "0 1 2 3 4 5 6 7" +-- +-- Is doing this: +-- +-- > fast 2 $ rev $ slow 2 "0 1 2 3 4 5 6 7" +-- +-- so rather than whole cycles, each half of a cycle is reversed. inside :: Pattern Time -> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a inside np f p = innerJoin $ (\n -> _inside n f p) <$> np _inside :: Time -> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a _inside n f p = _fast n $ f (_slow n p) -{-| -@outside@ is the inverse of the 'inside' function. @outside@ applies its function /outside/ the cycle. -Say you have a pattern that takes 4 cycles to repeat and apply the rev function: - -> d1 $ rev $ cat [s "bd bd sn",s "sn sn bd", s"lt lt sd", s "sd sd bd"] - -The above generates: - -> d1 $ rev $ cat [s "sn bd bd",s "bd sn sn", s "sd lt lt", s "bd sd sd"] - -However if you apply @outside@: - -> d1 $ outside 4 (rev) $ cat [s "bd bd sn",s "sn sn bd", s"lt lt sd", s "sd sd bd"] - -The result is: - -> d1 $ rev $ cat [s "bd sd sd", s "sd lt lt", s "sn sn bd", s "bd bd sn"] - -Notice that the whole idea has been reversed. What this function is really doing -is ‘speeding up’ the pattern by a given factor, applying the given function to -it, and then ‘slowing it down’ by the same factor. In other words, this: - -> d1 $ slow 4 $ rev $ fast 4 -> $ cat [s "bd bd sn",s "sn sn bd", s"lt lt sd", s "sd sd bd"] - -This compresses the idea into a single cycle before rev operates and then slows it back to the original speed. --} +-- | +-- @outside@ is the inverse of the 'inside' function. @outside@ applies its function /outside/ the cycle. +-- Say you have a pattern that takes 4 cycles to repeat and apply the rev function: +-- +-- > d1 $ rev $ cat [s "bd bd sn",s "sn sn bd", s"lt lt sd", s "sd sd bd"] +-- +-- The above generates: +-- +-- > d1 $ rev $ cat [s "sn bd bd",s "bd sn sn", s "sd lt lt", s "bd sd sd"] +-- +-- However if you apply @outside@: +-- +-- > d1 $ outside 4 (rev) $ cat [s "bd bd sn",s "sn sn bd", s"lt lt sd", s "sd sd bd"] +-- +-- The result is: +-- +-- > d1 $ rev $ cat [s "bd sd sd", s "sd lt lt", s "sn sn bd", s "bd bd sn"] +-- +-- Notice that the whole idea has been reversed. What this function is really doing +-- is ‘speeding up’ the pattern by a given factor, applying the given function to +-- it, and then ‘slowing it down’ by the same factor. In other words, this: +-- +-- > d1 $ slow 4 $ rev $ fast 4 +-- > $ cat [s "bd bd sn",s "sn sn bd", s"lt lt sd", s "sd sd bd"] +-- +-- This compresses the idea into a single cycle before rev operates and then slows it back to the original speed. outside :: Pattern Time -> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a outside np f p = innerJoin $ (\n -> _outside n f p) <$> np _outside :: Time -> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a -_outside n = _inside (1/n) - -{-| - Takes a pattern and loops only the first cycle of the pattern. For example, the following code will only play the bass drum sample: +_outside n = _inside (1 / n) - > d1 $ loopFirst $ s "< cp*4>" - - This function combines with 'sometimes' to insert events from the first cycle randomly into subsequent cycles of the pattern: - - > d1 $ sometimes loopFirst $ s "< cp*4>" --} +-- | +-- Takes a pattern and loops only the first cycle of the pattern. For example, the following code will only play the bass drum sample: +-- +-- > d1 $ loopFirst $ s "< cp*4>" +-- +-- This function combines with 'sometimes' to insert events from the first cycle randomly into subsequent cycles of the pattern: +-- +-- > d1 $ sometimes loopFirst $ s "< cp*4>" loopFirst :: Pattern a -> Pattern a loopFirst p = splitQueries $ p {query = f} - where f st = map - (\(Event c w p' v) -> - Event c (plus <$> w) (plus p') v) $ - query p (st {arc = minus $ arc st}) - where minus = fmap (subtract (sam s)) - plus = fmap (+ sam s) - s = start $ arc st + where + f st = + map + ( \(Event c w p' v) -> + Event c (plus <$> w) (plus p') v + ) + $ query p (st {arc = minus $ arc st}) + where + minus = fmap (subtract (sam s)) + plus = fmap (+ sam s) + s = start $ arc st timeLoop :: Pattern Time -> Pattern a -> Pattern a timeLoop n = outside n loopFirst -{-| - @seqPLoop@ will keep looping the sequence when it gets to the end: - - > d1 $ qtrigger $ seqPLoop - > [ (0, 12, sound "bd bd*2") - > , (4, 12, sound "hh*2 [sn cp] cp future*4") - > , (8, 12, sound (samples "arpy*8" (run 16))) - > ] --} +-- | +-- @seqPLoop@ will keep looping the sequence when it gets to the end: +-- +-- > d1 $ qtrigger $ seqPLoop +-- > [ (0, 12, sound "bd bd*2") +-- > , (4, 12, sound "hh*2 [sn cp] cp future*4") +-- > , (8, 12, sound (samples "arpy*8" (run 16))) +-- > ] seqPLoop :: [(Time, Time, Pattern a)] -> Pattern a seqPLoop ps = timeLoop (pure $ maxT - minT) $ minT `rotL` seqP ps - where minT = minimum $ map (\(x,_,_) -> x) ps - maxT = maximum $ map (\(_,x,_) -> x) ps - -{-| -@toScale@ lets you turn a pattern of notes within a scale (expressed as a -list) to note numbers. - -For example: - -> toScale [0, 4, 7] "0 1 2 3" - -will turn into the pattern @"0 4 7 12"@. - -@toScale@ is handy for quickly applying a scale without naming it: - -> d1 $ n (toScale [0,2,3,5,7,8,10] "0 1 2 3 4 5 6 7") # sound "superpiano" - -This function assumes your scale fits within an octave; if that's not true, -use 'toScale''. + where + minT = minimum $ map (\(x, _, _) -> x) ps + maxT = maximum $ map (\(_, x, _) -> x) ps -@toScale = toScale' 12@ --} +-- | +-- @toScale@ lets you turn a pattern of notes within a scale (expressed as a +-- list) to note numbers. +-- +-- For example: +-- +-- > toScale [0, 4, 7] "0 1 2 3" +-- +-- will turn into the pattern @"0 4 7 12"@. +-- +-- @toScale@ is handy for quickly applying a scale without naming it: +-- +-- > d1 $ n (toScale [0,2,3,5,7,8,10] "0 1 2 3 4 5 6 7") # sound "superpiano" +-- +-- This function assumes your scale fits within an octave; if that's not true, +-- use 'toScale''. +-- +-- @toScale = toScale' 12@ toScale :: Num a => [a] -> Pattern Int -> Pattern a toScale = toScale' 12 -{- | As 'toScale', though allowing scales of arbitrary size. - -An example: @toScale' 24 [0,4,7,10,14,17] (run 8)@ turns into @"0 4 7 10 14 17 24 28"@. --} +-- | As 'toScale', though allowing scales of arbitrary size. +-- +-- An example: @toScale' 24 [0,4,7,10,14,17] (run 8)@ turns into @"0 4 7 10 14 17 24 28"@. toScale' :: Num a => Int -> [a] -> Pattern Int -> Pattern a toScale' _ [] = const silence toScale' o s = fmap noteInScale - where octave x = x `div` length s - noteInScale x = (s !!! x) + fromIntegral (o * octave x) - - -{- | @swingBy x n@ divides a cycle into @n@ slices and delays the notes in the - second half of each slice by @x@ fraction of a slice. So if @x@ is 0 it does - nothing, 0.5 delays for half the note duration, and 1 will wrap around to - doing nothing again. The end result is a shuffle or swing-like rhythm. For - example, the following will delay every other @"hh"@ 1/3 of the way to the - next @"hh"@: - - > d1 $ swingBy (1/3) 4 $ sound "hh*8" --} + where + octave x = x `div` length s + noteInScale x = (s !!! x) + fromIntegral (o * octave x) + +-- | @swingBy x n@ divides a cycle into @n@ slices and delays the notes in the +-- second half of each slice by @x@ fraction of a slice. So if @x@ is 0 it does +-- nothing, 0.5 delays for half the note duration, and 1 will wrap around to +-- doing nothing again. The end result is a shuffle or swing-like rhythm. For +-- example, the following will delay every other @"hh"@ 1/3 of the way to the +-- next @"hh"@: +-- +-- > d1 $ swingBy (1/3) 4 $ sound "hh*8" swingBy :: Pattern Time -> Pattern Time -> Pattern a -> Pattern a swingBy x n = inside n (withinArc (Arc 0.5 1) (x ~>)) -{-| -As 'swingBy', with the cycle division set to ⅓. --} +-- | +-- As 'swingBy', with the cycle division set to ⅓. swing :: Pattern Time -> Pattern a -> Pattern a -swing = swingBy (pure $ 1%3) - -{- | @cycleChoose@ is like `choose` but only picks a new item from the list - once each cycle. +swing = swingBy (pure $ 1 % 3) - > d1 $ sound "drum ~ drum drum" # n (cycleChoose [0,2,3]) --} +-- | @cycleChoose@ is like `choose` but only picks a new item from the list +-- once each cycle. +-- +-- > d1 $ sound "drum ~ drum drum" # n (cycleChoose [0,2,3]) cycleChoose :: [a] -> Pattern a cycleChoose = segment 1 . choose -{- | Internal function used by shuffle and scramble -} +-- | Internal function used by shuffle and scramble _rearrangeWith :: Pattern Int -> Int -> Pattern a -> Pattern a _rearrangeWith ipat n pat = innerJoin $ (\i -> _fast nT $ _repeatCycles n $ pats !! i) <$> ipat where - pats = map (\i -> zoom (fromIntegral i / nT, fromIntegral (i+1) / nT) pat) [0 .. (n-1)] + pats = map (\i -> zoom (fromIntegral i / nT, fromIntegral (i + 1) / nT) pat) [0 .. (n - 1)] nT :: Time nT = fromIntegral n -{- | @shuffle n p@ evenly divides one cycle of the pattern @p@ into @n@ parts, -and returns a random permutation of the parts each cycle. For example, -@shuffle 3 "a b c"@ could return @"a b c"@, @"a c b"@, @"b a c"@, @"b c a"@, -@"c a b"@, or @"c b a"@. But it will /never/ return @"a a a"@, because that -is not a permutation of the parts. - -This could also be called “sampling without replacement”. --} +-- | @shuffle n p@ evenly divides one cycle of the pattern @p@ into @n@ parts, +-- and returns a random permutation of the parts each cycle. For example, +-- @shuffle 3 "a b c"@ could return @"a b c"@, @"a c b"@, @"b a c"@, @"b c a"@, +-- @"c a b"@, or @"c b a"@. But it will /never/ return @"a a a"@, because that +-- is not a permutation of the parts. +-- +-- This could also be called “sampling without replacement”. shuffle :: Pattern Int -> Pattern a -> Pattern a shuffle = patternify' _shuffle _shuffle :: Int -> Pattern a -> Pattern a _shuffle n = _rearrangeWith (randrun n) n -{- | @scramble n p@ is like 'shuffle' but randomly selects from the parts -of @p@ instead of making permutations. -For example, @scramble 3 "a b c"@ will randomly select 3 parts from -@"a"@ @"b"@ and @"c"@, possibly repeating a single part. - -This could also be called “sampling with replacement”. --} +-- | @scramble n p@ is like 'shuffle' but randomly selects from the parts +-- of @p@ instead of making permutations. +-- For example, @scramble 3 "a b c"@ will randomly select 3 parts from +-- @"a"@ @"b"@ and @"c"@, possibly repeating a single part. +-- +-- This could also be called “sampling with replacement”. scramble :: Pattern Int -> Pattern a -> Pattern a scramble = patternify' _scramble _scramble :: Int -> Pattern a -> Pattern a _scramble n = _rearrangeWith (_segment (fromIntegral n) $ _irand n) n -{-| -@randrun n@ generates a pattern of random integers less than @n@. - -The following plays random notes in an octave: - -@ -d1 $ s "superhammond!12" # n (fromIntegral <$> randrun 13) -@ - --} +-- | +-- @randrun n@ generates a pattern of random integers less than @n@. +-- +-- The following plays random notes in an octave: +-- +-- @ +-- 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) - 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] - arcs = zipWith Arc fractions (tail fractions) - fractions = map (+ (sam $ start a)) [0, 1 / fromIntegral n' .. 1] - toEv (a',v) = do a'' <- subArc a a' - return $ Event (Context []) (Just a') a'' v + 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] + arcs = zipWith Arc fractions (tail fractions) + fractions = map (+ (sam $ start a)) [0, 1 / fromIntegral n' .. 1] + toEv (a', v) = do + a'' <- subArc a a' + return $ Event (Context []) (Just a') a'' v -- ** Composing patterns -{- | The function @seqP@ allows you to define when -a sound within a list starts and ends. The code below contains three -separate patterns in a `stack`, but each has different start times -(zero cycles, eight cycles, and sixteen cycles, respectively). All -patterns stop after 128 cycles: - -@ -d1 $ seqP [ - (0, 128, sound "bd bd*2"), - (8, 128, sound "hh*2 [sn cp] cp future*4"), - (16, 128, sound (samples "arpy*8" (run 16))) -] -@ --} +-- | The function @seqP@ allows you to define when +-- a sound within a list starts and ends. The code below contains three +-- separate patterns in a `stack`, but each has different start times +-- (zero cycles, eight cycles, and sixteen cycles, respectively). All +-- patterns stop after 128 cycles: +-- +-- @ +-- d1 $ seqP [ +-- (0, 128, sound "bd bd*2"), +-- (8, 128, sound "hh*2 [sn cp] cp future*4"), +-- (16, 128, sound (samples "arpy*8" (run 16))) +-- ] +-- @ seqP :: [(Time, Time, Pattern a)] -> Pattern a seqP ps = stack $ map (\(s, e, p) -> playFor s e (sam s `rotR` p)) ps -{-| -The @ur@ function is designed for longer form composition, by allowing you to -create ‘patterns of patterns’ in a repeating loop. It takes four parameters: -how long the loop will take, a pattern giving the structure of the composition, -a lookup table for named patterns to feed into that structure, and a second -lookup table for named transformations\/effects. - -The /ur-/ prefix [comes from German](https://en.wiktionary.org/wiki/ur-#German) and -means /proto-/ or /original/. For a mnemonic device, think of this function as -assembling a set of original patterns (ur-patterns) into a larger, newer whole. - -Lets say you had three patterns (called @a@, @b@ and @c@), and that you wanted -to play them four cycles each, over twelve cycles in total. Here is one way to -do it: - -@ -let pats = - [ ( "a", stack [ n "c4 c5 g4 f4 f5 g4 e5 g4" # s "superpiano" # gain "0.7" - , n "[c3,g4,c4]" # s "superpiano"# gain "0.7" - ] - ) - , ( "b", stack [ n "d4 c5 g4 f4 f5 g4 e5 g4" # s "superpiano" # gain "0.7" - , n "[d3,a4,d4]" # s "superpiano"# gain "0.7" - ] - ) - , ( "c", stack [ n "f4 c5 g4 f4 f5 g4 e5 g4" # s "superpiano" # gain "0.7" - , n "[f4,c5,f4]" # s "superpiano"# gain "0.7" - ] - ) - ] -in -d1 $ ur 12 "a b c" pats [] -@ - -In the above, the fourth parameter is given as an empty list, but that is where -you can put another lookup table, of functions rather than patterns this time. -For example: - -@ -let - pats = ... - fx = [ ("reverb", ( # (room 0.8 # sz 0.99 # orbit 1))) - , ("faster", fast 2) - ] -in -d1 $ ur 12 "a b:reverb c:faster" pats fx -@ - -In this example, @b@ has the function applied that’s named as reverb, while @c@ -is made to go faster. It’s also possible to schedule multiple patterns at once, -like in the following: - -@ -let pats = [ ("drums", s "drum cp*2") - , ("melody", s "arpy:2 arpy:3 arpy:5") - , ("craziness", s "cp:4*8" # speed ( sine + 0.5 )) - ] - fx = [("higher", ( # speed 2))] -in -d1 $ ur 8 "[drums, melody] [drums,craziness,melody] melody:higher" pats fx -@ --} +-- | +-- The @ur@ function is designed for longer form composition, by allowing you to +-- create ‘patterns of patterns’ in a repeating loop. It takes four parameters: +-- how long the loop will take, a pattern giving the structure of the composition, +-- a lookup table for named patterns to feed into that structure, and a second +-- lookup table for named transformations\/effects. +-- +-- The /ur-/ prefix [comes from German](https://en.wiktionary.org/wiki/ur-#German) and +-- means /proto-/ or /original/. For a mnemonic device, think of this function as +-- assembling a set of original patterns (ur-patterns) into a larger, newer whole. +-- +-- Lets say you had three patterns (called @a@, @b@ and @c@), and that you wanted +-- to play them four cycles each, over twelve cycles in total. Here is one way to +-- do it: +-- +-- @ +-- let pats = +-- [ ( "a", stack [ n "c4 c5 g4 f4 f5 g4 e5 g4" # s "superpiano" # gain "0.7" +-- , n "[c3,g4,c4]" # s "superpiano"# gain "0.7" +-- ] +-- ) +-- , ( "b", stack [ n "d4 c5 g4 f4 f5 g4 e5 g4" # s "superpiano" # gain "0.7" +-- , n "[d3,a4,d4]" # s "superpiano"# gain "0.7" +-- ] +-- ) +-- , ( "c", stack [ n "f4 c5 g4 f4 f5 g4 e5 g4" # s "superpiano" # gain "0.7" +-- , n "[f4,c5,f4]" # s "superpiano"# gain "0.7" +-- ] +-- ) +-- ] +-- in +-- d1 $ ur 12 "a b c" pats [] +-- @ +-- +-- In the above, the fourth parameter is given as an empty list, but that is where +-- you can put another lookup table, of functions rather than patterns this time. +-- For example: +-- +-- @ +-- let +-- pats = ... +-- fx = [ ("reverb", ( # (room 0.8 # sz 0.99 # orbit 1))) +-- , ("faster", fast 2) +-- ] +-- in +-- d1 $ ur 12 "a b:reverb c:faster" pats fx +-- @ +-- +-- In this example, @b@ has the function applied that’s named as reverb, while @c@ +-- is made to go faster. It’s also possible to schedule multiple patterns at once, +-- like in the following: +-- +-- @ +-- let pats = [ ("drums", s "drum cp*2") +-- , ("melody", s "arpy:2 arpy:3 arpy:5") +-- , ("craziness", s "cp:4*8" # speed ( sine + 0.5 )) +-- ] +-- fx = [("higher", ( # speed 2))] +-- in +-- d1 $ ur 8 "[drums, melody] [drums,craziness,melody] melody:higher" pats fx +-- @ ur :: Time -> Pattern String -> [(String, Pattern a)] -> [(String, Pattern a -> Pattern a)] -> Pattern a ur t outer_p ps fs = _slow t $ unwrap $ adjust <$> timedValues (getPat . split <$> outer_p) - where split = wordsBy (==':') - getPat (s:xs) = (match s, transform xs) - -- TODO - check this really 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' str (Arc s e) p = s `rotR` inside (pure $ 1/(e-s)) (matchF str) p - matchF str = fromMaybe id $ lookup str fs - 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. - - @inhabit@ allows you to link patterns to some @String@, or in other words, - to give patterns a name and then call them from within another pattern of - @String@s. - - For example, we can make our own bassdrum, hi-hat and snaredrum kit: - - > do - > let drum = inhabit [ ("bd", s "sine" |- accelerate 1.5) - > , ("hh", s "alphabet:7" # begin 0.7 # hpf 7000) - > , ("sd", s "invaders:3" # speed 12) - > ] - > d1 $ drum "[bd*8?, [~hh]*4, sd(6,16)]" - - @inhabit@ can be very useful when using MIDI controlled drum machines, since you - can give understandable drum names to patterns of notes. --} + where + split = wordsBy (== ':') + getPat (s : xs) = (match s, transform xs) + -- TODO - check this really 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' str (Arc s e) p = s `rotR` inside (pure $ 1 / (e - s)) (matchF str) p + matchF str = fromMaybe id $ lookup str fs + 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. +-- +-- @inhabit@ allows you to link patterns to some @String@, or in other words, +-- to give patterns a name and then call them from within another pattern of +-- @String@s. +-- +-- For example, we can make our own bassdrum, hi-hat and snaredrum kit: +-- +-- > do +-- > let drum = inhabit [ ("bd", s "sine" |- accelerate 1.5) +-- > , ("hh", s "alphabet:7" # begin 0.7 # hpf 7000) +-- > , ("sd", s "invaders:3" # speed 12) +-- > ] +-- > d1 $ drum "[bd*8?, [~hh]*4, sd(6,16)]" +-- +-- @inhabit@ can be very useful when using MIDI controlled drum machines, since you +-- can give understandable drum names to patterns of notes. inhabit :: [(String, Pattern a)] -> Pattern String -> Pattern a inhabit ps p = squeezeJoin $ (\s -> fromMaybe silence $ lookup s ps) <$> p -{- | @spaceOut xs p@ repeats a 'Pattern' @p@ at different durations given by the list of time values in @xs@. -} +-- | @spaceOut xs p@ repeats a 'Pattern' @p@ at different durations given by the list of time values in @xs@. 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 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 - -{-| @flatpat@ takes a 'Pattern' of lists and pulls the list elements as - separate 'Event's. For example, the following code uses @flatpat@ in combination with @listToPat@ to create an alternating pattern of chords: - - > d1 $ n (flatpat $ listToPat [[0,4,7],[(-12),(-8),(-5)]]) - > # s "superpiano" # sustain 2 - - This code is equivalent to: - - > d1 $ n ("[0,4,7] [-12,-8,-5]") # s "superpiano" # sustain 2 --} + where + markOut :: Time -> [Time] -> [Arc] + 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 + +-- | @flatpat@ takes a 'Pattern' of lists and pulls the list elements as +-- separate 'Event's. For example, the following code uses @flatpat@ in combination with @listToPat@ to create an alternating pattern of chords: +-- +-- > d1 $ n (flatpat $ listToPat [[0,4,7],[(-12),(-8),(-5)]]) +-- > # s "superpiano" # sustain 2 +-- +-- This code is equivalent to: +-- +-- > 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, 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. - -It allows you to layer up multiple functions on one pattern. For example, the following -will play two versions of the pattern at the same time, one reversed and one at twice -the speed: - -> d1 $ layer [rev, fast 2] $ sound "arpy [~ arpy:4]" - -The original version of the pattern can be included by using the @id@ function: - -> d1 $ layer [id, rev, fast 2] $ sound "arpy [~ arpy:4]" --} +-- | @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. +-- +-- It allows you to layer up multiple functions on one pattern. For example, the following +-- will play two versions of the pattern at the same time, one reversed and one at twice +-- the speed: +-- +-- > d1 $ layer [rev, fast 2] $ sound "arpy [~ arpy:4]" +-- +-- The original version of the pattern can be included by using the @id@ function: +-- +-- > d1 $ layer [id, rev, fast 2] $ sound "arpy [~ arpy:4]" layer :: [a -> Pattern b] -> a -> Pattern b layer fs p = stack $ map ($ p) fs @@ -1973,78 +1964,81 @@ arpeggiate = arpWith id -- | Shorthand alias for arpeggiate arpg :: Pattern a -> Pattern a arpg = arpeggiate - -arpWith :: ([EventF (ArcF Time) a] -> [EventF (ArcF Time) b]) -> Pattern a -> Pattern b -arpWith f p = withEvents munge p - where munge es = concatMap (spreadOut . f) (groupBy (\a b -> whole a == whole b) $ sortOn whole es) - spreadOut xs = mapMaybe (\(n, x) -> shiftIt n (length xs) x) $ enumerate xs - shiftIt n d (Event c (Just (Arc s e)) a' v) = - do - a'' <- subArc (Arc newS newE) a' - return (Event c (Just $ Arc newS newE) a'' v) - where newS = s + (dur * fromIntegral n) - newE = newS + dur - dur = (e - s) / fromIntegral d - -- TODO ignoring analog events.. Should we just leave them as-is? - shiftIt _ _ _ = Nothing - - -{-| The @arp@ function takes an additional pattern of arpeggiate modes. For example: - -@ -d1 $ sound "superpiano" # n (arp "" "") -@ - -The different arpeggiate modes are: -@ -up down updown downup up&down down&up converge -diverge disconverge pinkyup pinkyupdown -thumbup thumbupdown -@ --} + +arpWith :: ([EventF (ArcF Time) a] -> [EventF (ArcF Time) b]) -> Pattern a -> Pattern b +arpWith f p = withEvents munge p + where + munge es = concatMap (spreadOut . f) (groupBy (\a b -> whole a == whole b) $ sortOn whole es) + spreadOut xs = mapMaybe (\(n, x) -> shiftIt n (length xs) x) $ enumerate xs + shiftIt n d (Event c (Just (Arc s e)) a' v) = + do + a'' <- subArc (Arc newS newE) a' + return (Event c (Just $ Arc newS newE) a'' v) + where + newS = s + (dur * fromIntegral n) + newE = newS + dur + dur = (e - s) / fromIntegral d + -- TODO ignoring analog events.. Should we just leave them as-is? + shiftIt _ _ _ = Nothing + +-- | The @arp@ function takes an additional pattern of arpeggiate modes. For example: +-- +-- @ +-- d1 $ sound "superpiano" # n (arp "" "") +-- @ +-- +-- The different arpeggiate modes are: +-- @ +-- up down updown downup up&down down&up converge +-- diverge disconverge pinkyup pinkyupdown +-- thumbup thumbupdown +-- @ arp :: Pattern String -> Pattern a -> Pattern a arp = patternify _arp _arp :: String -> Pattern a -> Pattern a _arp name p = arpWith f p - where f = fromMaybe id $ lookup name arps - arps :: [(String, [a] -> [a])] - arps = [("up", id), - ("down", reverse), - ("updown", \x -> init x ++ init (reverse x)), - ("downup", \x -> init (reverse x) ++ init x), - ("up&down", \x -> x ++ reverse x), - ("down&up", \x -> reverse x ++ x), - ("converge", converge), - ("diverge", reverse . converge), - ("disconverge", \x -> converge x ++ tail (reverse $ converge x)), - ("pinkyup", pinkyup), - ("pinkyupdown", \x -> init (pinkyup x) ++ init (reverse $ pinkyup x)), - ("thumbup", thumbup), - ("thumbupdown", \x -> init (thumbup x) ++ init (reverse $ thumbup x)) - ] - converge [] = [] - converge (x:xs) = x : converge' xs - converge' [] = [] - converge' xs = last xs : converge (init xs) - pinkyup xs = concatMap (:[pinky]) $ init xs - where pinky = last xs - thumbup xs = concatMap (\x -> [thumb,x]) $ tail xs - where thumb = head xs - -{- | @rolled@ plays each note of a chord quickly in order, as opposed to -simultaneously; to give a chord a harp-like or strum effect. - -Notes are played low to high, and are evenly distributed within (1/4) of the chord event length, as opposed to arp/arpeggiate that spread the notes over the whole event. - -@ -rolled $ n "c'maj'4" # s "superpiano" -@ - -@rolled = rolledBy (1/4)@ --} + where + f = fromMaybe id $ lookup name arps + arps :: [(String, [a] -> [a])] + arps = + [ ("up", id), + ("down", reverse), + ("updown", \x -> init x ++ init (reverse x)), + ("downup", \x -> init (reverse x) ++ init x), + ("up&down", \x -> x ++ reverse x), + ("down&up", \x -> reverse x ++ x), + ("converge", converge), + ("diverge", reverse . converge), + ("disconverge", \x -> converge x ++ tail (reverse $ converge x)), + ("pinkyup", pinkyup), + ("pinkyupdown", \x -> init (pinkyup x) ++ init (reverse $ pinkyup x)), + ("thumbup", thumbup), + ("thumbupdown", \x -> init (thumbup x) ++ init (reverse $ thumbup x)) + ] + converge [] = [] + converge (x : xs) = x : converge' xs + converge' [] = [] + converge' xs = last xs : converge (init xs) + pinkyup xs = concatMap (: [pinky]) $ init xs + where + pinky = last xs + thumbup xs = concatMap (\x -> [thumb, x]) $ tail xs + where + thumb = head xs + +-- | @rolled@ plays each note of a chord quickly in order, as opposed to +-- simultaneously; to give a chord a harp-like or strum effect. +-- +-- Notes are played low to high, and are evenly distributed within (1/4) of the chord event length, as opposed to arp/arpeggiate that spread the notes over the whole event. +-- +-- @ +-- rolled $ n "c'maj'4" # s "superpiano" +-- @ +-- +-- @rolled = rolledBy (1/4)@ rolled :: Pattern a -> Pattern a -rolled = rolledBy (1/4) +rolled = rolledBy (1 / 4) {- As 'rolled', but allows you to specify the length of the roll, i.e., the @@ -2061,17 +2055,19 @@ rolledBy pt = patternify rolledWith (segment 1 $ pt) rolledWith :: Ratio Integer -> Pattern a -> Pattern a rolledWith t = withEvents aux - where aux es = concatMap (steppityIn) (groupBy (\a b -> whole a == whole b) $ ((isRev t) es)) - isRev b = (\x -> if x > 0 then id else reverse ) b - steppityIn xs = mapMaybe (\(n, ev) -> (timeguard n xs ev t)) $ enumerate xs - timeguard _ _ ev 0 = return ev - timeguard n xs ev _ = (shiftIt n (length xs) ev) - shiftIt n d (Event c (Just (Arc s e)) a' v) = do - a'' <- subArc (Arc newS e) a' - return (Event c (Just $ Arc newS e) a'' v) - where newS = s + (dur * fromIntegral n) - dur = ((e - s)) / ((1/ (abs t))*fromIntegral d) - shiftIt _ _ ev = return ev + 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 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' + return (Event c (Just $ Arc newS e) a'' v) + where + newS = s + (dur * fromIntegral n) + dur = ((e - s)) / ((1 / (abs t)) * fromIntegral d) + shiftIt _ _ ev = return ev {- TODO ! @@ -2095,28 +2091,27 @@ fill p' p = struct (splitQueries $ p {query = q, pureValue = Nothing}) p' tolerance = 0.01 -} -{- | @ply n@ repeats each event @n@ times within its arc. - -For example, the following are equivalent: - -@ -d1 $ ply 3 $ s "bd ~ sn cp" -d1 $ s "[bd bd bd] ~ [sn sn sn] [cp cp cp]" -@ - -The first parameter may be given as a pattern, so that the following are equivalent: - -@ -d1 $ ply "2 3" $ s "bd ~ sn cp" -d1 $ s "[bd bd] ~ [sn sn sn] [cp cp cp]" -@ - -Here is an example of it being used conditionally: - -@ -d1 $ every 3 (ply 4) $ s "bd ~ sn cp" -@ --} +-- | @ply n@ repeats each event @n@ times within its arc. +-- +-- For example, the following are equivalent: +-- +-- @ +-- d1 $ ply 3 $ s "bd ~ sn cp" +-- d1 $ s "[bd bd bd] ~ [sn sn sn] [cp cp cp]" +-- @ +-- +-- The first parameter may be given as a pattern, so that the following are equivalent: +-- +-- @ +-- d1 $ ply "2 3" $ s "bd ~ sn cp" +-- d1 $ s "[bd bd] ~ [sn sn sn] [cp cp cp]" +-- @ +-- +-- Here is an example of it being used conditionally: +-- +-- @ +-- d1 $ every 3 (ply 4) $ s "bd ~ sn cp" +-- @ ply :: Pattern Rational -> Pattern a -> Pattern a ply = patternify' _ply @@ -2129,67 +2124,67 @@ plyWith np f p = innerJoin $ (\n -> _plyWith n f p) <$> np _plyWith :: (Ord t, Num t) => t -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a _plyWith numPat f p = arpeggiate $ compound numPat - where compound n | n <= 1 = p - | otherwise = overlay p (f $ compound $ n-1) - -{-| Syncopates a rhythm, shifting (delaying) each event halfway into its arc - (timespan). - - In mini-notation terms, it basically turns every instance of a into @[~ a]@, - e.g., @"a b [c d] e"@ becomes the equivalent of - @"[~ a] [~ b] [[~ c] [~ d]] [~ e]"@. - Every beat then becomes an offbeat, and so the overall effect is to - syncopate a pattern. - - In the following example, you can hear that the piano chords play between the - snare and the bass drum. In 4/4 time, they are playing in the 2 and a half, - and 4 and a half beats: - - > do - > resetCycles - > d1 $ stack [ - > press $ n "~ c'maj ~ c'maj" # s "superpiano" # gain 0.9 # pan 0.6, - > s "[bd,clap sd bd sd]" # pan 0.4 - > ] # cps (90/60/4) - - In the next example, the C major chord plays before the G major. As the slot - that occupies the C chord is that of one eighth note, it is displaced by press - only a sixteenth note: - - > do - > resetCycles - > d1 $ stack [ - > press $ n "~ [c'maj ~] ~ ~" # s "superpiano" # gain 0.9 # pan 0.6, - > press $ n "~ g'maj ~ ~" # s "superpiano" # gain 0.9 # pan 0.4, - > s "[bd,clap sd bd sd]" - > ] # cps (90/60/4) --} + where + compound n + | n <= 1 = p + | otherwise = overlay p (f $ compound $ n - 1) + +-- | Syncopates a rhythm, shifting (delaying) each event halfway into its arc +-- (timespan). +-- +-- In mini-notation terms, it basically turns every instance of a into @[~ a]@, +-- e.g., @"a b [c d] e"@ becomes the equivalent of +-- @"[~ a] [~ b] [[~ c] [~ d]] [~ e]"@. +-- Every beat then becomes an offbeat, and so the overall effect is to +-- syncopate a pattern. +-- +-- In the following example, you can hear that the piano chords play between the +-- snare and the bass drum. In 4/4 time, they are playing in the 2 and a half, +-- and 4 and a half beats: +-- +-- > do +-- > resetCycles +-- > d1 $ stack [ +-- > press $ n "~ c'maj ~ c'maj" # s "superpiano" # gain 0.9 # pan 0.6, +-- > s "[bd,clap sd bd sd]" # pan 0.4 +-- > ] # cps (90/60/4) +-- +-- In the next example, the C major chord plays before the G major. As the slot +-- that occupies the C chord is that of one eighth note, it is displaced by press +-- only a sixteenth note: +-- +-- > do +-- > resetCycles +-- > d1 $ stack [ +-- > press $ n "~ [c'maj ~] ~ ~" # s "superpiano" # gain 0.9 # pan 0.6, +-- > press $ n "~ g'maj ~ ~" # s "superpiano" # gain 0.9 # pan 0.4, +-- > s "[bd,clap sd bd sd]" +-- > ] # cps (90/60/4) press :: Pattern a -> Pattern a press = _pressBy 0.5 -{-| Like @press@, but allows you to specify the amount in which each event is - shifted as a float from 0 to 1 (exclusive). - - @pressBy 0.5@ is the same as @press@, while @pressBy (1/3)@ shifts each event - by a third of its arc. - - You can pattern the displacement to create interesting rhythmic effects: - - > d1 $ stack [ - > s "bd sd bd sd", - > pressBy "<0 0.5>" $ s "co:2*4" - > ] - - > d1 $ stack [ - > s "[bd,co sd bd sd]", - > pressBy "<0 0.25 0.5 0.75>" $ s "cp" - > ] --} +-- | Like @press@, but allows you to specify the amount in which each event is +-- shifted as a float from 0 to 1 (exclusive). +-- +-- @pressBy 0.5@ is the same as @press@, while @pressBy (1/3)@ shifts each event +-- by a third of its arc. +-- +-- You can pattern the displacement to create interesting rhythmic effects: +-- +-- > d1 $ stack [ +-- > s "bd sd bd sd", +-- > pressBy "<0 0.5>" $ s "co:2*4" +-- > ] +-- +-- > d1 $ stack [ +-- > s "[bd,co sd bd sd]", +-- > pressBy "<0 0.25 0.5 0.75>" $ s "cp" +-- > ] pressBy :: Pattern Time -> Pattern a -> Pattern a pressBy = patternify' _pressBy _pressBy :: Time -> Pattern a -> Pattern a -_pressBy r pat = squeezeJoin $ (compressTo (r,1) . pure) <$> pat +_pressBy r pat = squeezeJoin $ (compressTo (r, 1) . pure) <$> pat {- Uses the first (binary) pattern to switch between the following @@ -2218,26 +2213,29 @@ 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 Nothing Nothing - 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 - pattern, not the source patterns. (In 'sew', by contrast, the resulting structure comes from the source patterns.) - - The following uses a euclidean pattern to control CC0: - - > d1 $ ccv (stitch "t(7,16)" 127 0) # ccn 0 # "midi" --} + 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 +-- pattern, not the source patterns. (In 'sew', by contrast, the resulting structure comes from the source patterns.) +-- +-- The following uses a euclidean pattern to control CC0: +-- +-- > d1 $ ccv (stitch "t(7,16)" 127 0) # ccn 0 # "midi" stitch :: Pattern Bool -> Pattern a -> Pattern a -> Pattern a -stitch pb a b = overlay (struct pb a) (struct (inv pb) b) +stitch pb a b = overlay (struct pb a) (struct (inv pb) b) -- | A binary pattern is used to conditionally apply a function to a -- source pattern. The function is applied when a @True@ value is @@ -2247,134 +2245,134 @@ stitch pb a b = overlay (struct pb a) (struct (inv pb) b) while :: Pattern Bool -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a 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). -It is like 'Sound.Tidal.Control.echo' that doesn't reduce the volume, or 'ply' if you controlled the timing. - -> d1 $ stutter 4 (1/16) $ s "bd cp" - -is functionally equivalent to - -> d1 $ stut 4 1 (1/16) $ s "bd cp" --} +-- | +-- @stutter n t pat@ repeats each event in @pat@ @n@ times, separated by @t@ time (in fractions of a cycle). +-- It is like 'Sound.Tidal.Control.echo' that doesn't reduce the volume, or 'ply' if you controlled the timing. +-- +-- > d1 $ stutter 4 (1/16) $ s "bd cp" +-- +-- is functionally equivalent to +-- +-- > d1 $ stut 4 1 (1/16) $ s "bd cp" stutter :: Integral i => i -> Time -> Pattern a -> Pattern a -stutter n t p = stack $ map (\i -> (t * fromIntegral i) `rotR` p) [0 .. (n-1)] - -{- | The @jux@ function creates strange stereo effects by applying a - function to a pattern, but only in the right-hand channel. For - example, the following reverses the pattern on the righthand side: - - > d1 $ slow 32 $ jux (rev) $ striateBy 32 (1/16) $ sound "bev" - - When passing pattern transforms to functions like @jux@ and 'every', - it's possible to chain multiple transforms together with `.` (function - composition). For example this both reverses and halves the playback speed of - the pattern in the righthand channel: +stutter n t p = stack $ map (\i -> (t * fromIntegral i) `rotR` p) [0 .. (n - 1)] - > d1 $ slow 32 $ jux ((# speed "0.5") . rev) $ striateBy 32 (1/16) $ sound "bev" --} -jux - :: (Pattern ValueMap -> Pattern ValueMap) - -> Pattern ValueMap -> Pattern ValueMap +-- | The @jux@ function creates strange stereo effects by applying a +-- function to a pattern, but only in the right-hand channel. For +-- example, the following reverses the pattern on the righthand side: +-- +-- > d1 $ slow 32 $ jux (rev) $ striateBy 32 (1/16) $ sound "bev" +-- +-- When passing pattern transforms to functions like @jux@ and 'every', +-- it's possible to chain multiple transforms together with `.` (function +-- composition). For example this both reverses and halves the playback speed of +-- the pattern in the righthand channel: +-- +-- > d1 $ slow 32 $ jux ((# speed "0.5") . rev) $ striateBy 32 (1/16) $ sound "bev" +jux :: + (Pattern ValueMap -> Pattern ValueMap) -> + Pattern ValueMap -> + Pattern ValueMap jux = juxBy 1 -juxcut - :: (Pattern ValueMap -> Pattern ValueMap) - -> Pattern ValueMap -> Pattern ValueMap -juxcut f p = stack [p # P.pan (pure 0) # P.cut (pure (-1)), - f $ p # P.pan (pure 1) # P.cut (pure (-2)) - ] -juxcut' :: [t -> Pattern ValueMap] -> t -> Pattern ValueMap -juxcut' fs p = stack $ map (\n -> ((fs !! n) p |+ P.cut (pure $ 1-n)) # P.pan (pure $ fromIntegral n / fromIntegral l)) [0 .. l-1] - where l = length fs - -{- | In addition to `jux`, `jux'` allows using a list of pattern - transformations. Resulting patterns from each transformation will be spread via - pan from left to right. - - For example, the following will put @iter 4@ of the pattern to the far left - and `palindrome` to the far right. In the center, the original pattern will - play and the chopped and the reversed version will appear mid left and mid - right respectively. - - > d1 $ jux' [iter 4, chop 16, id, rev, palindrome] $ sound "bd sn" +juxcut :: + (Pattern ValueMap -> Pattern ValueMap) -> + Pattern ValueMap -> + Pattern ValueMap +juxcut f p = + stack + [ p # P.pan (pure 0) # P.cut (pure (-1)), + f $ p # P.pan (pure 1) # P.cut (pure (-2)) + ] -One could also write: - -@ -d1 $ stack - [ iter 4 $ sound "bd sn" # pan "0" - , chop 16 $ sound "bd sn" # pan "0.25" - , sound "bd sn" # pan "0.5" - , rev $ sound "bd sn" # pan "0.75" - , palindrome $ sound "bd sn" # pan "1" - ] -@ +juxcut' :: [t -> Pattern ValueMap] -> t -> Pattern ValueMap +juxcut' fs p = stack $ map (\n -> ((fs !! n) p |+ P.cut (pure $ 1 - n)) # P.pan (pure $ fromIntegral n / fromIntegral l)) [0 .. l - 1] + where + l = length fs --} +-- | In addition to `jux`, `jux'` allows using a list of pattern +-- transformations. Resulting patterns from each transformation will be spread via +-- pan from left to right. +-- +-- For example, the following will put @iter 4@ of the pattern to the far left +-- and `palindrome` to the far right. In the center, the original pattern will +-- play and the chopped and the reversed version will appear mid left and mid +-- right respectively. +-- +-- > d1 $ jux' [iter 4, chop 16, id, rev, palindrome] $ sound "bd sn" +-- +-- One could also write: +-- +-- @ +-- d1 $ stack +-- [ iter 4 $ sound "bd sn" # pan "0" +-- , chop 16 $ sound "bd sn" # pan "0.25" +-- , sound "bd sn" # pan "0.5" +-- , rev $ sound "bd sn" # pan "0.75" +-- , palindrome $ sound "bd sn" # pan "1" +-- ] +-- @ jux' :: [t -> Pattern ValueMap] -> t -> Pattern ValueMap -jux' fs p = stack $ map (\n -> (fs !! n) p |+ P.pan (pure $ fromIntegral n / fromIntegral l)) [0 .. l-1] - where l = length fs +jux' fs p = stack $ map (\n -> (fs !! n) p |+ P.pan (pure $ fromIntegral n / fromIntegral l)) [0 .. l - 1] + where + l = length fs -- | Multichannel variant of `jux`, /not sure what it does/ -jux4 - :: (Pattern ValueMap -> Pattern ValueMap) - -> Pattern ValueMap -> Pattern ValueMap -jux4 f p = stack [p # P.pan (pure (5/8)), f $ p # P.pan (pure (1/8))] - -{- | -With `jux`, the original and effected versions of the pattern are -panned hard left and right (i.e., panned at 0 and 1). This can be a -bit much, especially when listening on headphones. The variant @juxBy@ -has an additional parameter, which brings the channel closer to the -centre. For example: - -> d1 $ juxBy 0.5 (fast 2) $ sound "bd sn:1" - -In the above, the two versions of the pattern would be panned at 0.25 -and 0.75, rather than 0 and 1. --} -juxBy - :: Pattern Double - -> (Pattern ValueMap -> Pattern ValueMap) - -> Pattern ValueMap - -> Pattern ValueMap +jux4 :: + (Pattern ValueMap -> Pattern ValueMap) -> + Pattern ValueMap -> + Pattern ValueMap +jux4 f p = stack [p # P.pan (pure (5 / 8)), f $ p # P.pan (pure (1 / 8))] + +-- | +-- With `jux`, the original and effected versions of the pattern are +-- panned hard left and right (i.e., panned at 0 and 1). This can be a +-- bit much, especially when listening on headphones. The variant @juxBy@ +-- has an additional parameter, which brings the channel closer to the +-- centre. For example: +-- +-- > d1 $ juxBy 0.5 (fast 2) $ sound "bd sn:1" +-- +-- In the above, the two versions of the pattern would be panned at 0.25 +-- and 0.75, rather than 0 and 1. +juxBy :: + Pattern Double -> + (Pattern ValueMap -> Pattern ValueMap) -> + Pattern ValueMap -> + Pattern ValueMap -- 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 -suitable to pass to 'Data.String.fromString' to create a 'Pattern String'. -'samples' is a 'Pattern'-compatible interface to this function. +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)] -@pick name n = name ++ ":" ++ show n@ --} +-- | +-- Given a sample's directory name and number, this generates a string +-- suitable to pass to 'Data.String.fromString' to create a 'Pattern String'. +-- 'samples' is a 'Pattern'-compatible interface to this function. +-- +-- @pick name n = name ++ ":" ++ show n@ pick :: String -> Int -> String pick name n = name ++ ":" ++ show n -{- | -Given a pattern of sample directory names and a of pattern indices -create a pattern of strings corresponding to the sample at each -name-index pair. - -An example: - -> samples "jvbass [~ latibro] [jvbass [latibro jvbass]]" -> ((1%2) `rotL` slow 6 "[1 6 8 7 3]") - -The type signature is more general here, but you can consider this -to be a function of type @Pattern String -> Pattern Int -> Pattern String@. - -@samples = liftA2 pick@ --} +-- | +-- Given a pattern of sample directory names and a of pattern indices +-- create a pattern of strings corresponding to the sample at each +-- name-index pair. +-- +-- An example: +-- +-- > samples "jvbass [~ latibro] [jvbass [latibro jvbass]]" +-- > ((1%2) `rotL` slow 6 "[1 6 8 7 3]") +-- +-- The type signature is more general here, but you can consider this +-- to be a function of type @Pattern String -> Pattern Int -> Pattern String@. +-- +-- @samples = liftA2 pick@ samples :: Applicative f => f String -> f Int -> f String samples p p' = pick <$> p <*> p' -{- | -Equivalent to 'samples', though the sample specifier pattern -(the @f Int@) will be evaluated first. Not a large difference -in the majority of cases. --} +-- | +-- Equivalent to 'samples', though the sample specifier pattern +-- (the @f Int@) will be evaluated first. Not a large difference +-- in the majority of cases. samples' :: Applicative f => f String -> f Int -> f String samples' p p' = flip pick <$> p' <*> p @@ -2399,9 +2397,11 @@ spreadf :: [a -> Pattern b] -> a -> Pattern b spreadf = spread ($) stackwith :: Unionable a => Pattern a -> [Pattern a] -> Pattern a -stackwith p ps | null ps = silence - | otherwise = stack $ map (\(i, p') -> p' # ((fromIntegral i % l) `rotL` p)) (zip [0::Int ..] ps) - where l = fromIntegral $ length ps +stackwith p ps + | null ps = silence + | otherwise = stack $ map (\(i, p') -> p' # ((fromIntegral i % l) `rotL` p)) (zip [0 :: Int ..] ps) + where + l = fromIntegral $ length ps {- cross f p p' = pattern $ \t -> concat [filter flt $ arc p t, @@ -2410,52 +2410,49 @@ cross f p p' = pattern $ \t -> concat [filter flt $ arc p t, ] where flt = f . cyclePos . fst . fst -} -{- | `range` will take a pattern which goes from 0 to 1 (like `sine`), and range it to a different range - between the first and second arguments. In the below example, `range 1 1.5` shifts the range of `sine1` from 0 - 1 to 1 - 1.5. - -> d1 $ jux (iter 4) $ sound "arpy arpy:2*2" -> |+ speed (slow 4 $ range 1 1.5 sine1) - -The above is equivalent to: - -> d1 $ jux (iter 4) $ sound "arpy arpy:2*2" -> |+ speed (slow 4 $ sine1 * 0.5 + 1) --} +-- | `range` will take a pattern which goes from 0 to 1 (like `sine`), and range it to a different range - between the first and second arguments. In the below example, `range 1 1.5` shifts the range of `sine1` from 0 - 1 to 1 - 1.5. +-- +-- > d1 $ jux (iter 4) $ sound "arpy arpy:2*2" +-- > |+ speed (slow 4 $ range 1 1.5 sine1) +-- +-- The above is equivalent to: +-- +-- > d1 $ jux (iter 4) $ sound "arpy arpy:2*2" +-- > |+ speed (slow 4 $ sine1 * 0.5 + 1) range :: Num a => Pattern a -> Pattern a -> Pattern a -> Pattern a -range fromP toP p = (\from to v -> ((v * (to-from)) + from)) <$> fromP *> toP *> p +range fromP toP p = (\from to v -> ((v * (to - from)) + from)) <$> fromP *> toP *> p _range :: (Functor f, Num b) => b -> b -> f b -> f b -_range from to p = (+ from) . (* (to-from)) <$> p - -{- | `rangex` is an exponential version of `range`, good for using with -frequencies. For example, @range 20 2000 "0.5"@ will give @1010@ - halfway -between @20@ and @2000@. But @rangex 20 2000 0.5@ will give @200@ - halfway -between on a logarithmic scale. This usually sounds better if you’re using the -numbers as pitch frequencies. Since rangex uses logarithms, don’t try to scale -things to zero or less. --} +_range from to p = (+ from) . (* (to - from)) <$> p + +-- | `rangex` is an exponential version of `range`, good for using with +-- frequencies. For example, @range 20 2000 "0.5"@ will give @1010@ - halfway +-- between @20@ and @2000@. But @rangex 20 2000 0.5@ will give @200@ - halfway +-- between on a logarithmic scale. This usually sounds better if you’re using the +-- numbers as pitch frequencies. Since rangex uses logarithms, don’t try to scale +-- things to zero or less. rangex :: (Functor f, Floating b) => b -> b -> f b -> f b rangex from to p = exp <$> _range (log from) (log to) p -{-| - @off@ is similar to 'superimpose', in that it applies a function to a pattern - and layers up the results on top of the original pattern. The difference - is that @off@ takes an extra pattern being a time (in cycles) to shift the - transformed version of the pattern by. - - The following plays a pattern on top of itself, but offset by an eighth of a - cycle, with a distorting bitcrush effect applied: - - > d1 $ off 0.125 (# crush 2) $ sound "bd [~ sn:2] mt lt*2" - - The following makes arpeggios by adding offset patterns that are shifted up - the scale: - - > d1 $ slow 2 - > $ n (off 0.25 (+12) - > $ off 0.125 (+7) - > $ slow 2 "c(3,8) a(3,8,2) f(3,8) e(3,8,4)") - > # sound "superpiano" --} +-- | +-- @off@ is similar to 'superimpose', in that it applies a function to a pattern +-- and layers up the results on top of the original pattern. The difference +-- is that @off@ takes an extra pattern being a time (in cycles) to shift the +-- transformed version of the pattern by. +-- +-- The following plays a pattern on top of itself, but offset by an eighth of a +-- cycle, with a distorting bitcrush effect applied: +-- +-- > d1 $ off 0.125 (# crush 2) $ sound "bd [~ sn:2] mt lt*2" +-- +-- The following makes arpeggios by adding offset patterns that are shifted up +-- the scale: +-- +-- > d1 $ slow 2 +-- > $ n (off 0.25 (+12) +-- > $ off 0.125 (+7) +-- > $ slow 2 "c(3,8) a(3,8,2) f(3,8) e(3,8,4)") +-- > # sound "superpiano" off :: Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a off tp f p = innerJoin $ (\tv -> _off tv f p) <$> tp @@ -2463,67 +2460,65 @@ _off :: Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a _off t f p = superimpose (f . (t `rotR`)) p offadd :: Num a => Pattern Time -> Pattern a -> Pattern a -> Pattern a -offadd tp pn p = off tp (+pn) p - -{- | - @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, @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 (sseq "sn" "x x 12 ") --} +offadd tp pn p = off tp (+ pn) p + +-- | +-- @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, @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 (sseq "sn" "x x 12 ") 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 - -{- | @sseqs@ is like @sseq@ but it takes a list of pairs, like sseq would, and - it plays them all simultaneously. + where + f c + | c == 'x' = pure s + | isDigit c = pure $ s ++ ":" ++ [c] + | otherwise = silence - > d1 $ s (sseqs [("cp","x x x x x x"),("bd", "xxxx")]) --} +-- | @sseqs@ is like @sseq@ but it takes a list of pairs, like sseq would, and +-- it plays them all simultaneously. +-- +-- > d1 $ s (sseqs [("cp","x x x x x x"),("bd", "xxxx")]) sseqs :: [(String, String)] -> Pattern String sseqs = stack . map (uncurry sseq) -{- | like `sseq`, but allows you to specify an array of strings to use for @0,1,2...@ - For example, - - > d1 $ s (sseq' ["superpiano","supermandolin"] "0 1 000 1") - > # sustain 4 # n 0 - - is equivalent to - - > d1 $ s "superpiano ~ supermandolin ~ superpiano!3 ~ supermandolin" - > # sustain 4 # n 0 --} +-- | like `sseq`, but allows you to specify an array of strings to use for @0,1,2...@ +-- For example, +-- +-- > d1 $ s (sseq' ["superpiano","supermandolin"] "0 1 000 1") +-- > # sustain 4 # n 0 +-- +-- is equivalent to +-- +-- > d1 $ s "superpiano ~ supermandolin ~ superpiano!3 ~ supermandolin" +-- > # sustain 4 # n 0 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 - + where + f c + | c == 'x' = pure $ head ss + | isDigit c = pure $ ss !! digitToInt c + | otherwise = silence -- | Deprecated backwards-compatible alias for 'ghostWith'. ghost'' :: Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a ghost'' = ghostWith -{-| Like 'ghost'', but a user-supplied function describes how to alter the pattern. - - In this example, ghost notes are applied to the snare hit, but these notes will - be louder, not quieter, and the sample will have its beginning slightly cut: - - > d1 $ slow 2 - > $ ghostWith (1/16) ((|*| gain 1.1) . (|> begin 0.05)) - > $ sound "sn" - --} +-- | Like 'ghost'', but a user-supplied function describes how to alter the pattern. +-- +-- In this example, ghost notes are applied to the snare hit, but these notes will +-- be louder, not quieter, and the sample will have its beginning slightly cut: +-- +-- > d1 $ slow 2 +-- > $ ghostWith (1/16) ((|*| gain 1.1) . (|> begin 0.05)) +-- > $ sound "sn" ghostWith :: Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a -ghostWith a f p = superimpose (((a*2.5) `rotR`) . f) $ superimpose (((a*1.5) `rotR`) . f) p +ghostWith a f p = superimpose (((a * 2.5) `rotR`) . f) $ superimpose (((a * 1.5) `rotR`) . f) p {- @ghost' t pat@ Adds quieter, pitch-shifted, copies of an event @t@ cycles after events in @pat@, emulating ghost notes that are common in drumming patterns. @@ -2535,31 +2530,31 @@ The following creates a kick snare pattern with ghost notes applied to the snare ghost' :: Time -> Pattern ValueMap -> Pattern ValueMap ghost' a p = ghostWith a ((|*| P.gain (pure 0.7)) . (|> P.end (pure 0.2)) . (|*| P.speed (pure 1.25))) p -{-| As 'ghost'', but with the copies set to appear one-eighth of a cycle afterwards. - -@ghost = ghost' 0.125@ - -The following creates a kick snare pattern with ghost notes applied to the snare hit: - -> d1 $ stack [ ghost $ sound "~ sn", sound "bd*2 [~ bd]" ] --} +-- | As 'ghost'', but with the copies set to appear one-eighth of a cycle afterwards. +-- +-- @ghost = ghost' 0.125@ +-- +-- The following creates a kick snare pattern with ghost notes applied to the snare hit: +-- +-- > d1 $ stack [ ghost $ sound "~ sn", sound "bd*2 [~ bd]" ] ghost :: Pattern ValueMap -> Pattern ValueMap ghost = ghost' 0.125 -{- | A more literal weaving than the `weave` function. Given @tabby threads p1 p@, - parameters representing the threads per cycle and the patterns to weave, and - this function will weave them together using a plain (aka ’tabby’) weave, - with a simple over/under structure - -} +-- | A more literal weaving than the `weave` function. Given @tabby threads p1 p@, +-- parameters representing the threads per cycle and the patterns to weave, and +-- this function will weave them together using a plain (aka ’tabby’) weave, +-- with a simple over/under structure tabby :: Int -> Pattern a -> Pattern a -> Pattern a -tabby nInt p p' = stack [maskedWarp, - maskedWeft - ] +tabby nInt p p' = + stack + [ maskedWarp, + maskedWeft + ] where n = fromIntegral nInt - weft = concatMap (const [[0..n-1], reverse [0..n-1]]) [0 .. (n `div` 2) - 1] + weft = concatMap (const [[0 .. n - 1], reverse [0 .. n - 1]]) [0 .. (n `div` 2) - 1] warp = transpose weft - thread xs p'' = _slow (n%1) $ fastcat $ map (\i -> zoomArc (Arc (i%n) ((i+1)%n)) p'') (concat xs) + thread xs p'' = _slow (n % 1) $ fastcat $ map (\i -> zoomArc (Arc (i % n) ((i + 1) % n)) p'') (concat xs) weftP = thread weft p' warpP = thread warp p maskedWeft = mask (every 2 rev $ _fast (n % 2) $ fastCat [silence, pure True]) weftP @@ -2570,108 +2565,112 @@ select :: Pattern Double -> [Pattern a] -> Pattern a select = patternify _select _select :: Double -> [Pattern a] -> Pattern a -_select f ps = ps !! floor (max 0 (min 1 f) * fromIntegral (length ps - 1)) +_select f ps = ps !! floor (max 0 (min 1 f) * fromIntegral (length ps - 1)) -- | Chooses from a list of functions, using a pattern of floats (from 0 to 1). selectF :: Pattern Double -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a selectF pf ps p = innerJoin $ (\f -> _selectF f ps p) <$> pf _selectF :: Double -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a -_selectF f ps p = (ps !! floor (max 0 (min 0.999999 f) * fromIntegral (length ps))) p +_selectF f ps p = (ps !! floor (max 0 (min 0.999999 f) * fromIntegral (length ps))) p -- | Chooses from a list of functions, using a pattern of integers. pickF :: Pattern Int -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a pickF pInt fs pat = innerJoin $ (\i -> _pickF i fs pat) <$> pInt _pickF :: Int -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a -_pickF i fs p = (fs !!! i) p - -{- | @contrast f f' p p'@ splits the control pattern @p'@ in two, applying - the function @f@ to one and @f'@ to the other. This depends on - whether events in @p'@ contain values matching with those in @p@. - For example, in - - > contrast (# crush 3) (# vowel "a") (n "1") $ n "0 1" # s "bd sn" # speed 3 - - the first event will have the vowel effect applied and the second will have - the crush applied. - - @contrast@ is like an if-else-statement over patterns. For @contrast t f p@ - you can think of @t@ as the true branch, @f@ as the false branch, and @p@ as - the test. +_pickF i fs p = (fs !!! i) p - You can use any control pattern as a test of equality, e.g., @n "<0 1>", speed - "0.5"@, or things like that. This lets you choose specific properties of the - pattern you’re transforming for testing, like in the following example, - - > d1 $ contrast (|+ n 12) (|- n 12) (n "c") $ n (run 4) # s "superpiano" - - where every note that isn’t middle-c will be shifted down an octave but - middle-c will be shifted up to c5. - - Since the test given to contrast is also a pattern, you can do things like have - it alternate between options: - - > d1 $ contrast (|+ n 12) (|- n 12) (s "") - > $ s "superpiano superchip" # n 0 - - If you listen to this you’ll hear that which instrument is shifted up and which - instrument is shifted down alternates between cycles. --} -contrast :: (ControlPattern -> ControlPattern) -> (ControlPattern -> ControlPattern) - -> ControlPattern -> ControlPattern -> ControlPattern +-- | @contrast f f' p p'@ splits the control pattern @p'@ in two, applying +-- the function @f@ to one and @f'@ to the other. This depends on +-- whether events in @p'@ contain values matching with those in @p@. +-- For example, in +-- +-- > contrast (# crush 3) (# vowel "a") (n "1") $ n "0 1" # s "bd sn" # speed 3 +-- +-- the first event will have the vowel effect applied and the second will have +-- the crush applied. +-- +-- @contrast@ is like an if-else-statement over patterns. For @contrast t f p@ +-- you can think of @t@ as the true branch, @f@ as the false branch, and @p@ as +-- the test. +-- +-- You can use any control pattern as a test of equality, e.g., @n "<0 1>", speed +-- "0.5"@, or things like that. This lets you choose specific properties of the +-- pattern you’re transforming for testing, like in the following example, +-- +-- > d1 $ contrast (|+ n 12) (|- n 12) (n "c") $ n (run 4) # s "superpiano" +-- +-- where every note that isn’t middle-c will be shifted down an octave but +-- middle-c will be shifted up to c5. +-- +-- Since the test given to contrast is also a pattern, you can do things like have +-- it alternate between options: +-- +-- > d1 $ contrast (|+ n 12) (|- n 12) (s "") +-- > $ s "superpiano superchip" # n 0 +-- +-- If you listen to this you’ll hear that which instrument is shifted up and which +-- instrument is shifted down alternates between cycles. +contrast :: + (ControlPattern -> ControlPattern) -> + (ControlPattern -> ControlPattern) -> + ControlPattern -> + ControlPattern -> + ControlPattern contrast = contrastBy (==) -{-| - @contrastBy@ is contrastBy is the general version of 'contrast', in which you can specify an abritrary boolean function that will be used to compare the control patterns. - - > d2 $ contrastBy (>=) (|+ n 12) (|- n 12) (n "2") $ n "0 1 2 [3 4]" # s "superpiano" --} -contrastBy :: (a -> Value -> Bool) - -> (ControlPattern -> Pattern b) - -> (ControlPattern -> Pattern b) - -> Pattern (Map.Map String a) - -> Pattern (Map.Map String Value) - -> Pattern b +-- | +-- @contrastBy@ is contrastBy is the general version of 'contrast', in which you can specify an abritrary boolean function that will be used to compare the control patterns. +-- +-- > d2 $ contrastBy (>=) (|+ n 12) (|- n 12) (n "2") $ n "0 1 2 [3 4]" # s "superpiano" +contrastBy :: + (a -> Value -> Bool) -> + (ControlPattern -> Pattern b) -> + (ControlPattern -> Pattern b) -> + Pattern (Map.Map String a) -> + Pattern (Map.Map String Value) -> + Pattern b contrastBy comp f f' p p' = overlay (f matched) (f' unmatched) - where matches = matchManyToOne (flip $ Map.isSubmapOfBy comp) p p' - matched :: ControlPattern - matched = filterJust $ (\(t, a) -> if t then Just a else Nothing) <$> matches - unmatched :: ControlPattern - unmatched = filterJust $ (\(t, a) -> if not t then Just a else Nothing) <$> matches - -contrastRange - :: (ControlPattern -> Pattern a) - -> (ControlPattern -> Pattern a) - -> Pattern (Map.Map String (Value, Value)) - -> ControlPattern - -> Pattern a + where + matches = matchManyToOne (flip $ Map.isSubmapOfBy comp) p p' + matched :: ControlPattern + matched = filterJust $ (\(t, a) -> if t then Just a else Nothing) <$> matches + unmatched :: ControlPattern + unmatched = filterJust $ (\(t, a) -> if not t then Just a else Nothing) <$> matches + +contrastRange :: + (ControlPattern -> Pattern a) -> + (ControlPattern -> Pattern a) -> + Pattern (Map.Map String (Value, Value)) -> + ControlPattern -> + Pattern a contrastRange = contrastBy f - where f (VI s, VI e) (VI v) = v >= s && v <= e - 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 - -{- | - The @fix@ function applies another function to matching events in a pattern of - controls. @fix@ is 'contrast' where the false-branching function is set to the - identity 'id'. It is like 'contrast', but one function is given and applied to - events with matching controls. - - For example, the following only adds the 'crush' control when the @n@ control - is set to either 1 or 4: - - > d1 $ slow 2 - > $ fix (# crush 3) (n "[1,4]") - > $ n "0 1 2 3 4 5 6" - > # sound "arpy" - - You can be quite specific; for example, the following applies the function - @'hurry' 2@ to sample 1 of the drum sample set, and leaves the rest as they are: - - > fix (hurry 2) (s "drum" # n "1") --} + where + f (VI s, VI e) (VI v) = v >= s && v <= e + 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 + +-- | +-- The @fix@ function applies another function to matching events in a pattern of +-- controls. @fix@ is 'contrast' where the false-branching function is set to the +-- identity 'id'. It is like 'contrast', but one function is given and applied to +-- events with matching controls. +-- +-- For example, the following only adds the 'crush' control when the @n@ control +-- is set to either 1 or 4: +-- +-- > d1 $ slow 2 +-- > $ fix (# crush 3) (n "[1,4]") +-- > $ n "0 1 2 3 4 5 6" +-- > # sound "arpy" +-- +-- You can be quite specific; for example, the following applies the function +-- @'hurry' 2@ to sample 1 of the drum sample set, and leaves the rest as they are: +-- +-- > fix (hurry 2) (s "drum" # n "1") fix :: (ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern -> ControlPattern fix f = contrast f id @@ -2681,60 +2680,60 @@ fix f = contrast f id unfix :: (ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern -> ControlPattern unfix = contrast id -{-| - The @fixRange@ function isn’t very user-friendly at the moment, but you can - create a @fix@ variant with a range condition. Any value of a 'ControlPattern' - wich matches the values will apply the passed function. - - > d1 $ ( fixRange ( (# distort 1) . (# gain 0.8) ) - > ( pure $ Map.singleton "note" ((VN 0, VN 7)) ) - > ) - > $ s "superpiano" - > <| note "1 12 7 11" --} -fixRange :: (ControlPattern -> Pattern ValueMap) - -> Pattern (Map.Map String (Value, Value)) - -> ControlPattern - -> ControlPattern +-- | +-- The @fixRange@ function isn’t very user-friendly at the moment, but you can +-- create a @fix@ variant with a range condition. Any value of a 'ControlPattern' +-- wich matches the values will apply the passed function. +-- +-- > d1 $ ( fixRange ( (# distort 1) . (# gain 0.8) ) +-- > ( pure $ Map.singleton "note" ((VN 0, VN 7)) ) +-- > ) +-- > $ s "superpiano" +-- > <| note "1 12 7 11" +fixRange :: + (ControlPattern -> Pattern ValueMap) -> + Pattern (Map.Map String (Value, Value)) -> + ControlPattern -> + ControlPattern fixRange f = contrastRange f id -unfixRange :: (ControlPattern -> Pattern ValueMap) - -> Pattern (Map.Map String (Value, Value)) - -> ControlPattern - -> ControlPattern +unfixRange :: + (ControlPattern -> Pattern ValueMap) -> + Pattern (Map.Map String (Value, Value)) -> + ControlPattern -> + ControlPattern unfixRange = contrastRange id -{- | @quantise@ limits values in a Pattern (or other Functor) to @n@ equally spaced -divisions of 1. - -It is useful for rounding a collection of numbers to some particular base -fraction. For example, - -> quantise 5 [0, 1.3 ,2.6,3.2,4.7,5] - -It will round all the values to the nearest @(1/5)=0.2@ and thus will output -the list @[0.0,1.2,2.6,3.2,4.8,5.0]@. You can use this function to force a -continuous pattern like sine into specific values. In the following example: - -> d1 $ s "superchip*8" # n (quantise 1 $ range (-10) (10) $ slow 8 $ cosine) -> # release (quantise 5 $ slow 8 $ sine + 0.1) - -all the releases selected be rounded to the nearest @0.1@ and the notes selected -to the nearest @1@. - -@quantise@ with fractional inputs does the consistent thing: @quantise 0.5@ -rounds values to the nearest @2@, @quantise 0.25@ rounds the nearest @4@, etc. --} +-- | @quantise@ limits values in a Pattern (or other Functor) to @n@ equally spaced +-- divisions of 1. +-- +-- It is useful for rounding a collection of numbers to some particular base +-- fraction. For example, +-- +-- > quantise 5 [0, 1.3 ,2.6,3.2,4.7,5] +-- +-- It will round all the values to the nearest @(1/5)=0.2@ and thus will output +-- the list @[0.0,1.2,2.6,3.2,4.8,5.0]@. You can use this function to force a +-- continuous pattern like sine into specific values. In the following example: +-- +-- > d1 $ s "superchip*8" # n (quantise 1 $ range (-10) (10) $ slow 8 $ cosine) +-- > # release (quantise 5 $ slow 8 $ sine + 0.1) +-- +-- all the releases selected be rounded to the nearest @0.1@ and the notes selected +-- to the nearest @1@. +-- +-- @quantise@ with fractional inputs does the consistent thing: @quantise 0.5@ +-- rounds values to the nearest @2@, @quantise 0.25@ rounds the nearest @4@, etc. quantise :: (Functor f, RealFrac b) => b -> f b -> f b -quantise n = fmap ((/n) . (fromIntegral :: RealFrac b => Int -> b) . round . (*n)) +quantise n = fmap ((/ n) . (fromIntegral :: RealFrac b => Int -> b) . round . (* n)) -- | As 'quantise', but uses 'Prelude.floor' to calculate divisions. qfloor :: (Functor f, RealFrac b) => b -> f b -> f b -qfloor n = fmap ((/n) . (fromIntegral :: RealFrac b => Int -> b) . floor . (*n)) +qfloor n = fmap ((/ n) . (fromIntegral :: RealFrac b => Int -> b) . floor . (* n)) -- | As 'quantise', but uses 'Prelude.ceiling' to calculate divisions. qceiling :: (Functor f, RealFrac b) => b -> f b -> f b -qceiling n = fmap ((/n) . (fromIntegral :: RealFrac b => Int -> b) . ceiling . (*n)) +qceiling n = fmap ((/ n) . (fromIntegral :: RealFrac b => Int -> b) . ceiling . (* n)) -- | An alias for 'quantise'. qround :: (Functor f, RealFrac b) => b -> f b -> f b @@ -2747,26 +2746,28 @@ 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 - flatten :: [Event a] -> [Event a] - flatten = mapMaybe constrainPart . truncateOverlaps . sortOn whole - 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 - | stop (wholeOrPart b) <= stop (wholeOrPart a) = Nothing - | otherwise = Just b {whole = Just $ Arc (stop $ wholeOrPart a) (stop $ wholeOrPart b)} - constrainPart :: Event a -> Maybe (Event a) - constrainPart e = do a <- subArc (wholeOrPart e) (part e) - return $ e {part = a} - -{-| -@smooth@ receives a pattern of numbers and linearly goes from one to the next, passing through all of them. As time is cycle-based, after reaching the last number in the pattern, it will smoothly go to the first one again. - -> d1 $ sound "bd*4" # pan (slow 4 $ smooth "0 1 0.5 1") - -This sound will pan gradually from left to right, then to the center, then to the right again, and finally comes back to the left. --} +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 (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 + | stop (wholeOrPart b) <= stop (wholeOrPart a) = Nothing + | otherwise = Just b {whole = Just $ Arc (stop $ wholeOrPart a) (stop $ wholeOrPart b)} + constrainPart :: Event a -> Maybe (Event a) + constrainPart e = do + a <- subArc (wholeOrPart e) (part e) + return $ e {part = a} + +-- | +-- @smooth@ receives a pattern of numbers and linearly goes from one to the next, passing through all of them. As time is cycle-based, after reaching the last number in the pattern, it will smoothly go to the first one again. +-- +-- > d1 $ sound "bd*4" # pan (slow 4 $ smooth "0 1 0.5 1") +-- +-- This sound will pan gradually from left to right, then to the center, then to the right again, and finally comes back to the left. -- serialize the given pattern -- find the middle of the query's arc and use that to query the serialized pattern. We should get either no events or a single event back @@ -2782,54 +2783,56 @@ smooth p = pattern $ \st@(State a cm) -> tween st a $ query monoP (State (midArc where midArc a = Arc (mid (start a, stop a)) (mid (start a, stop a)) tween _ _ [] = [] - tween st queryA (e:_) = maybe [e {whole = Just queryA, part = queryA}] (tween' queryA) (nextV st) - where aStop = Arc (wholeStop e) (wholeStop e) - nextEs st' = query monoP (st' {arc = aStop}) - nextV st' | null (nextEs st') = Nothing - | otherwise = Just $ value (head (nextEs st')) - tween' queryA' v = - [ Event - { context = context e, - whole = Just queryA' - , part = queryA' - , value = value e + ((v - value e) * pc)} - ] - pc | delta' (wholeOrPart e) == 0 = 0 - | otherwise = fromRational $ (eventPartStart e - wholeStart e) / delta' (wholeOrPart e) - delta' a = stop a - start a + tween st queryA (e : _) = maybe [e {whole = Just queryA, part = queryA}] (tween' queryA) (nextV st) + where + aStop = Arc (wholeStop e) (wholeStop e) + nextEs st' = query monoP (st' {arc = aStop}) + nextV st' + | null (nextEs st') = Nothing + | otherwise = Just $ value (head (nextEs st')) + tween' queryA' v = + [ Event + { context = context e, + whole = Just queryA', + part = queryA', + value = value e + ((v - value e) * pc) + } + ] + pc + | delta' (wholeOrPart e) == 0 = 0 + | otherwise = fromRational $ (eventPartStart e - wholeStart e) / delta' (wholeOrPart e) + delta' a = stop a - start a monoP = mono p -- | Looks up values from a list of tuples, in order to swap values in the given pattern swap :: Eq a => [(a, b)] -> Pattern a -> Pattern b swap things p = filterJust $ (`lookup` things) <$> p -{-| - @snowball@ takes a function that can combine patterns (like '+'), - a function that transforms a pattern (like 'slow'), - a depth, and a starting pattern, - it will then transform the pattern and combine it with the last transformation until the depth is reached. - This is like putting an effect (like a filter) in the feedback of a delay line; each echo is more affected. - - > d1 $ note ( scale "hexDorian" - > $ snowball 8 (+) (slow 2 . rev) "0 ~ . -1 . 5 3 4 . ~ -2" - > ) - > # s "gtr" --} +-- | +-- @snowball@ takes a function that can combine patterns (like '+'), +-- a function that transforms a pattern (like 'slow'), +-- a depth, and a starting pattern, +-- it will then transform the pattern and combine it with the last transformation until the depth is reached. +-- This is like putting an effect (like a filter) in the feedback of a delay line; each echo is more affected. +-- +-- > d1 $ note ( scale "hexDorian" +-- > $ snowball 8 (+) (slow 2 . rev) "0 ~ . -1 . 5 3 4 . ~ -2" +-- > ) +-- > # s "gtr" snowball :: Int -> (Pattern a -> Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a 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 - applying the function until the depth is reached this can be used to create - a pattern that wanders away from the original pattern by continually adding - random numbers. - - > d1 $ note ( scale "hexDorian" mutateBy (+ (range -1 1 $ irand 2)) 8 - > $ "0 1 . 2 3 4" - > ) - > # s "gtr" --} -soak :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a +-- | +-- Applies a function to a pattern and cats the resulting pattern, then continues +-- applying the function until the depth is reached this can be used to create +-- a pattern that wanders away from the original pattern by continually adding +-- random numbers. +-- +-- > d1 $ note ( scale "hexDorian" mutateBy (+ (range -1 1 $ irand 2)) 8 +-- > $ "0 1 . 2 3 4" +-- > ) +-- > # s "gtr" +soak :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a soak depth f pat = cat $ take depth $ iterate f pat -- | @construct n p@ breaks @p@ into pieces and then reassembles them @@ -2838,79 +2841,84 @@ 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') ..] - arcs = zip (take n breaks) (drop 1 breaks) - n' = fromIntegral n - -{- | @bite n ipat pat@ slices a pattern @pat@ into @n@ pieces, then uses the - @ipat@ pattern of integers to index into those slices. So @bite 4 "0 2*2" (run - 8)@ is the same as @"[0 1] [4 5]*2"@. - - I.e., it allows you to slice each cycle into a given number of equal sized - bits, and then pattern those bits by number. It’s similar to @slice@, but is - for slicing up patterns, rather than samples. The following slices the pattern - into four bits, and then plays those bits in turn: - - > d1 $ bite 4 "0 1 2 3" $ n "0 .. 7" # sound "arpy" - - Of course that doesn’t actually change anything, but then you can reorder those bits: - - > d1 $ bite 4 "2 0 1 3" $ n "0 .. 7" # sound "arpy" - - The slices bits of pattern will be squeezed or contracted to fit: - - > d1 $ bite 4 "2 [0 3] 1*4 1" $ n "0 .. 7" # sound "arpy" --} + toList pat = map (\(s, e) -> map value $ queryArc (_segment n' pat) (Arc s e)) arcs + where + breaks = [0, (1 / n') ..] + arcs = zip (take n breaks) (drop 1 breaks) + n' = fromIntegral n + +-- | @bite n ipat pat@ slices a pattern @pat@ into @n@ pieces, then uses the +-- @ipat@ pattern of integers to index into those slices. So @bite 4 "0 2*2" (run +-- 8)@ is the same as @"[0 1] [4 5]*2"@. +-- +-- I.e., it allows you to slice each cycle into a given number of equal sized +-- bits, and then pattern those bits by number. It’s similar to @slice@, but is +-- for slicing up patterns, rather than samples. The following slices the pattern +-- into four bits, and then plays those bits in turn: +-- +-- > d1 $ bite 4 "0 1 2 3" $ n "0 .. 7" # sound "arpy" +-- +-- Of course that doesn’t actually change anything, but then you can reorder those bits: +-- +-- > d1 $ bite 4 "2 0 1 3" $ n "0 .. 7" # sound "arpy" +-- +-- The slices bits of pattern will be squeezed or contracted to fit: +-- +-- > d1 $ bite 4 "2 [0 3] 1*4 1" $ n "0 .. 7" # sound "arpy" bite :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a bite npat ipat pat = innerJoin $ (\n -> _bite n ipat pat) <$> npat _bite :: Int -> Pattern Int -> Pattern a -> Pattern a _bite n ipat pat = squeezeJoin $ zoompat <$> ipat - where zoompat i = zoom (i'/(fromIntegral n), (i'+1)/(fromIntegral n)) pat - where i' = fromIntegral $ i `mod` n + where + zoompat i = zoom (i' / (fromIntegral n), (i' + 1) / (fromIntegral n)) pat + where + i' = fromIntegral $ i `mod` n -- | 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 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} - -- already ignoring analog events, but for completeness.. - f _ _ = [] - munge co oWhole oPart (Event ci (Just iWhole) iPart v) = - do w' <- subArc oWhole iWhole - p' <- subArc oPart iPart - return (Event (combineContexts [ci,co]) (Just w') p' v) - munge _ _ _ _ = Nothing - -_chew :: Int -> Pattern Int -> ControlPattern -> ControlPattern + 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} + -- already ignoring analog events, but for completeness.. + f _ _ = [] + munge co oWhole oPart (Event ci (Just iWhole) iPart v) = + do + w' <- subArc oWhole iWhole + p' <- subArc oPart iPart + return (Event (combineContexts [ci, co]) (Just w') p' v) + munge _ _ _ _ = Nothing + +_chew :: Int -> Pattern Int -> ControlPattern -> ControlPattern _chew n ipat pat = (squeezeJoinUp $ zoompat <$> ipat) |/ P.speed (pure $ fromIntegral n) - where zoompat i = zoom (i'/(fromIntegral n), (i'+1)/(fromIntegral n)) (pat) - where i' = fromIntegral $ i `mod` n - -{-| - @chew@ works the same as 'bite', but speeds up\/slows down playback of sounds as - well as squeezing\/contracting the slices of the provided pattern. Compare: + where + zoompat i = zoom (i' / (fromIntegral n), (i' + 1) / (fromIntegral n)) (pat) + where + i' = fromIntegral $ i `mod` n - > d1 $ 'bite' 4 "0 1*2 2*2 [~ 3]" $ n "0 .. 7" # sound "drum" - > d1 $ chew 4 "0 1*2 2*2 [~ 3]" $ n "0 .. 7" # sound "drum" --} +-- | +-- @chew@ works the same as 'bite', but speeds up\/slows down playback of sounds as +-- well as squeezing\/contracting the slices of the provided pattern. Compare: +-- +-- > d1 $ 'bite' 4 "0 1*2 2*2 [~ 3]" $ n "0 .. 7" # sound "drum" +-- > d1 $ chew 4 "0 1*2 2*2 [~ 3]" $ n "0 .. 7" # sound "drum" -- TODO maybe _chew could pattern the first parameter directly.. -chew :: Pattern Int -> Pattern Int -> ControlPattern -> ControlPattern +chew :: Pattern Int -> Pattern Int -> ControlPattern -> ControlPattern chew npat ipat pat = innerJoin $ (\n -> _chew n ipat pat) <$> npat __binary :: Data.Bits.Bits b => Int -> b -> [Bool] -__binary n num = map (testBit num) $ reverse [0 .. n-1] +__binary n num = map (testBit num) $ reverse [0 .. n - 1] _binary :: Data.Bits.Bits b => Int -> b -> Pattern Bool _binary n num = listToPat $ __binary n num @@ -2927,23 +2935,23 @@ binary = binaryN 8 ascii :: Pattern String -> Pattern Bool ascii p = squeezeJoin $ (listToPat . concatMap (__binary 8 . ord)) <$> p -{- | Given a start point and a duration (both specified in cycles), this - generates a control pattern that makes a sound begin at the start - point and last the duration. - - The following are equivalent: - - > d1 $ slow 2 $ s "bev" # grain 0.2 0.1 # legato 1 - > d1 $ slow 2 $ s "bev" # begin 0.2 # end 0.3 # legato 1 - - @grain@ is defined as: - - > grain s d = 'Sound.Tidal.Params.begin' s # 'Sound.Tidal.Params.end' (s+d) --} +-- | Given a start point and a duration (both specified in cycles), this +-- generates a control pattern that makes a sound begin at the start +-- point and last the duration. +-- +-- The following are equivalent: +-- +-- > d1 $ slow 2 $ s "bev" # grain 0.2 0.1 # legato 1 +-- > d1 $ slow 2 $ s "bev" # begin 0.2 # end 0.3 # legato 1 +-- +-- @grain@ is defined as: +-- +-- > grain s d = 'Sound.Tidal.Params.begin' s # 'Sound.Tidal.Params.end' (s+d) grain :: Pattern Double -> Pattern Double -> ControlPattern grain s w = P.begin b # P.end e - where b = s - e = s + w + where + b = s + e = s + w -- | For specifying a boolean pattern according to a list of offsets -- (aka inter-onset intervals). For example @necklace 12 [4,2]@ is @@ -2951,27 +2959,36 @@ grain s w = P.begin b # P.end e -- with true values alternating between every 4 and every 2 steps. necklace :: Rational -> [Int] -> Pattern Bool necklace perCycle xs = _slow ((toRational $ sum xs) / perCycle) $ listToPat $ list xs - where list :: [Int] -> [Bool] - list [] = [] - list (x:xs') = (True:(replicate (x-1) False)) ++ list xs' - -{- | Inserts chromatic notes into a pattern. - -The first argument indicates the (patternable) number of notes to insert, -and the second argument is the base pattern of "anchor notes" that gets transformed. - -The following are equivalent: + where + list :: [Int] -> [Bool] + list [] = [] + list (x : xs') = (True : (replicate (x - 1) False)) ++ list xs' -> d1 $ up (chromaticiseBy "0 1 2 -1" "[0 2] [3 6] [5 6 8] [3 1 0]") # s "superpiano" -> d1 $ up "[0 2] [[3 4] [6 7]] [[5 6 7] [6 7 8] [8 9 10] [[3 2] [1 0] [0 -1]]" # s "superpiano" --} +-- | Inserts chromatic notes into a pattern. +-- +-- The first argument indicates the (patternable) number of notes to insert, +-- and the second argument is the base pattern of "anchor notes" that gets transformed. +-- +-- The following are equivalent: +-- +-- > d1 $ up (chromaticiseBy "0 1 2 -1" "[0 2] [3 6] [5 6 8] [3 1 0]") # s "superpiano" +-- > d1 $ up "[0 2] [[3 4] [6 7]] [[5 6 7] [6 7 8] [8 9 10] [[3 2] [1 0] [0 -1]]" # s "superpiano" chromaticiseBy :: (Num a, Enum a, Ord a) => Pattern a -> Pattern a -> Pattern a chromaticiseBy n pat = innerJoin $ (\np -> _chromaticiseBy np pat) <$> n _chromaticiseBy :: (Num a, Enum a, Ord a) => a -> Pattern a -> Pattern a -_chromaticiseBy n pat = squeezeJoin $ (\value -> fastcat - $ map pure (if n >=0 then [value .. (value+n)] - else (reverse $ [(value + n) .. value]))) <$> pat +_chromaticiseBy n pat = + squeezeJoin $ + ( \value -> + fastcat $ + map + pure + ( if n >= 0 + then [value .. (value + n)] + else (reverse $ [(value + n) .. value]) + ) + ) + <$> pat -- | Alias for chromaticiseBy chromaticizeBy :: (Num a, Enum a, Ord a) => Pattern a -> Pattern a -> Pattern a diff --git a/src/Sound/Tidal/Utils.hs b/src/Sound/Tidal/Utils.hs index e8f9986f..b754d6bf 100644 --- a/src/Sound/Tidal/Utils.hs +++ b/src/Sound/Tidal/Utils.hs @@ -1,5 +1,5 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} module Sound.Tidal.Utils where @@ -21,106 +21,104 @@ 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 Data.Set (Set) +import qualified Data.Set as Set +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 -mapBoth :: (a -> a) -> (a,a) -> (a,a) -mapBoth f (a,b) = (f a, f b) +mapBoth :: (a -> a) -> (a, a) -> (a, a) +mapBoth f (a, b) = (f a, f b) -mapPartTimes :: (a -> a) -> ((a,a),(a,a)) -> ((a,a),(a,a)) +mapPartTimes :: (a -> a) -> ((a, a), (a, a)) -> ((a, a), (a, a)) mapPartTimes f = mapBoth (mapBoth f) mapFst :: (a -> b) -> (a, c) -> (b, c) -mapFst f (x,y) = (f x,y) +mapFst f (x, y) = (f x, y) mapSnd :: (a -> b) -> (c, a) -> (c, b) -mapSnd f (x,y) = (x,f y) +mapSnd f (x, y) = (x, f y) delta :: Num a => (a, a) -> a -delta (a,b) = b-a +delta (a, b) = b - a -- | The midpoint of two values -mid :: Fractional a => (a,a) -> a -mid (a,b) = a + ((b - a) / 2) - -removeCommon :: Eq a => [a] -> [a] -> ([a],[a]) -removeCommon [] bs = ([],bs) -removeCommon as [] = (as,[]) -removeCommon (a:as) bs | a `elem` bs = removeCommon as (delete a bs) - | otherwise = (a:as',bs') - where (as',bs') = removeCommon as bs +mid :: Fractional a => (a, a) -> a +mid (a, b) = a + ((b - a) / 2) + +removeCommon :: Eq a => [a] -> [a] -> ([a], [a]) +removeCommon [] bs = ([], bs) +removeCommon as [] = (as, []) +removeCommon (a : as) bs + | a `elem` bs = removeCommon as (delete a bs) + | otherwise = (a : as', bs') + where + (as', bs') = removeCommon as bs readMaybe :: (Read a) => String -> Maybe a -readMaybe s = case [x | (x,t) <- reads s, ("","") <- lex t] of - [x] -> Just x - _ -> Nothing - -{- | like `!!` selects @n@th element from xs, but wraps over at the end of @xs@ - ->>> map ((!!!) [1,3,5]) [0,1,2,3,4,5] -[1,3,5,1,3,5] --} +readMaybe s = case [x | (x, t) <- reads s, ("", "") <- lex t] of + [x] -> Just x + _ -> Nothing + +-- | like `!!` selects @n@th element from xs, but wraps over at the end of @xs@ +-- +-- >>> map ((!!!) [1,3,5]) [0,1,2,3,4,5] +-- [1,3,5,1,3,5] (!!!) :: [a] -> Int -> a (!!!) xs n = xs !! (n `mod` length xs) - -{- | Safer version of !! --} +-- | Safer version of !! - nth :: Int -> [a] -> Maybe a -nth _ [] = Nothing -nth 0 (x : _) = Just x +nth _ [] = Nothing +nth 0 (x : _) = Just x nth n (_ : xs) = nth (n - 1) xs accumulate :: Num t => [t] -> [t] -accumulate [] = [] -accumulate (x:xs) = scanl (+) x xs +accumulate [] = [] +accumulate (x : xs) = scanl (+) x xs -{- | enumerate a list of things - ->>> enumerate ["foo","bar","baz"] -[(1,"foo"), (2,"bar"), (3,"baz")] --} +-- | enumerate a list of things +-- +-- >>> enumerate ["foo","bar","baz"] +-- [(1,"foo"), (2,"bar"), (3,"baz")] enumerate :: [a] -> [(Int, a)] -enumerate = zip [0..] - -{- | split given list of @a@ by given single a, e.g. +enumerate = zip [0 ..] ->>> wordsBy (== ':') "bd:3" -["bd", "3"] --} +-- | split given list of @a@ by given single a, e.g. +-- +-- >>> wordsBy (== ':') "bd:3" +-- ["bd", "3"] wordsBy :: (a -> Bool) -> [a] -> [[a]] wordsBy p s = case dropWhile p s of - [] -> [] - s':rest -> (s':w) : wordsBy p (drop 1 s'') - where (w, s'') = break p rest + [] -> [] + s' : rest -> (s' : w) : wordsBy p (drop 1 s'') + where + (w, s'') = break p rest matchMaybe :: Maybe a -> Maybe a -> Maybe a matchMaybe Nothing y = y -matchMaybe x _ = x +matchMaybe x _ = x -- Available in Data.Either, but only since 4.10 fromRight :: b -> Either a b -> b fromRight _ (Right b) = b -fromRight 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 True f x = f x applyWhen False _ x = x -- pair up neighbours in list -pairs :: [a] -> [(a,a)] +pairs :: [a] -> [(a, a)] pairs rs = zip rs (tail rs) -- The following is from Data.Containers.ListUtils, (c) Gershom Bazerman 2018, @@ -129,8 +127,8 @@ pairs rs = zip rs (tail rs) 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 #-} @@ -139,10 +137,11 @@ nubOrdOnExcluding :: Ord b => (a -> b) -> Set b -> [a] -> [a] nubOrdOnExcluding f = go where go _ [] = [] - go s (x:xs) + go s (x : xs) | fx `Set.member` s = go s xs | otherwise = x : go (Set.insert fx s) xs - where !fx = f x + where + !fx = f x #ifdef __GLASGOW_HASKELL__ {-# INLINABLE [1] nubOrdOnExcluding #-} diff --git a/src/Sound/Tidal/Version.hs b/src/Sound/Tidal/Version.hs index deca346b..0148aceb 100644 --- a/src/Sound/Tidal/Version.hs +++ b/src/Sound/Tidal/Version.hs @@ -24,9 +24,9 @@ tidal_version :: String tidal_version = "1.10.0" tidal_status :: IO () -tidal_status = tidal_status_string >>= putStrLn +tidal_status = tidal_status_string >>= putStrLn tidal_status_string :: IO String -tidal_status_string = do datadir <- getDataDir - return $ "[TidalCycles version " ++ tidal_version ++ "]\nInstalled in " ++ datadir - +tidal_status_string = do + datadir <- getDataDir + return $ "[TidalCycles version " ++ tidal_version ++ "]\nInstalled in " ++ datadir diff --git a/test/Sound/Tidal/ChordsTest.hs b/test/Sound/Tidal/ChordsTest.hs index 8fb81a9f..1df860e4 100644 --- a/test/Sound/Tidal/ChordsTest.hs +++ b/test/Sound/Tidal/ChordsTest.hs @@ -2,54 +2,61 @@ module Sound.Tidal.ChordsTest where -import TestUtils -import Test.Microspec - -import Prelude hiding ((<*), (*>)) - import Sound.Tidal.Pattern +import Test.Microspec +import TestUtils +import Prelude hiding ((*>), (<*)) run :: Microspec () run = describe "Sound.Tidal.Chords" $ do describe "chord" $ do - describe "chord length adjustments" $ do - it "can remove notes from the end of the list when length given is less than the standard chord length" $ do - compareP (Arc 0 1) - ("'major'1") - ("[0]" :: Pattern Note) - it "can do nothing when the length given is the same as the standard chord length" $ do - compareP (Arc 0 1) - ("'major'3") - ("[0, 4, 7]" :: Pattern Note) - it "can append chord notes at higher octaves to the list when length given is greater than the standard chord length" $ do - compareP (Arc 0 1) - ("'major'5") - ("[0, 4, 7, 12, 16]" :: Pattern Note) - describe "open voiced chords" $ do - it "can subtract 12 from the first and third element of a list, and sort them in ascending numerical order" $ do - compareP (Arc 0 1) - ("'major'o") - ("[-12, -5, 4]" :: Pattern Note) - it "not crash if chord length is < 3" $ do - compareP (Arc 0 1) - ("'five'o") - ("[0, 7]" :: Pattern Note) - describe "chord inversions" $ do - it "can add 12 to the first element of a list, and sort in ascending numeric order (1st inversion)" $ do - compareP (Arc 0 1) - ("'major'i") - ("[4, 7, 12]" :: Pattern Note) - it "can add 12 to the first two elements of a list, and sort in ascending numeric order (2nd inversion)" $ do - compareP (Arc 0 1) - ("'major'ii") - ("[7, 12, 16]" :: Pattern Note) - it "can add 12 to the first three elements of a list, and sort in ascending numeric order (3rd inversion)" $ do - compareP (Arc 0 1) - ("'major'iii") - ("[12, 16, 19]" :: Pattern Note) - describe "edge cases" $ do - it "gracefully handle an inversion when there are more inversions than notes in the chord (4th inversion of a 3 note chord)" $ do - compareP (Arc 0 1) - ("'major'iiii") - ("[16, 19, 24]" :: Pattern Note) + describe "chord length adjustments" $ do + it "can remove notes from the end of the list when length given is less than the standard chord length" $ do + compareP + (Arc 0 1) + ("'major'1") + ("[0]" :: Pattern Note) + it "can do nothing when the length given is the same as the standard chord length" $ do + compareP + (Arc 0 1) + ("'major'3") + ("[0, 4, 7]" :: Pattern Note) + it "can append chord notes at higher octaves to the list when length given is greater than the standard chord length" $ do + compareP + (Arc 0 1) + ("'major'5") + ("[0, 4, 7, 12, 16]" :: Pattern Note) + describe "open voiced chords" $ do + it "can subtract 12 from the first and third element of a list, and sort them in ascending numerical order" $ do + compareP + (Arc 0 1) + ("'major'o") + ("[-12, -5, 4]" :: Pattern Note) + it "not crash if chord length is < 3" $ do + compareP + (Arc 0 1) + ("'five'o") + ("[0, 7]" :: Pattern Note) + describe "chord inversions" $ do + it "can add 12 to the first element of a list, and sort in ascending numeric order (1st inversion)" $ do + compareP + (Arc 0 1) + ("'major'i") + ("[4, 7, 12]" :: Pattern Note) + it "can add 12 to the first two elements of a list, and sort in ascending numeric order (2nd inversion)" $ do + compareP + (Arc 0 1) + ("'major'ii") + ("[7, 12, 16]" :: Pattern Note) + it "can add 12 to the first three elements of a list, and sort in ascending numeric order (3rd inversion)" $ do + compareP + (Arc 0 1) + ("'major'iii") + ("[12, 16, 19]" :: Pattern Note) + describe "edge cases" $ do + it "gracefully handle an inversion when there are more inversions than notes in the chord (4th inversion of a 3 note chord)" $ do + compareP + (Arc 0 1) + ("'major'iiii") + ("[16, 19, 24]" :: Pattern Note) diff --git a/test/Sound/Tidal/ControlTest.hs b/test/Sound/Tidal/ControlTest.hs index 689c147f..a6f0e52a 100644 --- a/test/Sound/Tidal/ControlTest.hs +++ b/test/Sound/Tidal/ControlTest.hs @@ -2,60 +2,64 @@ module Sound.Tidal.ControlTest where -import TestUtils -import Test.Microspec - -import Prelude hiding ((<*), (*>)) - import Sound.Tidal.Control import Sound.Tidal.Core import Sound.Tidal.Params import Sound.Tidal.Pattern +import Test.Microspec +import TestUtils +import Prelude hiding ((*>), (<*)) run :: Microspec () run = describe "Sound.Tidal.Control" $ do - describe "echo" $ do it "should echo the event by the specified time and multiply the gain factor" $ do - comparePD (Arc 0 1) + comparePD + (Arc 0 1) (echo 3 0.2 0.5 $ s "bd" # gain "1") - (stack [ - rotR 0 $ s "bd" # gain 1, - rotR 0.2 $ s "bd" # gain 0.5, - rotR 0.4 $ s "bd" # gain 0.25 - ]) + ( stack + [ rotR 0 $ s "bd" # gain 1, + rotR 0.2 $ s "bd" # gain 0.5, + rotR 0.4 $ s "bd" # gain 0.25 + ] + ) describe "echoWith" $ do it "should echo the event by the specified time and apply the specified function" $ do - comparePD (Arc 0 1) + comparePD + (Arc 0 1) (echoWith 3 0.25 (|* speed 2) $ s "bd" # speed "1") - (stack [ - rotR 0 $ s "bd" # speed 1, - rotR 0.25 $ s "bd" # speed 2, - rotR 0.5 $ s "bd" # speed 4 - ]) + ( stack + [ rotR 0 $ s "bd" # speed 1, + rotR 0.25 $ s "bd" # speed 2, + rotR 0.5 $ s "bd" # speed 4 + ] + ) describe "stutWith" $ do it "can mimic stut" $ do - comparePD (Arc 0 1) + comparePD + (Arc 0 1) (filterOnsets $ stutWith 4 0.25 (# gain 1) $ sound "bd") (filterOnsets $ stut 4 1 0.25 $ sound "bd") describe "splice" $ do it "can beatslice" $ do - comparePD (Arc 0 1) + comparePD + (Arc 0 1) (splice "4 8" "0 1" $ sound "bev") (begin "0 0.125" # end "0.25 0.25" # speed "0.5 0.25" # sound "bev" # unit "c") describe "slice" $ do it "can slice samples" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (slice "8 4" "7 5 0 3 2 4 1 6" $ sound "sn bd") (begin "0.875 0.625 0.0 0.375 0.5 0.0 0.25 0.5" # end "1.0 0.75 0.125 0.5 0.75 0.25 0.5 0.75" # sound "sn bd") it "can slice by 1" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (slice "1 4" "1 [2 4 1 6]" $ sound "sn bd") (begin "0.0 [0.5 0.0 0.25 0.5]" # end "1.0 [0.75 0.25 0.5 0.75]" # sound "sn bd") - diff --git a/test/Sound/Tidal/CoreTest.hs b/test/Sound/Tidal/CoreTest.hs index 76cd6492..b4c8bb17 100644 --- a/test/Sound/Tidal/CoreTest.hs +++ b/test/Sound/Tidal/CoreTest.hs @@ -3,8 +3,8 @@ module Sound.Tidal.CoreTest where import Data.List (sort) -import Data.Ratio import qualified Data.Map as Map +import Data.Ratio import Sound.Tidal.Context import Test.Microspec import TestUtils @@ -18,7 +18,8 @@ run = sampleOf pat t = (value . head) $ query pat (State (Arc t t) Map.empty) describe "are in range [0, 1]" $ do let inNormalRange pat t = (y >= 0) && (y <= 1) - where y = sampleOf pat t + where + y = sampleOf pat t it "sine" $ inNormalRange sine it "cosine" $ inNormalRange cosine it "saw" $ inNormalRange saw @@ -27,15 +28,16 @@ run = it "square" $ inNormalRange square describe "have correctly-scaled bipolar variants" $ do let areCorrectlyScaled pat pat2 t = (y * 2 - 1) ~== y2 - where y = sampleOf pat t - y2 = sampleOf pat2 t + where + y = sampleOf pat t + y2 = sampleOf pat2 t it "sine" $ areCorrectlyScaled sine sine2 it "cosine" $ areCorrectlyScaled cosine cosine2 it "saw" $ areCorrectlyScaled saw saw2 it "isaw" $ areCorrectlyScaled isaw isaw2 it "tri" $ areCorrectlyScaled tri tri2 it "square" $ areCorrectlyScaled square square2 - + describe "append" $ it "can switch between the cycles from two pures" $ do queryArc (append (pure "a") (pure "b")) (Arc 0 5) diff --git a/test/Sound/Tidal/ExceptionsTest.hs b/test/Sound/Tidal/ExceptionsTest.hs index 0934111b..7b609b56 100644 --- a/test/Sound/Tidal/ExceptionsTest.hs +++ b/test/Sound/Tidal/ExceptionsTest.hs @@ -1,15 +1,14 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Sound.Tidal.ExceptionsTest where -import Control.DeepSeq -import Control.Exception -import Data.Typeable () -import Prelude hiding ((*>), (<*)) -import Test.Microspec - -import Sound.Tidal.Pattern +import Control.DeepSeq +import Control.Exception +import Data.Typeable () +import Sound.Tidal.Pattern +import Test.Microspec +import Prelude hiding ((*>), (<*)) run :: Microspec () run = @@ -19,32 +18,32 @@ run = evaluate (rnf (Pattern undefined Nothing Nothing :: Pattern ())) `shouldThrow` anyException - -- copied from http://hackage.haskell.org/package/hspec-expectations-0.8.2/docs/src/Test-Hspec-Expectations.html#shouldThrow shouldThrow :: (Exception e) => IO a -> Selector e -> Microspec () -action `shouldThrow` p = prop "shouldThrow" $ monadicIO $ do - r <- Test.Microspec.run $ try action - case r of - Right _ -> - -- "finished normally, but should throw exception: " ++ exceptionType - Test.Microspec.assert False - Left e -> - -- "threw exception that did not meet expectation") - Test.Microspec.assert $ p e +action `shouldThrow` p = prop "shouldThrow" $ + monadicIO $ do + r <- Test.Microspec.run $ try action + case r of + Right _ -> + -- "finished normally, but should throw exception: " ++ exceptionType + Test.Microspec.assert False + Left e -> + -- "threw exception that did not meet expectation") + Test.Microspec.assert $ p e where - -- a string repsentation of the expected exception's type - {- - exceptionType = (show . typeOf . instanceOf) p - where - instanceOf :: Selector a -> a - instanceOf _ = error "Test.Hspec.Expectations.shouldThrow: broken Typeable instance" - -} + +-- a string repsentation of the expected exception's type +{- +exceptionType = (show . typeOf . instanceOf) p + where + instanceOf :: Selector a -> a + instanceOf _ = error "Test.Hspec.Expectations.shouldThrow: broken Typeable instance" +-} -- | -- A @Selector@ is a predicate; it can simultaneously constrain the type and -- value of an exception. - type Selector a = (a -> Bool) anyException :: Selector SomeException diff --git a/test/Sound/Tidal/ParamsTest.hs b/test/Sound/Tidal/ParamsTest.hs index 453bfdd1..facff2c1 100644 --- a/test/Sound/Tidal/ParamsTest.hs +++ b/test/Sound/Tidal/ParamsTest.hs @@ -2,39 +2,43 @@ module Sound.Tidal.ParamsTest where -import Test.Microspec -import TestUtils import Sound.Tidal.Core import Sound.Tidal.Params import Sound.Tidal.Pattern +import Test.Microspec +import TestUtils run :: Microspec () run = describe "Sound.Tidal.Params" $ do describe "VF params" $ do it "should parse fractional ratio" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (sound "bd" # delay "e") - (sound "bd" # delay (1/8)) + (sound "bd" # delay (1 / 8)) it "should parse correctly floating point number" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (sound "bd" # delay "0.5") - (sound "bd" # delay (1/2)) + (sound "bd" # delay (1 / 2)) describe "VN params" $ do - it "should parse note value" $ do - compareP (Arc 0 1) - (sound "bd" # note "e") - (sound "bd" # note 4) - - it "should parse n value" $ do - compareP (Arc 0 1) - (sound "bd" # n "e") - (sound "bd" # n 4) - - it "should parse correctly floating point number" $ do - compareP (Arc 0 1) - (sound "bd" # note "0.5") - (sound "bd" # note (1/2)) + it "should parse note value" $ do + compareP + (Arc 0 1) + (sound "bd" # note "e") + (sound "bd" # note 4) + + it "should parse n value" $ do + compareP + (Arc 0 1) + (sound "bd" # n "e") + (sound "bd" # n 4) + it "should parse correctly floating point number" $ do + compareP + (Arc 0 1) + (sound "bd" # note "0.5") + (sound "bd" # note (1 / 2)) diff --git a/test/Sound/Tidal/ParseTest.hs b/test/Sound/Tidal/ParseTest.hs index 2d1f62e7..0ec10c71 100644 --- a/test/Sound/Tidal/ParseTest.hs +++ b/test/Sound/Tidal/ParseTest.hs @@ -2,277 +2,339 @@ module Sound.Tidal.ParseTest where -import Test.Microspec -import TestUtils import Control.Exception - -import Prelude hiding ((<*), (*>)) - -import Sound.Tidal.ExceptionsTest (shouldThrow, anyException) import Sound.Tidal.Core +import Sound.Tidal.ExceptionsTest (anyException, shouldThrow) import Sound.Tidal.Pattern import Sound.Tidal.UI (_degradeBy) +import Test.Microspec +import TestUtils +import Prelude hiding ((*>), (<*)) run :: Microspec () run = describe "Sound.Tidal.Parse" $ do describe "parseBP_E" $ do it "can parse strings" $ do - compareP (Arc 0 12) + compareP + (Arc 0 12) ("a b c" :: Pattern String) (fastCat ["a", "b", "c"]) it "can parse ints" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("0 1 2 3 4 5 6 7 8 0 10 20 30 40 50" :: Pattern Int) (fastCat $ map (pure . read) $ words "0 1 2 3 4 5 6 7 8 0 10 20 30 40 50") it "can parse pattern groups" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) ("[bd sd] hh" :: Pattern String) (fastCat ["bd sd", "hh"]) it "can parse pattern groups shorthand " $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) ("bd sd . hh hh hh" :: Pattern String) ("[bd sd] [hh hh hh]") it "can alternate with <>" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("a " :: Pattern String) (cat [fastCat ["a", "b"], fastCat ["a", "c"]]) it "can slow with /" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("a/2" :: Pattern String) (slow 2 $ "a") it "can speed up with *" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("a*8" :: Pattern String) (fast 8 "a") it "can elongate with _" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("a _ _ b _" :: Pattern String) - (timeCat [(3,"a"), (2,"b")]) + (timeCat [(3, "a"), (2, "b")]) it "can replicate with !" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("a! b" :: Pattern String) (fastCat ["a", "a", "b"]) it "can replicate with ! inside {}" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("{a a}%2" :: Pattern String) ("{a !}%2" :: Pattern String) it "can replicate with ! and number" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("a!3 b" :: Pattern String) (fastCat ["a", "a", "a", "b"]) it "can degrade with ?" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) ("a?" :: Pattern String) (degradeByDefault "a") it "can degrade with ? and number" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) ("a?0.2" :: Pattern String) (_degradeBy 0.2 "a") it "can degrade with ? for double patterns" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) ("0.4 0.5? 0.6" :: Pattern Double) - (fastcat[0.4, degradeByDefault 0.5, 0.6]) + (fastcat [0.4, degradeByDefault 0.5, 0.6]) it "can handle ? on replicated value" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) ("a!8?" :: Pattern String) ("[a!8]?" :: Pattern String) it "can handle ? on streched value" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) ("a*4@0.25?" :: Pattern String) ("[a*4@0.25]?" :: Pattern String) it "can stretch with @" $ do - comparePD (Arc 0 1) + comparePD + (Arc 0 1) ("a@2 b" :: Pattern String) - (timeCat [(2, "a"),(1,"b")]) + (timeCat [(2, "a"), (1, "b")]) it "can do polymeter with {}" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("{a b, c d e}" :: Pattern String) (stack [fastcat [pure "a", pure "b"], slow 1.5 $ fastcat [pure "c", pure "d", pure "e"]]) it "can parse .. with ints" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("0 .. 8" :: Pattern Int) ("0 1 2 3 4 5 6 7 8") it "can parse .. with rationals" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("0 .. 8" :: Pattern Rational) ("0 1 2 3 4 5 6 7 8") it "can parse .. with doubles" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("0.0 .. 8.0" :: Pattern Double) ("0 1 2 3 4 5 6 7 8") it "can parse .. with doubles, without spaces" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("0.0..8.0" :: Pattern Double) ("0 1 2 3 4 5 6 7 8") it "can parse .. with notes" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("0.0 .. 8.0" :: Pattern Note) ("0 1 2 3 4 5 6 7 8") it "can parse .. with notes, without spaces" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("0..8" :: Pattern Note) ("0 1 2 3 4 5 6 7 8") it "can handle repeats (!) and durations (@) with <>" $ do - compareP (Arc 0 31) + compareP + (Arc 0 31) ("" :: Pattern String) (slow 10 "[a a a b b] c") it "can handle repeats (!) and durations (@) with <> (with ints)" $ do - compareP (Arc 0 31) + compareP + (Arc 0 31) ("<1!3 2 ! 3@5>" :: Pattern Int) (slow 10 "[1 1 1 2 2] 3") it "can handle fractional durations" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("a@0.5 b@1%6 b@1%6 b@1%6" :: Pattern String) ("a b*3") it "can handle fractional durations (with rationals)" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("1%3@0.5 3%4@1%6 3%4@1%6 3%4@1%6" :: Pattern Rational) ("1%3 0.75*3") it "can handle ratio shortands on a fraction" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) ("1%3t" :: Pattern Rational) ("1%9" :: Pattern Rational) it "can handle ratio shortands on a floating point number" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) ("3.33t" :: Pattern Double) ("1.11" :: Pattern Double) it "cannot handle fractional with floating point numerator or denominator" $ do evaluate ("1.2%5.3" :: Pattern Time) `shouldThrow` anyException it "can parse a chord" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("'major" :: Pattern Int) ("[0,4,7]") it "can parse two chords" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("'major 'minor" :: Pattern Int) ("[0,4,7] [0,3,7]") it "can parse c chords" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("'major 'minor 'dim7" :: Pattern Int) ("c'major c'minor c'dim7") it "can parse various chords" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("c'major e'minor f'dim7" :: Pattern Int) ("c e f" + "'major 'minor 'dim7") it "can parse note chords" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("c'major c'minor" :: Pattern Note) ("'major 'minor") it "can invert chords" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("c'major'i" :: Pattern Note) ("[4,7,12]") it "can invert chords using a number" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("c'major'i2" :: Pattern Note) ("[7,12,16]") it "spread chords over a range" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("c'major'5 e'min7'5" :: Pattern Note) ("[0,4,7,12,16] [4,7,11,14,16]") it "can open chords" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("c'major'o" :: Pattern Note) ("[-12,-5,4]") it "can drop notes in a chord" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("c'major'd1" :: Pattern Note) ("[-5,0,4]") it "can apply multiple modifiers" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("c'major'i'5" :: Pattern Note) ("[4,7,12,16,19]") it "can pattern modifiers" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("c'major'" :: Pattern Note) ("<[4,7,12] [0,4,7,12,16]>") it "can pattern chord names" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("c''i" :: Pattern Note) ("<[4,7,12] [3,7,12]>") it "can pattern chord notes" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("''i" :: Pattern Note) ("<[4,7,12] [7,11,16]>") it "handle trailing and leading whitespaces" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (" bd " :: Pattern String) ("bd" :: Pattern String) it "can parse negative ratio shorthands" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) ("h -h" :: Pattern Double) ("0.5 -0.5" :: Pattern Double) it "can parse multiplied ratio shorthands" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) ("3h -2q 1.5q" :: Pattern Double) ("1.5 -0.5 0.375" :: Pattern Double) it "can parse exponential notation value for pattern double" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) ("1e3" :: Pattern Double) ("1000" :: Pattern Double) it "can parse negative exponential notation value for pattern double" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) ("400e-3" :: Pattern Double) ("0.4" :: Pattern Double) it "can parse ratio shortand on exponential notation value" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) ("4e2q" :: Pattern Double) ("100" :: Pattern Double) it "can parse euclid pattern" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) ("bd(3,8,1)" :: Pattern String) ("~ ~ bd ~ ~ bd ~ bd") it "can parse euclid bool pattern" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) ("t(3,8,1)" :: Pattern Bool) ("f f t f f t f t") it "doesn't crash on zeroes (1)" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("cp/0" :: Pattern String) (silence) it "doesn't crash on zeroes (2)" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("cp(5,0)" :: Pattern String) (silence) it "doesn't crash on zeroes (3)" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) ("cp(5,c)" :: Pattern String) (silence) it "can't parse a floating point number as int" $ do evaluate ("1.5" :: Pattern Int) `shouldThrow` anyException it "can correctly parse multiplied boolean patterns 1" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) ("t*2 t*3" :: Pattern Bool) ("1*2 1*3" :: Pattern Bool) it "can correctly parse multiplied boolean patterns 2" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) ("t*2t t" :: Pattern Bool) ("1*2%3 1" :: Pattern Bool) it "does the same for '-' and '~' in simple patterns" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) ("- 2" :: Pattern String) ("~ 2" :: Pattern String) it "does the same for '-' and '~' in complex patterns parsed as Rational" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) ("[-- 2 <-- 2@7 3> 4%2 3? 4 9|8 -- [-- <2 9q> -]] 2!4" :: Pattern Rational) ("[~~ 2 <~~ 2@7 3> 4%2 3? 4 9|8 ~~ [~~ <2 9q> ~]] 2!4" :: Pattern Rational) it "does the same for '-' and '~' in complex patterns" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) ("[-- 2 <-- 2@7 3> 1*4%2 3? 4 9|8 -- [-- <2 9q> -]] 2!4" :: Pattern String) ("[~~ 2 <~~ 2@7 3> 1*4%2 3? 4 9|8 ~~ [~~ <2 9q> ~]] 2!4" :: Pattern String) it "does the same for '-' and '~' using rational numbers" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) ("- 2q -3.999-9" :: Pattern String) ("~ 2q -3.999-9" :: Pattern String) it "does the same for '-' and '~' in list patterns" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) ("[-- 2 -- -]" :: Pattern String) ("[~~ 2 ~~ ~]" :: Pattern String) it "does the same for '-' and '~' alternating patterns" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) ("<-- 2 -- - 8>" :: Pattern String) ("<~~ 2 ~~ ~ 8>" :: Pattern String) - where degradeByDefault = _degradeBy 0.5 + where + degradeByDefault = _degradeBy 0.5 diff --git a/test/Sound/Tidal/PatternTest.hs b/test/Sound/Tidal/PatternTest.hs index 774006a1..3b7929db 100644 --- a/test/Sound/Tidal/PatternTest.hs +++ b/test/Sound/Tidal/PatternTest.hs @@ -2,41 +2,37 @@ module Sound.Tidal.PatternTest where -import Test.Microspec -import TestUtils - -import Prelude hiding ((*>), (<*)) - -import Data.Ratio - -import Sound.Tidal.Core -import Sound.Tidal.Pattern -import Sound.Tidal.UI - -import qualified Data.Map.Strict as Map +import qualified Data.Map.Strict as Map +import Data.Ratio +import Sound.Tidal.Core +import Sound.Tidal.Pattern +import Sound.Tidal.UI +import Test.Microspec +import TestUtils +import Prelude hiding ((*>), (<*)) run :: Microspec () run = describe "Sound.Tidal.Pattern" $ do describe "Arc" $ do it "Arc is a Functor: Apply a given function to the start and end values of an Arc" $ do - let res = fmap (+1) (Arc 3 5) + let res = fmap (+ 1) (Arc 3 5) property $ ((Arc 4 6) :: Arc) === res - {- - describe "Event" $ do - it "(Bifunctor) first: Apply a function to the Arc elements: whole and part" $ do - let res = Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5 :: Event (Context []) Int - f = (+1) - property $ - first f res === - Event (Context []) (Just $ Arc 2 3) (Arc 4 5) 5 - it "(Bifunctor) second: Apply a function to the event element" $ do - let res = Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5 :: Event (Context []) Int - f = (+1) - property $ - second f res === - Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 6-} + {- + describe "Event" $ do + it "(Bifunctor) first: Apply a function to the Arc elements: whole and part" $ do + let res = Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5 :: Event (Context []) Int + f = (+1) + property $ + first f res === + Event (Context []) (Just $ Arc 2 3) (Arc 4 5) 5 + it "(Bifunctor) second: Apply a function to the event element" $ do + let res = Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5 :: Event (Context []) Int + f = (+1) + property $ + second f res === + Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 6-} describe "whole" $ do it "returns the whole Arc in an Event" $ do @@ -48,18 +44,18 @@ run = describe "value" $ do it "returns the event value in an Event" $ do - property $ 5 === value (Event (Context []) (Just $ Arc (1 :: Rational) 2) (Arc 3 4) ( 5 :: Int)) + property $ 5 === value (Event (Context []) (Just $ Arc (1 :: Rational) 2) (Arc 3 4) (5 :: Int)) - describe "wholeStart" $ do - it "retrieve the onset of an event: the start of the whole Arc" $ do + describe "wholeStart" $ do + it "retrieve the onset of an event: the start of the whole Arc" $ do property $ 1 === wholeStart (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) - describe "eventHasOnset" $ do - it "return True when the start values of the two arcs in an event are equal" $ do - let ev = (Event (Context []) (Just $ Arc 1 2) (Arc 1 3) (4 :: Int)) - property $ True === eventHasOnset ev - it "return False when the start values of the two arcs in an event are not equal" $ do - let ev = (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) + describe "eventHasOnset" $ do + it "return True when the start values of the two arcs in an event are equal" $ do + let ev = (Event (Context []) (Just $ Arc 1 2) (Arc 1 3) (4 :: Int)) + property $ True === eventHasOnset ev + it "return False when the start values of the two arcs in an event are not equal" $ do + let ev = (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) property $ False === eventHasOnset ev describe "pure" $ do @@ -68,131 +64,142 @@ run = it "returns the part of an pure that you ask for, preserving the whole" $ do property $ queryArc (pure 0) (Arc 0.25 0.75) === [(Event (Context []) (Just $ Arc 0 1) (Arc 0.25 0.75) (0 :: Int))] it "gives correct fragments when you go over cycle boundaries" $ do - property $ queryArc (pure 0) (Arc 0.25 1.25) === - [ (Event (Context []) (Just $ Arc 0 1) (Arc 0.25 1) (0 :: Int)), - (Event (Context []) (Just $ Arc 1 2) (Arc 1 1.25) 0) - ] + property $ + queryArc (pure 0) (Arc 0.25 1.25) + === [ (Event (Context []) (Just $ Arc 0 1) (Arc 0.25 1) (0 :: Int)), + (Event (Context []) (Just $ Arc 1 2) (Arc 1 1.25) 0) + ] it "works with zero-length queries" $ do it "0" $ queryArc (pure "a") (Arc 0 0) - `shouldBe` fmap toEvent [(((0,1), (0,0)), "a" :: String)] + `shouldBe` fmap toEvent [(((0, 1), (0, 0)), "a" :: String)] it "1/3" $ - queryArc (pure "a") (Arc (1%3) (1%3)) - `shouldBe` fmap toEvent [(((0,1), (1%3,1%3)), "a" :: String)] + queryArc (pure "a") (Arc (1 % 3) (1 % 3)) + `shouldBe` fmap toEvent [(((0, 1), (1 % 3, 1 % 3)), "a" :: String)] describe "_fastGap" $ do it "copes with cross-cycle queries" $ do - (queryArc(_fastGap 2 $ fastCat [pure "a", pure "b"]) (Arc 0.5 1.5)) - `shouldBe` - [(Event (Context []) (Just $ Arc (1 % 1) (5 % 4)) (Arc (1 % 1) (5 % 4)) ("a" :: String)), - (Event (Context []) (Just $ Arc (5 % 4) (3 % 2)) (Arc (5 % 4) (3 % 2)) "b") - ] + (queryArc (_fastGap 2 $ fastCat [pure "a", pure "b"]) (Arc 0.5 1.5)) + `shouldBe` [ (Event (Context []) (Just $ Arc (1 % 1) (5 % 4)) (Arc (1 % 1) (5 % 4)) ("a" :: String)), + (Event (Context []) (Just $ Arc (5 % 4) (3 % 2)) (Arc (5 % 4) (3 % 2)) "b") + ] it "does not return events outside of the query" $ do - (queryArc(_fastGap 2 $ fastCat [pure "a", pure ("b" :: String)]) (Arc 0.5 0.9)) + (queryArc (_fastGap 2 $ fastCat [pure "a", pure ("b" :: String)]) (Arc 0.5 0.9)) `shouldBe` [] describe "<*>" $ do it "can apply a pattern of values to a pattern of values" $ do - queryArc ((pure (+1)) <*> (pure 3)) (Arc 0 1) `shouldBe` fmap toEvent [(((0,1), (0,1)), 4 :: Int)] + queryArc ((pure (+ 1)) <*> (pure 3)) (Arc 0 1) `shouldBe` fmap toEvent [(((0, 1), (0, 1)), 4 :: Int)] it "can take structure from the left" $ do - queryArc ((fastCat [pure (+1), pure (+2)]) <*> (pure 3)) (Arc 0 1) `shouldBe` fmap toEvent - [(((0,0.5), (0,0.5)), 4 :: Int), - (((0.5,1), (0.5,1)), 5) - ] + queryArc ((fastCat [pure (+ 1), pure (+ 2)]) <*> (pure 3)) (Arc 0 1) + `shouldBe` fmap + toEvent + [ (((0, 0.5), (0, 0.5)), 4 :: Int), + (((0.5, 1), (0.5, 1)), 5) + ] it "can take structure from the right" $ do - queryArc (pure (+1) <*> (fastCat [pure 7, pure 8])) (Arc 0 1) `shouldBe` fmap toEvent - [(((0,0.5), (0,0.5)), 8 :: Int), - (((0.5,1), (0.5,1)), 9) - ] + queryArc (pure (+ 1) <*> (fastCat [pure 7, pure 8])) (Arc 0 1) + `shouldBe` fmap + toEvent + [ (((0, 0.5), (0, 0.5)), 8 :: Int), + (((0.5, 1), (0.5, 1)), 9) + ] it "can take structure from the both sides" $ do it "one" $ - queryArc ((fastCat [pure (+1), pure (+2)]) <*> (fastCat [pure 7, pure 8])) (Arc 0 1) - `shouldBe` fmap toEvent - [(((0,0.5), (0,0.5)), 8 :: Int), - (((0.5,1), (0.5,1)), 10) - ] + queryArc ((fastCat [pure (+ 1), pure (+ 2)]) <*> (fastCat [pure 7, pure 8])) (Arc 0 1) + `shouldBe` fmap + toEvent + [ (((0, 0.5), (0, 0.5)), 8 :: Int), + (((0.5, 1), (0.5, 1)), 10) + ] it "two" $ - queryArc ((fastCat [pure (+1), pure (+2), pure (+3)]) <*> (fastCat [pure 7, pure 8])) (Arc 0 1) - `shouldBe` fmap toEvent - [ (((0%1, 1%3), (0%1, 1%3)), 8 :: Int), - (((1%3, 1%2), (1%3, 1%2)), 9), - (((1%2, 2%3), (1%2, 2%3)), 10), - (((2%3, 1%1), (2%3, 1%1)), 11) - ] + queryArc ((fastCat [pure (+ 1), pure (+ 2), pure (+ 3)]) <*> (fastCat [pure 7, pure 8])) (Arc 0 1) + `shouldBe` fmap + toEvent + [ (((0 % 1, 1 % 3), (0 % 1, 1 % 3)), 8 :: Int), + (((1 % 3, 1 % 2), (1 % 3, 1 % 2)), 9), + (((1 % 2, 2 % 3), (1 % 2, 2 % 3)), 10), + (((2 % 3, 1 % 1), (2 % 3, 1 % 1)), 11) + ] it "obeys pure id <*> v = v" $ do let v = (fastCat [fastCat [pure 7, pure 8], pure 9]) :: Pattern Int queryArc ((pure id <*> v)) (Arc 0 5) `shouldBe` queryArc v (Arc 0 5) it "obeys pure f <*> pure x = pure (f x)" $ do - let f = (+3) + let f = (+ 3) x = 7 :: Int queryArc (pure f <*> pure x) (Arc 0 5) `shouldBe` queryArc (pure (f x)) (Arc 0 5) it "obeys u <*> pure y = pure ($ y) <*> u" $ do - let u = fastCat [pure (+7), pure (+8)] + let u = fastCat [pure (+ 7), pure (+ 8)] y = 6 :: Int queryArc (u <*> pure y) (Arc 0 5) `shouldBe` queryArc (pure ($ y) <*> u) (Arc 0 5) it "obeys pure (.) <*> u <*> v <*> w = u <*> (v <*> w)" $ do - let u = (fastCat [pure (+7), pure (+8)]) :: Pattern (Int -> Int) - v = fastCat [pure (+3), pure (+4), pure (+5)] + let u = (fastCat [pure (+ 7), pure (+ 8)]) :: Pattern (Int -> Int) + v = fastCat [pure (+ 3), pure (+ 4), pure (+ 5)] w = fastCat [pure 1, pure 2] queryArc (pure (.) <*> u <*> v <*> w) (Arc 0 5) `shouldBe` queryArc (u <*> (v <*> w)) (Arc 0 5) describe "<*" $ do it "can apply a pattern of values to a pattern of functions" $ do - queryArc ((pure (+1)) <* (pure 3)) (Arc 0 1) `shouldBe` fmap toEvent - [(((0,1), (0,1)), 4 :: Int)] + queryArc ((pure (+ 1)) <* (pure 3)) (Arc 0 1) + `shouldBe` fmap + toEvent + [(((0, 1), (0, 1)), 4 :: Int)] it "doesn't take structure from the right" $ do - queryArc (pure (+1) <* (fastCat [pure 7, pure 8])) (Arc 0 1) - `shouldBe` fmap toEvent [(((0,1), (0,0.5)), 8 :: Int), - (((0,1), (0.5,1)), 9 :: Int) - ] + queryArc (pure (+ 1) <* (fastCat [pure 7, pure 8])) (Arc 0 1) + `shouldBe` fmap + toEvent + [ (((0, 1), (0, 0.5)), 8 :: Int), + (((0, 1), (0.5, 1)), 9 :: Int) + ] describe "*>" $ do it "can apply a pattern of values to a pattern of functions" $ do - it "works within cycles" $ queryArc ((pure (+1)) *> (pure 3)) (Arc 0 1) `shouldBe` fmap toEvent [(((0,1), (0,1)), 4 :: Int)] - it "works across cycles" $ queryArc ((pure (+1)) *> (slow 2 $ pure 3)) (Arc 0 1) `shouldBe` fmap toEvent [(((0,2), (0,1)), 4 :: Int)] + it "works within cycles" $ queryArc ((pure (+ 1)) *> (pure 3)) (Arc 0 1) `shouldBe` fmap toEvent [(((0, 1), (0, 1)), 4 :: Int)] + it "works across cycles" $ queryArc ((pure (+ 1)) *> (slow 2 $ pure 3)) (Arc 0 1) `shouldBe` fmap toEvent [(((0, 2), (0, 1)), 4 :: Int)] it "doesn't take structure from the left" $ do - queryArc (pure (+1) *> (fastCat [pure 7, pure 8])) (Arc 0 1) - `shouldBe` fmap toEvent - [(((0,0.5), (0,0.5)), 8 :: Int), - (((0.5,1), (0.5,1)), 9 :: Int) - ] + queryArc (pure (+ 1) *> (fastCat [pure 7, pure 8])) (Arc 0 1) + `shouldBe` fmap + toEvent + [ (((0, 0.5), (0, 0.5)), 8 :: Int), + (((0.5, 1), (0.5, 1)), 9 :: Int) + ] describe "arcCycles" $ do - it "leaves a unit cycle intact" $ do - it "(0,1)" $ arcCycles (Arc 0 1) `shouldBe` [(Arc 0 1)] - it "(3,4)" $ arcCycles (Arc 3 4) `shouldBe` [(Arc 3 4)] - it "splits a cycle at cycle boundaries" $ do - it "(0,1.1)" $ arcCycles (Arc 0 1.1) `shouldBe` [(Arc 0 1),(Arc 1 1.1)] - it "(1,2,1)" $ arcCycles (Arc 1 2.1) `shouldBe` [(Arc 1 2),(Arc 2 2.1)] - it "(3 + (1%3),5.1)" $ - arcCycles (Arc (3 + (1%3)) 5.1) `shouldBe` [(Arc (3+(1%3)) 4),(Arc 4 5),(Arc 5 5.1)] + it "leaves a unit cycle intact" $ do + it "(0,1)" $ arcCycles (Arc 0 1) `shouldBe` [(Arc 0 1)] + it "(3,4)" $ arcCycles (Arc 3 4) `shouldBe` [(Arc 3 4)] + it "splits a cycle at cycle boundaries" $ do + it "(0,1.1)" $ arcCycles (Arc 0 1.1) `shouldBe` [(Arc 0 1), (Arc 1 1.1)] + it "(1,2,1)" $ arcCycles (Arc 1 2.1) `shouldBe` [(Arc 1 2), (Arc 2 2.1)] + it "(3 + (1%3),5.1)" $ + arcCycles (Arc (3 + (1 % 3)) 5.1) `shouldBe` [(Arc (3 + (1 % 3)) 4), (Arc 4 5), (Arc 5 5.1)] describe "unwrap" $ do it "preserves inner structure" $ do it "one" $ (queryArc (unwrap $ pure (fastCat [pure "a", pure ("b" :: String)])) (Arc 0 1)) - `shouldBe` (queryArc (fastCat [pure "a", pure "b"]) (Arc 0 1)) + `shouldBe` (queryArc (fastCat [pure "a", pure "b"]) (Arc 0 1)) it "two" $ (queryArc (unwrap $ pure (fastCat [pure "a", pure "b", fastCat [pure "c", pure ("d" :: String)]])) (Arc 0 1)) - `shouldBe` (queryArc (fastCat [pure "a", pure "b", fastCat [pure "c", pure "d"]]) (Arc 0 1)) + `shouldBe` (queryArc (fastCat [pure "a", pure "b", fastCat [pure "c", pure "d"]]) (Arc 0 1)) it "preserves outer structure" $ do it "one" $ (queryArc (unwrap $ fastCat [pure $ pure "a", pure $ pure ("b" :: String)]) (Arc 0 1)) - `shouldBe` (queryArc (fastCat [pure "a", pure "b"]) (Arc 0 1)) + `shouldBe` (queryArc (fastCat [pure "a", pure "b"]) (Arc 0 1)) it "two" $ (queryArc (unwrap $ fastCat [pure $ pure "a", pure $ pure "b", fastCat [pure $ pure "c", pure $ pure ("d" :: String)]]) (Arc 0 1)) - `shouldBe` (queryArc (fastCat [pure "a", pure "b", fastCat [pure "c", pure "d"]]) (Arc 0 1)) + `shouldBe` (queryArc (fastCat [pure "a", pure "b", fastCat [pure "c", pure "d"]]) (Arc 0 1)) it "gives events whole/part timespans that are an intersection of that of inner and outer events" $ do let a = fastCat [pure "a", pure "b"] b = fastCat [pure "c", pure "d", pure "e"] pp = fastCat [pure a, pure b] queryArc (unwrap pp) (Arc 0 1) - `shouldBe` [(Event (Context []) (Just $ Arc (0 % 1) (1 % 2)) (Arc (0 % 1) (1 % 2)) ("a" :: String)), - (Event (Context []) (Just $ Arc (1 % 2) (2 % 3)) (Arc (1 % 2) (2 % 3)) "d"), - (Event (Context []) (Just $ Arc (2 % 3) (1 % 1)) (Arc (2 % 3) (1 % 1)) "e") + `shouldBe` [ (Event (Context []) (Just $ Arc (0 % 1) (1 % 2)) (Arc (0 % 1) (1 % 2)) ("a" :: String)), + (Event (Context []) (Just $ Arc (1 % 2) (2 % 3)) (Arc (1 % 2) (2 % 3)) "d"), + (Event (Context []) (Just $ Arc (2 % 3) (1 % 1)) (Arc (2 % 3) (1 % 1)) "e") ] describe "squeezeJoin" $ do @@ -201,11 +208,11 @@ run = b = fastCat [pure "c", pure "d", pure "e"] pp = fastCat [pure a, pure b] queryArc (squeezeJoin pp) (Arc 0 1) - `shouldBe` [(Event (Context []) (Just $ Arc (0 % 1) (1 % 4)) (Arc (0 % 1) (1 % 4)) ("a" :: String)), - (Event (Context []) (Just $ Arc (1 % 4) (1 % 2)) (Arc (1 % 4) (1 % 2)) "b"), - (Event (Context []) (Just $ Arc (1 % 2) (2 % 3)) (Arc (1 % 2) (2 % 3)) "c"), - (Event (Context []) (Just $ Arc (2 % 3) (5 % 6)) (Arc (2 % 3) (5 % 6)) "d"), - (Event (Context []) (Just $ Arc (5 % 6) (1 % 1)) (Arc (5 % 6) (1 % 1)) "e") + `shouldBe` [ (Event (Context []) (Just $ Arc (0 % 1) (1 % 4)) (Arc (0 % 1) (1 % 4)) ("a" :: String)), + (Event (Context []) (Just $ Arc (1 % 4) (1 % 2)) (Arc (1 % 4) (1 % 2)) "b"), + (Event (Context []) (Just $ Arc (1 % 2) (2 % 3)) (Arc (1 % 2) (2 % 3)) "c"), + (Event (Context []) (Just $ Arc (2 % 3) (5 % 6)) (Arc (2 % 3) (5 % 6)) "d"), + (Event (Context []) (Just $ Arc (5 % 6) (1 % 1)) (Arc (5 % 6) (1 % 1)) "e") ] it "preserves cycle number of inner patterns" $ do (map value $ queryArc (squeezeJoin (pure $ struct "1" $ (sig $ id))) (Arc 3 4)) @@ -213,78 +220,82 @@ run = describe ">>=" $ do it "can apply functions to patterns" $ do - let p = fastCat [pure 7, pure 8] :: Pattern Int - p' = do x <- p - return $ x + 1 - (queryArc p' (Arc 0 1)) `shouldBe` (queryArc ((+1) <$> p) (Arc 0 1)) + let p = fastCat [pure 7, pure 8] :: Pattern Int + p' = do + x <- p + return $ x + 1 + (queryArc p' (Arc 0 1)) `shouldBe` (queryArc ((+ 1) <$> p) (Arc 0 1)) it "can add two patterns together" $ do - let p1 = fastCat [pure 7, pure 8, pure 9] :: Pattern Int - p2 = fastCat [pure 4, fastCat [pure 5, pure 6]] - p' = do x <- p1 - y <- p2 - return $ x + y - compareP (Arc 0 1) p' ((+) <$> p1 <*> p2) + let p1 = fastCat [pure 7, pure 8, pure 9] :: Pattern Int + p2 = fastCat [pure 4, fastCat [pure 5, pure 6]] + p' = do + x <- p1 + y <- p2 + return $ x + y + compareP (Arc 0 1) p' ((+) <$> p1 <*> p2) it "conforms to (return v) >>= f = f v" $ do - let f x = pure $ x + 10 - v = 5 :: Int - compareP (Arc 0 5) ((return v) >>= f) (f v) + let f x = pure $ x + 10 + v = 5 :: Int + compareP (Arc 0 5) ((return v) >>= f) (f v) it "conforms to m >>= return ≡ m" $ do - let m = fastCat [pure "a", fastCat [pure "b", pure ("c" :: String)]] - compareP (Arc 0 1) (m >>= return) m - -- it "conforms to (m >>= f) >>= g ≡ m >>= ( \x -> (f x >>= g) )" $ do - -- let m = fastCat [pure "a", fastCat [pure "b", pure "c"]] + let m = fastCat [pure "a", fastCat [pure "b", pure ("c" :: String)]] + compareP (Arc 0 1) (m >>= return) m + -- it "conforms to (m >>= f) >>= g ≡ m >>= ( \x -> (f x >>= g) )" $ do + -- let m = fastCat [pure "a", fastCat [pure "b", pure "c"]] describe "rotR" $ do it "works over two cycles" $ - property $ comparePD (Arc 0 2) (0.25 ~> pure "a") (0.25 `rotR` pure ("a" :: String)) + property $ comparePD (Arc 0 2) (0.25 ~> pure "a") (0.25 `rotR` pure ("a" :: String)) it "works over one cycle" $ - property $ compareP (Arc 0 1) (0.25 ~> pure "a") (0.25 `rotR` pure ("a" :: String)) + property $ compareP (Arc 0 1) (0.25 ~> pure "a") (0.25 `rotR` pure ("a" :: String)) it "works with zero width queries" $ - property $ compareP (Arc 0 0) (0.25 ~> pure "a") (0.25 `rotR` pure ("a" :: String)) + property $ compareP (Arc 0 0) (0.25 ~> pure "a") (0.25 `rotR` pure ("a" :: String)) describe "comparePD" $ do it "allows split events to be compared" $ - property $ comparePD (Arc 0 2) - (splitQueries $ _slow 2 $ pure ("a" :: String)) - (_slow 2 $ pure "a") + property $ + comparePD + (Arc 0 2) + (splitQueries $ _slow 2 $ pure ("a" :: String)) + (_slow 2 $ pure "a") describe "controlI" $ do it "can retrieve values from state" $ - (query (pure 3 + cF_ "hello") $ State (Arc 0 1) (Map.singleton "hello" (VF 0.5))) - `shouldBe` [(Event (Context []) (Just $ Arc (0 % 1) (1 % 1)) (Arc (0 % 1) (1 % 1)) 3.5)] + (query (pure 3 + cF_ "hello") $ State (Arc 0 1) (Map.singleton "hello" (VF 0.5))) + `shouldBe` [(Event (Context []) (Just $ Arc (0 % 1) (1 % 1)) (Arc (0 % 1) (1 % 1)) 3.5)] - describe "wholeStart" $ do - it "retrieve first element of a tuple, inside first element of a tuple, inside the first of another" $ do + describe "wholeStart" $ do + it "retrieve first element of a tuple, inside first element of a tuple, inside the first of another" $ do property $ 1 === wholeStart (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) describe "wholeStop" $ do it "retrieve the end time from the first Arc in an Event" $ do property $ 2 === wholeStop (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) - describe "eventPartStart" $ do - it "retrieve the start time of the second Arc in an Event" $ do + describe "eventPartStart" $ do + it "retrieve the start time of the second Arc in an Event" $ do property $ 3 === eventPartStart (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) - describe "eventPartStop" $ do - it "retrieve the end time of the second Arc in an Event" $ do + describe "eventPartStop" $ do + it "retrieve the end time of the second Arc in an Event" $ do property $ 4 === eventPartStop (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) - - describe "eventPart" $ do - it "retrieve the second Arc in an Event" $ do + + describe "eventPart" $ do + it "retrieve the second Arc in an Event" $ do property $ Arc 3 4 === eventPart (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) - + describe "eventValue" $ do - it "retrieve the second value from a tuple" $ do + it "retrieve the second value from a tuple" $ do property $ 5 === eventValue (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) - describe "eventHasOnset" $ do - it "return True when the start values of the two arcs in an event are equal" $ do - let ev = (Event (Context []) (Just $ Arc 1 2) (Arc 1 3) (4 :: Int)) - property $ True === eventHasOnset ev - it "return False when the start values of the two arcs in an event are not equal" $ do - let ev = (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) + describe "eventHasOnset" $ do + it "return True when the start values of the two arcs in an event are equal" $ do + let ev = (Event (Context []) (Just $ Arc 1 2) (Arc 1 3) (4 :: Int)) + property $ True === eventHasOnset ev + it "return False when the start values of the two arcs in an event are not equal" $ do + let ev = (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) property $ False === eventHasOnset ev describe "sam" $ do @@ -297,15 +308,15 @@ run = let res = nextSam (3.4 :: Time) property $ (4.0 :: Time) === res - describe "arcCycles" $ do - it "if start time is greater than end time return empty list" $ do + describe "arcCycles" $ do + it "if start time is greater than end time return empty list" $ do let res = arcCycles (Arc 2.3 2.1) - property $ [] === res - it "if start time is equal to end time return empty list" $ do + property $ [] === res + it "if start time is equal to end time return empty list" $ do let res = arcCycles (Arc 3 3) property $ [] === res it "if start and end time round down to same value return list of (start, end)" $ do - let res = arcCycles (Arc 2.1 2.3) + let res = arcCycles (Arc 2.1 2.3) property $ [(Arc 2.1 2.3)] === res it "if start time is less than end time and start time does not round down to same value as end time" $ do let res = arcCycles (Arc 2.1 3.3) @@ -327,7 +338,7 @@ run = describe "mapCycle" $ do it "Apply a function to the Arc values minus the start value rounded down (sam'), adding both results to sam' to obtain the new Arc value" $ do - let res = mapCycle (*2) (Arc 3.3 5) + let res = mapCycle (* 2) (Arc 3.3 5) property $ ((Arc 3.6 7.0) :: Arc) === res describe "toTime" $ do @@ -361,21 +372,21 @@ run = property $ False === res describe "onsetIn" $ do - it "If the beginning of an Event is within a given Arc, same rules as 'isIn'" $ do - let res = onsetIn (Arc 2.0 2.8) (Event (Context []) (Just $ Arc 2.2 2.7) (Arc 3.3 3.8) (5 :: Int)) - property $ True === res - it "Beginning of Event is equal to beggining of given Arc" $ do - let res = onsetIn (Arc 2.0 2.8) (Event (Context []) (Just $ Arc 2.0 2.7) (Arc 3.3 3.8) (5 :: Int)) - property $ True === res - it "Beginning of an Event is less than the start of the Arc" $ do - let res = onsetIn (Arc 2.0 2.8) (Event (Context []) (Just $ Arc 1.2 1.7) (Arc 3.3 3.8) (5 :: Int)) - property $ False === res - it "Start of Event is greater than the start of the given Arc" $ do - let res = onsetIn (Arc 2.0 2.8) (Event (Context []) (Just $ Arc 3.1 3.5) (Arc 4.0 4.6) (5 :: Int)) - property $ False === res + it "If the beginning of an Event is within a given Arc, same rules as 'isIn'" $ do + let res = onsetIn (Arc 2.0 2.8) (Event (Context []) (Just $ Arc 2.2 2.7) (Arc 3.3 3.8) (5 :: Int)) + property $ True === res + it "Beginning of Event is equal to beggining of given Arc" $ do + let res = onsetIn (Arc 2.0 2.8) (Event (Context []) (Just $ Arc 2.0 2.7) (Arc 3.3 3.8) (5 :: Int)) + property $ True === res + it "Beginning of an Event is less than the start of the Arc" $ do + let res = onsetIn (Arc 2.0 2.8) (Event (Context []) (Just $ Arc 1.2 1.7) (Arc 3.3 3.8) (5 :: Int)) + property $ False === res + it "Start of Event is greater than the start of the given Arc" $ do + let res = onsetIn (Arc 2.0 2.8) (Event (Context []) (Just $ Arc 3.1 3.5) (Arc 4.0 4.6) (5 :: Int)) + property $ False === res describe "subArc" $ do - it "Checks if an Arc is within another, returns Just (max $ (fst a1) (fst a2), min $ (snd a1) (snd a2)) if so, otherwise Nothing" $ do + it "Checks if an Arc is within another, returns Just (max $ (fst a1) (fst a2), min $ (snd a1) (snd a2)) if so, otherwise Nothing" $ do let res = subArc (Arc 2.1 2.4) (Arc 2.4 2.8) property $ Nothing === res it "if max (fst arc1) (fst arc2) <= min (snd arc1) (snd arc2) return Just (max (fst arc1) (fst arc2), min...)" $ do @@ -384,11 +395,11 @@ run = describe "timeToCycleArc" $ do it "given a Time value return the Arc in which it resides" $ do - let res = timeToCycleArc 2.2 + let res = timeToCycleArc 2.2 property $ (Arc 2.0 3.0) === res - describe "cyclesInArc" $ do - it "Return a list of cycles in a given arc, if start is greater than end return empty list" $ do + describe "cyclesInArc" $ do + it "Return a list of cycles in a given arc, if start is greater than end return empty list" $ do let res = cyclesInArc (Arc 2.4 2.2) property $ ([] :: [Int]) === res it "If start value of Arc is equal to end value return list with start value rounded down" $ do @@ -396,80 +407,80 @@ run = property $ ([2] :: [Int]) === res it "if start of Arc is less than end return list of start rounded down to end rounded up minus one" $ do let res = cyclesInArc (Arc 2.2 4.5) - property $ ([2,3,4] :: [Int]) === res + property $ ([2, 3, 4] :: [Int]) === res describe "cycleArcsInArc" $ do it "generates a list of Arcs based on the cycles found within a given a Arc" $ do - let res = cycleArcsInArc (Arc 2.2 4.5) - property $ [(Arc 2.0 3.0), (Arc 3.0 4.0), (Arc 4.0 5.0)] === res + let res = cycleArcsInArc (Arc 2.2 4.5) + property $ [(Arc 2.0 3.0), (Arc 3.0 4.0), (Arc 4.0 5.0)] === res describe "isAdjacent" $ do - it "if the given Events are adjacent parts of the same whole" $ do + it "if the given Events are adjacent parts of the same whole" $ do let res = isAdjacent (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5) (Event (Context []) (Just $ Arc 1 2) (Arc 4 3) (5 :: Int)) - property $ True === res + property $ True === res it "if first Arc of of first Event is not equal to first Arc of second Event" $ do let res = isAdjacent (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5) (Event (Context []) (Just $ Arc 7 8) (Arc 4 3) (5 :: Int)) - property $ False === res - it "if the value of the first Event does not equal the value of the second Event" $ do + property $ False === res + it "if the value of the first Event does not equal the value of the second Event" $ do let res = isAdjacent (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5) (Event (Context []) (Just $ Arc 1 2) (Arc 4 3) (6 :: Int)) - property $ False === res + property $ False === res it "second value of second Arc of first Event not equal to first value of second Arc in second Event..." $ do let res = isAdjacent (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5) (Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)) - property $ False === res + property $ False === res - describe "defragParts" $ do - it "if empty list with no events return empty list" $ do - let res = defragParts ([] :: [Event Int]) + describe "defragParts" $ do + it "if empty list with no events return empty list" $ do + let res = defragParts ([] :: [Event Int]) property $ [] === res - it "if list consists of only one Event return it as is" $ do + it "if list consists of only one Event return it as is" $ do let res = defragParts [(Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int))] - property $ [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)] === res - it "if list contains adjacent Events return list with Parts combined" $ do + property $ [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)] === res + it "if list contains adjacent Events return list with Parts combined" $ do let res = defragParts [(Event (Context []) (Just $ Arc 1 2) (Arc 3 4) (5 :: Int)), (Event (Context []) (Just $ Arc 1 2) (Arc 4 3) (5 :: Int))] property $ [(Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5)] === res - it "if list contains more than one Event none of which are adjacent, return List as is" $ do + it "if list contains more than one Event none of which are adjacent, return List as is" $ do let res = defragParts [(Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5), (Event (Context []) (Just $ Arc 7 8) (Arc 4 3) (5 :: Int))] property $ [Event (Context []) (Just $ Arc 1 2) (Arc 3 4) 5, Event (Context []) (Just $ Arc 7 8) (Arc 4 3) (5 :: Int)] === res - describe "sect" $ do + describe "sect" $ do it "take two Arcs and return - Arc (max of two starts) (min of two ends)" $ do let res = sect (Arc 2.2 3) (Arc 2 2.9) property $ Arc 2.2 2.9 == res - describe "hull" $ do + describe "hull" $ do it "take two Arcs anre return - Arc (min of two starts) (max of two ends)" $ do - let res = hull (Arc 2.2 3) (Arc 2 2.9) + let res = hull (Arc 2.2 3) (Arc 2 2.9) property $ Arc 2 3 == res - describe "withResultArc" $ do - it "apply given function to the Arcs" $ do - let p = withResultArc (+5) (stripContext $ fast "1 2" "3 4" :: Pattern Int) - let res = queryArc p (Arc 0 1) - property $ res === fmap toEvent [(((5, 11%2), (5, 11%2)), 3), (((11%2, 23%4), (11%2, 23%4)), 3), (((23%4, 6), (23%4, 6)), 4)] + describe "withResultArc" $ do + it "apply given function to the Arcs" $ do + let p = withResultArc (+ 5) (stripContext $ fast "1 2" "3 4" :: Pattern Int) + let res = queryArc p (Arc 0 1) + property $ res === fmap toEvent [(((5, 11 % 2), (5, 11 % 2)), 3), (((11 % 2, 23 % 4), (11 % 2, 23 % 4)), 3), (((23 % 4, 6), (23 % 4, 6)), 4)] - describe "applyFIS" $ do - it "apply Float function when value of type VF" $ do - let res = applyFIS (+1) (+1) (++ "1") (VF 1) + describe "applyFIS" $ do + it "apply Float function when value of type VF" $ do + let res = applyFIS (+ 1) (+ 1) (++ "1") (VF 1) property $ (VF 2.0) === res - it "apply Int function when value of type VI" $ do - let res = applyFIS (+1) (+1) (++ "1") (VI 1) + it "apply Int function when value of type VI" $ do + let res = applyFIS (+ 1) (+ 1) (++ "1") (VI 1) property $ (VI 2) === res it "apply String function when value of type VS" $ do - let res = applyFIS (+1) (+1) (++ "1") (VS "1") - property $ (VS "11") === res + let res = applyFIS (+ 1) (+ 1) (++ "1") (VS "1") + property $ (VS "11") === res describe "fNum2" $ do - it "apply Int function for two Int values" $ do + it "apply Int function for two Int values" $ do let res = fNum2 (+) (+) (VI 2) (VI 3) - property $ (VI 5) === res - it "apply float function when given two float values" $ do + property $ (VI 5) === res + it "apply float function when given two float values" $ do let res = fNum2 (+) (+) (VF 2) (VF 3) - property $ (VF 5.0) === res + property $ (VF 5.0) === res it "apply float function when one float and one int value given" $ do - let res = fNum2 (+) (+) (VF 2) (VI 3) - property $ (VF 5.0) === res + let res = fNum2 (+) (+) (VF 2) (VI 3) + property $ (VF 5.0) === res - describe "getI" $ do + describe "getI" $ do it "get Just value when Int value is supplied" $ do let res = getI (VI 3) property $ (Just 3) === res @@ -480,68 +491,67 @@ run = let res = getI (VS "3") property $ Nothing === res - describe "getF" $ do - it "get Just value when Float value is supplied" $ do - let res = getF (VF 3) - property $ (Just 3.0) === res - it "get converted value if Int value is supplied" $ do - let res = getF (VI 3) - property $ (Just 3.0) === res - - describe "getS" $ do - it "get Just value when String value is supplied" $ do - let res = getS (VS "Tidal") - property $ (Just "Tidal") === res - it "get Nothing if Int value is not supplied" $ do - let res = getS (VI 3) - property $ Nothing === res - - describe "filterValues" $ do - it "remove Events above given threshold" $ do - let fil = filterValues (<2) $ fastCat [pure 1, pure 2, pure 3] :: Pattern Time - let res = queryArc fil (Arc 0.5 1.5) - property $ fmap toEvent [(((1, 4%3), (1, 4%3)), 1%1)] === res - - it "remove Events below given threshold" $ do - let fil = filterValues (>2) $ fastCat [pure 1, pure 2, pure 3] :: Pattern Time - let res = queryArc fil (Arc 0.5 1.5) - property $ fmap toEvent [(((2%3, 1), (2%3, 1)), 3%1)] === res - - describe "filterWhen" $ do - it "filter below given threshold" $ do - let fil = filterWhen (<0.5) $ struct "t*4" $ (tri :: Pattern Double) + 1 + describe "getF" $ do + it "get Just value when Float value is supplied" $ do + let res = getF (VF 3) + property $ (Just 3.0) === res + it "get converted value if Int value is supplied" $ do + let res = getF (VI 3) + property $ (Just 3.0) === res + + describe "getS" $ do + it "get Just value when String value is supplied" $ do + let res = getS (VS "Tidal") + property $ (Just "Tidal") === res + it "get Nothing if Int value is not supplied" $ do + let res = getS (VI 3) + property $ Nothing === res + + describe "filterValues" $ do + it "remove Events above given threshold" $ do + let fil = filterValues (< 2) $ fastCat [pure 1, pure 2, pure 3] :: Pattern Time + let res = queryArc fil (Arc 0.5 1.5) + property $ fmap toEvent [(((1, 4 % 3), (1, 4 % 3)), 1 % 1)] === res + + it "remove Events below given threshold" $ do + let fil = filterValues (> 2) $ fastCat [pure 1, pure 2, pure 3] :: Pattern Time + let res = queryArc fil (Arc 0.5 1.5) + property $ fmap toEvent [(((2 % 3, 1), (2 % 3, 1)), 3 % 1)] === res + + describe "filterWhen" $ do + it "filter below given threshold" $ do + let fil = filterWhen (< 0.5) $ struct "t*4" $ (tri :: Pattern Double) + 1 let res = queryArc fil (Arc 0.5 1.5) property $ [] === res - it "filter above given threshold" $ do - let fil = stripContext $ filterWhen (>0.5) $ struct "t*4" $ (tri :: Pattern Double) + 1 + it "filter above given threshold" $ do + let fil = stripContext $ filterWhen (> 0.5) $ struct "t*4" $ (tri :: Pattern Double) + 1 let res = queryArc fil (Arc 0.5 1.5) - property $ fmap toEvent [(((3%4, 1), (3%4, 1)), 1.25), (((1, 5%4), (1, 5%4)), 1.25), (((5%4, 3%2), (5%4, 3%2)), 1.75)] === res + property $ fmap toEvent [(((3 % 4, 1), (3 % 4, 1)), 1.25), (((1, 5 % 4), (1, 5 % 4)), 1.25), (((5 % 4, 3 % 2), (5 % 4, 3 % 2)), 1.75)] === res describe "compressArc" $ do - it "return empty if start time is greater than end time" $ do - let res = queryArc (compressArc (Arc 0.8 0.1) (fast "1 2" "3 4" :: Pattern Time) ) (Arc 1 2) + it "return empty if start time is greater than end time" $ do + let res = queryArc (compressArc (Arc 0.8 0.1) (fast "1 2" "3 4" :: Pattern Time)) (Arc 1 2) property $ [] === res - it "return empty if start time or end time are greater than 1" $ do + it "return empty if start time or end time are greater than 1" $ do let res = queryArc (compressArc (Arc 0.1 2) (fast "1 2" "3 4" :: Pattern Time)) (Arc 1 2) property $ [] === res it "return empty if start or end are less than zero" $ do let res = queryArc (compressArc (Arc (-0.8) 0.1) (fast "1 2" "3 4" :: Pattern Time)) (Arc 1 2) property $ [] === res - + it "otherwise compress difference between start and end values of Arc" $ do let p = fast "1 2" "3 4" :: Pattern Time let res = queryArc (stripContext $ compressArc (Arc 0.2 0.8) p) (Arc 0 1) - let expected = fmap toEvent [(((1%5, 1%2), (1%5, 1%2)), 3%1), (((1%2, 13%20), (1%2, 13%20)), 3%1), (((13%20, 4%5), (13%20, 4%5)), 4%1)] + let expected = fmap toEvent [(((1 % 5, 1 % 2), (1 % 5, 1 % 2)), 3 % 1), (((1 % 2, 13 % 20), (1 % 2, 13 % 20)), 3 % 1), (((13 % 20, 4 % 5), (13 % 20, 4 % 5)), 4 % 1)] property $ expected === res - - - -- pending "Sound.Tidal.Pattern.eventL" $ do - -- it "succeeds if the first event 'whole' is shorter" $ do - -- property $ eventL (Event (Context []) (Just $ Arc 0,0),(Arc 0 1)),"x") (((0 0) (Arc 0 1.1)) "x") - -- it "fails if the events are the same length" $ do - -- property $ not $ eventL (Event (Context []) (Just $ Arc 0,0),(Arc 0 1)),"x") (((0 0) (Arc 0 1)) "x") - -- it "fails if the second event is shorter" $ do - -- property $ not $ eventL (Event (Context []) (Just $ Arc 0,0),(Arc 0 1)),"x") (((0 0) (Arc 0 0.5)) "x") + +-- pending "Sound.Tidal.Pattern.eventL" $ do +-- it "succeeds if the first event 'whole' is shorter" $ do +-- property $ eventL (Event (Context []) (Just $ Arc 0,0),(Arc 0 1)),"x") (((0 0) (Arc 0 1.1)) "x") +-- it "fails if the events are the same length" $ do +-- property $ not $ eventL (Event (Context []) (Just $ Arc 0,0),(Arc 0 1)),"x") (((0 0) (Arc 0 1)) "x") +-- it "fails if the second event is shorter" $ do +-- property $ not $ eventL (Event (Context []) (Just $ Arc 0,0),(Arc 0 1)),"x") (((0 0) (Arc 0 0.5)) "x") diff --git a/test/Sound/Tidal/ScalesTest.hs b/test/Sound/Tidal/ScalesTest.hs index 65563548..c91f2aa3 100644 --- a/test/Sound/Tidal/ScalesTest.hs +++ b/test/Sound/Tidal/ScalesTest.hs @@ -2,317 +2,384 @@ module Sound.Tidal.ScalesTest where -import TestUtils -import Test.Microspec - -import Prelude hiding ((<*), (*>)) - -import Sound.Tidal.Scales import Sound.Tidal.Pattern +import Sound.Tidal.Scales +import Test.Microspec +import TestUtils +import Prelude hiding ((*>), (<*)) run :: Microspec () run = describe "Sound.Tidal.Scales" $ do describe "scale" $ do - describe "5 note scales" $ do - let twoOctavesOf5NoteScale = "0 1 2 3 4 5 6 7 8 9" - it "can transform notes correctly over 2 octaves - minPent" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "minPent" twoOctavesOf5NoteScale) - ("0 3 5 7 10 12 15 17 19 22"::Pattern Rational) - it "can transform notes correctly over 2 octaves - majPent" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "majPent" twoOctavesOf5NoteScale) - ("0 2 4 7 9 12 14 16 19 21"::Pattern Rational) - it "can transform notes correctly over 2 octaves - ritusen" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "ritusen" twoOctavesOf5NoteScale) - ("0 2 5 7 9 12 14 17 19 21"::Pattern Rational) - it "can transform notes correctly over 2 octaves - egyptian" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "egyptian" twoOctavesOf5NoteScale) - ("0 2 5 7 10 12 14 17 19 22"::Pattern Rational) - it "can transform notes correctly over 2 octaves - kumai" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "kumai" twoOctavesOf5NoteScale) - ("0 2 3 7 9 12 14 15 19 21"::Pattern Rational) - it "can transform notes correctly over 2 octaves - hirajoshi" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "hirajoshi" twoOctavesOf5NoteScale) - ("0 2 3 7 8 12 14 15 19 20"::Pattern Rational) - it "can transform notes correctly over 2 octaves - iwato" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "iwato" twoOctavesOf5NoteScale) - ("0 1 5 6 10 12 13 17 18 22"::Pattern Rational) - it "can transform notes correctly over 2 octaves - chinese" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "chinese" twoOctavesOf5NoteScale) - ("0 4 6 7 11 12 16 18 19 23"::Pattern Rational) - it "can transform notes correctly over 2 octaves - indian" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "indian" twoOctavesOf5NoteScale) - ("0 4 5 7 10 12 16 17 19 22"::Pattern Rational) - it "can transform notes correctly over 2 octaves - pelog" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "pelog" twoOctavesOf5NoteScale) - ("0 1 3 7 8 12 13 15 19 20"::Pattern Rational) - it "can transform notes correctly over 2 octaves - prometheus" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "prometheus" twoOctavesOf5NoteScale) - ("0 2 4 6 11 12 14 16 18 23"::Pattern Rational) - it "can transform notes correctly over 2 octaves - scriabin" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "scriabin" twoOctavesOf5NoteScale) - ("0 1 4 7 9 12 13 16 19 21"::Pattern Rational) - it "can transform notes correctly over 2 octaves - gong" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "gong" twoOctavesOf5NoteScale) - ("0 2 4 7 9 12 14 16 19 21"::Pattern Rational) - it "can transform notes correctly over 2 octaves - shang" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "shang" twoOctavesOf5NoteScale) - ("0 2 5 7 10 12 14 17 19 22"::Pattern Rational) - it "can transform notes correctly over 2 octaves - jiao" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "jiao" twoOctavesOf5NoteScale) - ("0 3 5 8 10 12 15 17 20 22"::Pattern Rational) - it "can transform notes correctly over 2 octaves - zhi" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "zhi" twoOctavesOf5NoteScale) - ("0 2 5 7 9 12 14 17 19 21"::Pattern Rational) - it "can transform notes correctly over 2 octaves - yu" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "yu" twoOctavesOf5NoteScale) - ("0 3 5 7 10 12 15 17 19 22"::Pattern Rational) - describe "6 note scales" $ do - let twoOctavesOf6NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11" - it "can transform notes correctly over 2 octaves - whole" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "whole" twoOctavesOf6NoteScale) - ("0 2 4 6 8 10 12 14 16 18 20 22"::Pattern Rational) - it "can transform notes correctly over 2 octaves - wholetone" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "wholetone" twoOctavesOf6NoteScale) - (Sound.Tidal.Scales.scale "whole" twoOctavesOf6NoteScale :: Pattern Rational) - it "can transform notes correctly over 2 octaves - augmented" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "augmented" twoOctavesOf6NoteScale) - ("0 3 4 7 8 11 12 15 16 19 20 23"::Pattern Rational) - it "can transform notes correctly over 2 octaves - augmented2" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "augmented2" twoOctavesOf6NoteScale) - ("0 1 4 5 8 9 12 13 16 17 20 21"::Pattern Rational) - it "can transform notes correctly over 2 octaves - hexMajor7" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "hexMajor7" twoOctavesOf6NoteScale) - ("0 2 4 7 9 11 12 14 16 19 21 23"::Pattern Rational) - it "can transform notes correctly over 2 octaves - hexPhrygian" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "hexPhrygian" twoOctavesOf6NoteScale) - ("0 1 3 5 8 10 12 13 15 17 20 22"::Pattern Rational) - it "can transform notes correctly over 2 octaves - hexDorian" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "hexDorian" twoOctavesOf6NoteScale) - ("0 2 3 5 7 10 12 14 15 17 19 22"::Pattern Rational) - it "can transform notes correctly over 2 octaves - hexSus" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "hexSus" twoOctavesOf6NoteScale) - ("0 2 5 7 9 10 12 14 17 19 21 22"::Pattern Rational) - it "can transform notes correctly over 2 octaves - hexMajor6" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "hexMajor6" twoOctavesOf6NoteScale) - ("0 2 4 5 7 9 12 14 16 17 19 21"::Pattern Rational) - it "can transform notes correctly over 2 octaves - hexAeolian" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "hexAeolian" twoOctavesOf6NoteScale) - ("0 3 5 7 8 10 12 15 17 19 20 22"::Pattern Rational) - describe "7 note scales" $ do - let twoOctavesOf7NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13" - it "can transform notes correctly over 2 octaves - major" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "major" twoOctavesOf7NoteScale) - ("0 2 4 5 7 9 11 12 14 16 17 19 21 23"::Pattern Rational) - it "can transform notes correctly over 2 octaves - ionian" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "ionian" twoOctavesOf7NoteScale) - (Sound.Tidal.Scales.scale "major" twoOctavesOf7NoteScale :: Pattern Rational) - it "can transform notes correctly over 2 octaves - dorian" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "dorian" twoOctavesOf7NoteScale) - ("0 2 3 5 7 9 10 12 14 15 17 19 21 22"::Pattern Rational) - it "can transform notes correctly over 2 octaves - aeolian" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "aeolian" twoOctavesOf7NoteScale) - ("0 2 3 5 7 8 10 12 14 15 17 19 20 22"::Pattern Rational) - it "can transform notes correctly over 2 octaves - aeolian" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "minor" twoOctavesOf7NoteScale) - (Sound.Tidal.Scales.scale "aeolian" twoOctavesOf7NoteScale::Pattern Rational) - it "can transform notes correctly over 2 octaves - minor" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "minor" twoOctavesOf7NoteScale) - (Sound.Tidal.Scales.scale "aeolian" twoOctavesOf7NoteScale::Pattern Rational) - it "can transform notes correctly over 2 octaves - locrian" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "locrian" twoOctavesOf7NoteScale) - ("0 1 3 5 6 8 10 12 13 15 17 18 20 22"::Pattern Rational) - it "can transform notes correctly over 2 octaves - harmonicMinor" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "harmonicMinor" twoOctavesOf7NoteScale) - ("0 2 3 5 7 8 11 12 14 15 17 19 20 23"::Pattern Rational) - it "can transform notes correctly over 2 octaves - harmonicMajor" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "harmonicMajor" twoOctavesOf7NoteScale) - ("0 2 4 5 7 8 11 12 14 16 17 19 20 23"::Pattern Rational) - it "can transform notes correctly over 2 octaves - melodicMinor" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "melodicMinor" twoOctavesOf7NoteScale) - ("0 2 3 5 7 9 11 12 14 15 17 19 21 23"::Pattern Rational) - it "can transform notes correctly over 2 octaves - melodicMinorDesc" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "melodicMinorDesc" twoOctavesOf7NoteScale) - (Sound.Tidal.Scales.scale "minor" twoOctavesOf7NoteScale::Pattern Rational) - it "can transform notes correctly over 2 octaves - melodicMajor" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "melodicMajor" twoOctavesOf7NoteScale) - ("0 2 4 5 7 8 10 12 14 16 17 19 20 22"::Pattern Rational) - it "can transform notes correctly over 2 octaves - bartok" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "bartok" twoOctavesOf7NoteScale) - (Sound.Tidal.Scales.scale "melodicMajor" twoOctavesOf7NoteScale::Pattern Rational) - it "can transform notes correctly over 2 octaves - hindu" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "hindu" twoOctavesOf7NoteScale) - (Sound.Tidal.Scales.scale "melodicMajor" twoOctavesOf7NoteScale::Pattern Rational) - it "can transform notes correctly over 2 octaves - todi" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "todi" twoOctavesOf7NoteScale) - ("0 1 3 6 7 8 11 12 13 15 18 19 20 23"::Pattern Rational) - it "can transform notes correctly over 2 octaves - purvi" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "purvi" twoOctavesOf7NoteScale) - ("0 1 4 6 7 8 11 12 13 16 18 19 20 23"::Pattern Rational) - it "can transform notes correctly over 2 octaves - marva" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "marva" twoOctavesOf7NoteScale) - ("0 1 4 6 7 9 11 12 13 16 18 19 21 23"::Pattern Rational) - it "can transform notes correctly over 2 octaves - bhairav" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "bhairav" twoOctavesOf7NoteScale) - ("0 1 4 5 7 8 11 12 13 16 17 19 20 23"::Pattern Rational) - it "can transform notes correctly over 2 octaves - ahirbhairav" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "ahirbhairav" twoOctavesOf7NoteScale) - ("0 1 4 5 7 9 10 12 13 16 17 19 21 22"::Pattern Rational) - it "can transform notes correctly over 2 octaves - superLocrian" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "superLocrian" twoOctavesOf7NoteScale) - ("0 1 3 4 6 8 10 12 13 15 16 18 20 22"::Pattern Rational) - it "can transform notes correctly over 2 octaves - romanianMinor" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "romanianMinor" twoOctavesOf7NoteScale) - ("0 2 3 6 7 9 10 12 14 15 18 19 21 22"::Pattern Rational) - it "can transform notes correctly over 2 octaves - hungarianMinor" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "hungarianMinor" twoOctavesOf7NoteScale) - ("0 2 3 6 7 8 11 12 14 15 18 19 20 23"::Pattern Rational) - it "can transform notes correctly over 2 octaves - neapolitanMinor" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "neapolitanMinor" twoOctavesOf7NoteScale) - ("0 1 3 5 7 8 11 12 13 15 17 19 20 23"::Pattern Rational) - it "can transform notes correctly over 2 octaves - enigmatic" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "enigmatic" twoOctavesOf7NoteScale) - ("0 1 4 6 8 10 11 12 13 16 18 20 22 23"::Pattern Rational) - it "can transform notes correctly over 2 octaves - spanish" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "spanish" twoOctavesOf7NoteScale) - ("0 1 4 5 7 8 10 12 13 16 17 19 20 22"::Pattern Rational) - it "can transform notes correctly over 2 octaves - leadingWhole" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "leadingWhole" twoOctavesOf7NoteScale) - ("0 2 4 6 8 10 11 12 14 16 18 20 22 23"::Pattern Rational) - it "can transform notes correctly over 2 octaves - lydianMinor" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "lydianMinor" twoOctavesOf7NoteScale) - ("0 2 4 6 7 8 10 12 14 16 18 19 20 22"::Pattern Rational) - it "can transform notes correctly over 2 octaves - neapolitanMajor" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "neapolitanMajor" twoOctavesOf7NoteScale) - ("0 1 3 5 7 9 11 12 13 15 17 19 21 23"::Pattern Rational) - it "can transform notes correctly over 2 octaves - locrianMajor" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "locrianMajor" twoOctavesOf7NoteScale) - ("0 2 4 5 6 8 10 12 14 16 17 18 20 22"::Pattern Rational) - describe "8 note scales" $ do - let twoOctavesOf8NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15" - it "can transform notes correctly over 2 octaves - diminished" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "diminished" twoOctavesOf8NoteScale) - ("0 1 3 4 6 7 9 10 12 13 15 16 18 19 21 22"::Pattern Rational) - it "can transform notes correctly over 2 octaves - octatonic" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "octatonic" twoOctavesOf8NoteScale) - (Sound.Tidal.Scales.scale "diminished" twoOctavesOf8NoteScale::Pattern Rational) - it "can transform notes correctly over 2 octaves - diminished2" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "diminished2" twoOctavesOf8NoteScale) - ("0 2 3 5 6 8 9 11 12 14 15 17 18 20 21 23"::Pattern Rational) - it "can transform notes correctly over 2 octaves - octatonic2" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "octatonic2" twoOctavesOf8NoteScale) - (Sound.Tidal.Scales.scale "diminished2" twoOctavesOf8NoteScale::Pattern Rational) - describe "modes of limited transposition" $ do - let twoOctavesOf6NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11" - let twoOctavesOf8NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15" - let twoOctavesOf9NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17" - let twoOctavesOf10NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19" - it "can transform notes correctly over 2 octaves - messiaen1" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "messiaen1" twoOctavesOf6NoteScale) - (Sound.Tidal.Scales.scale "wholetone" twoOctavesOf6NoteScale::Pattern Rational) - it "can transform notes correctly over 2 octaves - messiaen2" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "messiaen2" twoOctavesOf8NoteScale) - (Sound.Tidal.Scales.scale "diminished" twoOctavesOf8NoteScale::Pattern Rational) - it "can transform notes correctly over 2 octaves - messiaen3" $ do - -- tone, semitone, semitone, tone, semitone, semitone, tone, semitone, semitone - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "messiaen3" twoOctavesOf9NoteScale) - ("0 2 3 4 6 7 8 10 11 12 14 15 16 18 19 20 22 23"::Pattern Rational) - it "can transform notes correctly over 2 octaves - messiaen4" $ do - -- semitone, semitone, minor third, semitone, semitone, semitone, minor third, semitone - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "messiaen4" twoOctavesOf8NoteScale) - ("0 1 2 5 6 7 8 11 12 13 14 17 18 19 20 23"::Pattern Rational) - it "can transform notes correctly over 2 octaves - messiaen5" $ do - -- semitone, major third, semitone, semitone, major third, semitone - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "messiaen5" twoOctavesOf6NoteScale) - ("0 1 5 6 7 11 12 13 17 18 19 23"::Pattern Rational) - it "can transform notes correctly over 2 octaves - messiaen6" $ do - -- tone, tone, semitone, semitone, tone, tone, semitone, semitone - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "messiaen6" twoOctavesOf8NoteScale) - ("0 2 4 5 6 8 10 11 12 14 16 17 18 20 22 23"::Pattern Rational) - it "can transform notes correctly over 2 octaves - messiaen7" $ do - -- semitone, semitone, semitone, tone, semitone, semitone, semitone, semitone, tone, semitone - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "messiaen7" twoOctavesOf10NoteScale) - ("0 1 2 3 5 6 7 8 9 11 12 13 14 15 17 18 19 20 21 23"::Pattern Rational) - describe "12 note scales" $ do - let twoOctavesOf12NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23" - it "can transform notes correctly over 2 octaves - chromatic" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "chromatic" twoOctavesOf12NoteScale) - ("0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23"::Pattern Rational) - describe "edge cases" $ do - it "responds to unknown scales by mapping to octaves" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "ergaerv" "0 1 2 3 4") - ("0 12 24 36 48"::Pattern Rational) - it "correctly maps negative numbers" $ do - compareP (Arc 0 1) - (Sound.Tidal.Scales.scale "major" "0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13") - ("0 -1 -3 -5 -7 -8 -10 -12 -13 -15 -17 -19 -20 -22 "::Pattern Rational) - + describe "5 note scales" $ do + let twoOctavesOf5NoteScale = "0 1 2 3 4 5 6 7 8 9" + it "can transform notes correctly over 2 octaves - minPent" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "minPent" twoOctavesOf5NoteScale) + ("0 3 5 7 10 12 15 17 19 22" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - majPent" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "majPent" twoOctavesOf5NoteScale) + ("0 2 4 7 9 12 14 16 19 21" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - ritusen" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "ritusen" twoOctavesOf5NoteScale) + ("0 2 5 7 9 12 14 17 19 21" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - egyptian" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "egyptian" twoOctavesOf5NoteScale) + ("0 2 5 7 10 12 14 17 19 22" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - kumai" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "kumai" twoOctavesOf5NoteScale) + ("0 2 3 7 9 12 14 15 19 21" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - hirajoshi" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "hirajoshi" twoOctavesOf5NoteScale) + ("0 2 3 7 8 12 14 15 19 20" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - iwato" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "iwato" twoOctavesOf5NoteScale) + ("0 1 5 6 10 12 13 17 18 22" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - chinese" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "chinese" twoOctavesOf5NoteScale) + ("0 4 6 7 11 12 16 18 19 23" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - indian" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "indian" twoOctavesOf5NoteScale) + ("0 4 5 7 10 12 16 17 19 22" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - pelog" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "pelog" twoOctavesOf5NoteScale) + ("0 1 3 7 8 12 13 15 19 20" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - prometheus" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "prometheus" twoOctavesOf5NoteScale) + ("0 2 4 6 11 12 14 16 18 23" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - scriabin" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "scriabin" twoOctavesOf5NoteScale) + ("0 1 4 7 9 12 13 16 19 21" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - gong" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "gong" twoOctavesOf5NoteScale) + ("0 2 4 7 9 12 14 16 19 21" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - shang" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "shang" twoOctavesOf5NoteScale) + ("0 2 5 7 10 12 14 17 19 22" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - jiao" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "jiao" twoOctavesOf5NoteScale) + ("0 3 5 8 10 12 15 17 20 22" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - zhi" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "zhi" twoOctavesOf5NoteScale) + ("0 2 5 7 9 12 14 17 19 21" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - yu" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "yu" twoOctavesOf5NoteScale) + ("0 3 5 7 10 12 15 17 19 22" :: Pattern Rational) + describe "6 note scales" $ do + let twoOctavesOf6NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11" + it "can transform notes correctly over 2 octaves - whole" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "whole" twoOctavesOf6NoteScale) + ("0 2 4 6 8 10 12 14 16 18 20 22" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - wholetone" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "wholetone" twoOctavesOf6NoteScale) + (Sound.Tidal.Scales.scale "whole" twoOctavesOf6NoteScale :: Pattern Rational) + it "can transform notes correctly over 2 octaves - augmented" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "augmented" twoOctavesOf6NoteScale) + ("0 3 4 7 8 11 12 15 16 19 20 23" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - augmented2" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "augmented2" twoOctavesOf6NoteScale) + ("0 1 4 5 8 9 12 13 16 17 20 21" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - hexMajor7" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "hexMajor7" twoOctavesOf6NoteScale) + ("0 2 4 7 9 11 12 14 16 19 21 23" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - hexPhrygian" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "hexPhrygian" twoOctavesOf6NoteScale) + ("0 1 3 5 8 10 12 13 15 17 20 22" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - hexDorian" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "hexDorian" twoOctavesOf6NoteScale) + ("0 2 3 5 7 10 12 14 15 17 19 22" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - hexSus" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "hexSus" twoOctavesOf6NoteScale) + ("0 2 5 7 9 10 12 14 17 19 21 22" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - hexMajor6" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "hexMajor6" twoOctavesOf6NoteScale) + ("0 2 4 5 7 9 12 14 16 17 19 21" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - hexAeolian" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "hexAeolian" twoOctavesOf6NoteScale) + ("0 3 5 7 8 10 12 15 17 19 20 22" :: Pattern Rational) + describe "7 note scales" $ do + let twoOctavesOf7NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13" + it "can transform notes correctly over 2 octaves - major" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "major" twoOctavesOf7NoteScale) + ("0 2 4 5 7 9 11 12 14 16 17 19 21 23" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - ionian" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "ionian" twoOctavesOf7NoteScale) + (Sound.Tidal.Scales.scale "major" twoOctavesOf7NoteScale :: Pattern Rational) + it "can transform notes correctly over 2 octaves - dorian" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "dorian" twoOctavesOf7NoteScale) + ("0 2 3 5 7 9 10 12 14 15 17 19 21 22" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - aeolian" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "aeolian" twoOctavesOf7NoteScale) + ("0 2 3 5 7 8 10 12 14 15 17 19 20 22" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - aeolian" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "minor" twoOctavesOf7NoteScale) + (Sound.Tidal.Scales.scale "aeolian" twoOctavesOf7NoteScale :: Pattern Rational) + it "can transform notes correctly over 2 octaves - minor" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "minor" twoOctavesOf7NoteScale) + (Sound.Tidal.Scales.scale "aeolian" twoOctavesOf7NoteScale :: Pattern Rational) + it "can transform notes correctly over 2 octaves - locrian" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "locrian" twoOctavesOf7NoteScale) + ("0 1 3 5 6 8 10 12 13 15 17 18 20 22" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - harmonicMinor" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "harmonicMinor" twoOctavesOf7NoteScale) + ("0 2 3 5 7 8 11 12 14 15 17 19 20 23" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - harmonicMajor" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "harmonicMajor" twoOctavesOf7NoteScale) + ("0 2 4 5 7 8 11 12 14 16 17 19 20 23" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - melodicMinor" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "melodicMinor" twoOctavesOf7NoteScale) + ("0 2 3 5 7 9 11 12 14 15 17 19 21 23" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - melodicMinorDesc" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "melodicMinorDesc" twoOctavesOf7NoteScale) + (Sound.Tidal.Scales.scale "minor" twoOctavesOf7NoteScale :: Pattern Rational) + it "can transform notes correctly over 2 octaves - melodicMajor" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "melodicMajor" twoOctavesOf7NoteScale) + ("0 2 4 5 7 8 10 12 14 16 17 19 20 22" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - bartok" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "bartok" twoOctavesOf7NoteScale) + (Sound.Tidal.Scales.scale "melodicMajor" twoOctavesOf7NoteScale :: Pattern Rational) + it "can transform notes correctly over 2 octaves - hindu" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "hindu" twoOctavesOf7NoteScale) + (Sound.Tidal.Scales.scale "melodicMajor" twoOctavesOf7NoteScale :: Pattern Rational) + it "can transform notes correctly over 2 octaves - todi" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "todi" twoOctavesOf7NoteScale) + ("0 1 3 6 7 8 11 12 13 15 18 19 20 23" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - purvi" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "purvi" twoOctavesOf7NoteScale) + ("0 1 4 6 7 8 11 12 13 16 18 19 20 23" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - marva" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "marva" twoOctavesOf7NoteScale) + ("0 1 4 6 7 9 11 12 13 16 18 19 21 23" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - bhairav" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "bhairav" twoOctavesOf7NoteScale) + ("0 1 4 5 7 8 11 12 13 16 17 19 20 23" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - ahirbhairav" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "ahirbhairav" twoOctavesOf7NoteScale) + ("0 1 4 5 7 9 10 12 13 16 17 19 21 22" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - superLocrian" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "superLocrian" twoOctavesOf7NoteScale) + ("0 1 3 4 6 8 10 12 13 15 16 18 20 22" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - romanianMinor" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "romanianMinor" twoOctavesOf7NoteScale) + ("0 2 3 6 7 9 10 12 14 15 18 19 21 22" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - hungarianMinor" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "hungarianMinor" twoOctavesOf7NoteScale) + ("0 2 3 6 7 8 11 12 14 15 18 19 20 23" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - neapolitanMinor" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "neapolitanMinor" twoOctavesOf7NoteScale) + ("0 1 3 5 7 8 11 12 13 15 17 19 20 23" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - enigmatic" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "enigmatic" twoOctavesOf7NoteScale) + ("0 1 4 6 8 10 11 12 13 16 18 20 22 23" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - spanish" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "spanish" twoOctavesOf7NoteScale) + ("0 1 4 5 7 8 10 12 13 16 17 19 20 22" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - leadingWhole" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "leadingWhole" twoOctavesOf7NoteScale) + ("0 2 4 6 8 10 11 12 14 16 18 20 22 23" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - lydianMinor" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "lydianMinor" twoOctavesOf7NoteScale) + ("0 2 4 6 7 8 10 12 14 16 18 19 20 22" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - neapolitanMajor" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "neapolitanMajor" twoOctavesOf7NoteScale) + ("0 1 3 5 7 9 11 12 13 15 17 19 21 23" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - locrianMajor" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "locrianMajor" twoOctavesOf7NoteScale) + ("0 2 4 5 6 8 10 12 14 16 17 18 20 22" :: Pattern Rational) + describe "8 note scales" $ do + let twoOctavesOf8NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15" + it "can transform notes correctly over 2 octaves - diminished" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "diminished" twoOctavesOf8NoteScale) + ("0 1 3 4 6 7 9 10 12 13 15 16 18 19 21 22" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - octatonic" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "octatonic" twoOctavesOf8NoteScale) + (Sound.Tidal.Scales.scale "diminished" twoOctavesOf8NoteScale :: Pattern Rational) + it "can transform notes correctly over 2 octaves - diminished2" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "diminished2" twoOctavesOf8NoteScale) + ("0 2 3 5 6 8 9 11 12 14 15 17 18 20 21 23" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - octatonic2" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "octatonic2" twoOctavesOf8NoteScale) + (Sound.Tidal.Scales.scale "diminished2" twoOctavesOf8NoteScale :: Pattern Rational) + describe "modes of limited transposition" $ do + let twoOctavesOf6NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11" + let twoOctavesOf8NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15" + let twoOctavesOf9NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17" + let twoOctavesOf10NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19" + it "can transform notes correctly over 2 octaves - messiaen1" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "messiaen1" twoOctavesOf6NoteScale) + (Sound.Tidal.Scales.scale "wholetone" twoOctavesOf6NoteScale :: Pattern Rational) + it "can transform notes correctly over 2 octaves - messiaen2" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "messiaen2" twoOctavesOf8NoteScale) + (Sound.Tidal.Scales.scale "diminished" twoOctavesOf8NoteScale :: Pattern Rational) + it "can transform notes correctly over 2 octaves - messiaen3" $ do + -- tone, semitone, semitone, tone, semitone, semitone, tone, semitone, semitone + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "messiaen3" twoOctavesOf9NoteScale) + ("0 2 3 4 6 7 8 10 11 12 14 15 16 18 19 20 22 23" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - messiaen4" $ do + -- semitone, semitone, minor third, semitone, semitone, semitone, minor third, semitone + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "messiaen4" twoOctavesOf8NoteScale) + ("0 1 2 5 6 7 8 11 12 13 14 17 18 19 20 23" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - messiaen5" $ do + -- semitone, major third, semitone, semitone, major third, semitone + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "messiaen5" twoOctavesOf6NoteScale) + ("0 1 5 6 7 11 12 13 17 18 19 23" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - messiaen6" $ do + -- tone, tone, semitone, semitone, tone, tone, semitone, semitone + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "messiaen6" twoOctavesOf8NoteScale) + ("0 2 4 5 6 8 10 11 12 14 16 17 18 20 22 23" :: Pattern Rational) + it "can transform notes correctly over 2 octaves - messiaen7" $ do + -- semitone, semitone, semitone, tone, semitone, semitone, semitone, semitone, tone, semitone + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "messiaen7" twoOctavesOf10NoteScale) + ("0 1 2 3 5 6 7 8 9 11 12 13 14 15 17 18 19 20 21 23" :: Pattern Rational) + describe "12 note scales" $ do + let twoOctavesOf12NoteScale = "0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23" + it "can transform notes correctly over 2 octaves - chromatic" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "chromatic" twoOctavesOf12NoteScale) + ("0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23" :: Pattern Rational) + describe "edge cases" $ do + it "responds to unknown scales by mapping to octaves" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "ergaerv" "0 1 2 3 4") + ("0 12 24 36 48" :: Pattern Rational) + it "correctly maps negative numbers" $ do + compareP + (Arc 0 1) + (Sound.Tidal.Scales.scale "major" "0 -1 -2 -3 -4 -5 -6 -7 -8 -9 -10 -11 -12 -13") + ("0 -1 -3 -5 -7 -8 -10 -12 -13 -15 -17 -19 -20 -22 " :: Pattern Rational) diff --git a/test/Sound/Tidal/StreamTest.hs b/test/Sound/Tidal/StreamTest.hs index 06dd610b..81d4c10c 100644 --- a/test/Sound/Tidal/StreamTest.hs +++ b/test/Sound/Tidal/StreamTest.hs @@ -2,11 +2,11 @@ module Sound.Tidal.StreamTest where -import Test.Microspec -import Sound.Tidal.Stream -import Sound.Tidal.Pattern -import qualified Sound.Osc.Fd as O import qualified Data.Map.Strict as M +import qualified Sound.Osc.Fd as O +import Sound.Tidal.Pattern +import Sound.Tidal.Stream +import Test.Microspec run :: Microspec () run = @@ -14,7 +14,7 @@ run = describe "toDatum" $ do it "should convert VN to osc float" $ do toDatum (VN (Note 3.5)) `shouldBe` O.float (3.5 :: Double) - + describe "substitutePath" $ do -- ValueMap let state = M.fromList [("sound", VS "sn"), ("n", VI 8)] @@ -24,7 +24,7 @@ run = substitutePath "/{sound}/{n}/vol" state `shouldBe` Just "/sn/8/vol" it "should return Nothing if a param is not present" $ do substitutePath "/{sound}/{inst}" state `shouldBe` Nothing - + describe "getString" $ do it "should return Nothing for missing params" $ do getString M.empty "s" `shouldBe` Nothing diff --git a/test/Sound/Tidal/UITest.hs b/test/Sound/Tidal/UITest.hs index 68af5350..f2aec0f9 100644 --- a/test/Sound/Tidal/UITest.hs +++ b/test/Sound/Tidal/UITest.hs @@ -2,13 +2,7 @@ module Sound.Tidal.UITest where -import TestUtils -import Test.Microspec - -import Prelude hiding ((<*), (*>)) - import qualified Data.Map.Strict as Map - -- import Sound.Tidal.Pattern import Sound.Tidal.Control import Sound.Tidal.Core @@ -16,17 +10,22 @@ import Sound.Tidal.Params import Sound.Tidal.ParseBP import Sound.Tidal.Pattern import Sound.Tidal.UI +import Test.Microspec +import TestUtils +import Prelude hiding ((*>), (<*)) run :: Microspec () run = describe "Sound.Tidal.UI" $ do describe "_chop" $ do it "can chop in two bits" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (_chop 2 $ s (pure "a")) (begin (fastcat [pure 0, pure 0.5]) # end (fastcat [pure 0.5, pure 1]) # (s (pure "a"))) it "can be slowed" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (slow 2 $ _chop 2 $ s (pure "a")) (begin (pure 0) # end (pure 0.5) # (s (pure "a"))) it "can chop a chop" $ @@ -34,99 +33,85 @@ run = describe "segment" $ do it "can turn a single event into multiple events" $ do - compareP (Arc 0 3) + compareP + (Arc 0 3) (segment 4 "x") ("x*4" :: Pattern String) it "can turn a continuous pattern into multiple discrete events" $ do - compareP (Arc 0 3) + compareP + (Arc 0 3) (segment 4 saw) ("0.125 0.375 0.625 0.875" :: Pattern Double) it "can hold a value over multiple cycles" $ do - comparePD (Arc 0 8) + comparePD + (Arc 0 8) (segment 0.5 saw) (slow 2 "0" :: Pattern Double) - {- - -- not sure what this is supposed to do! - it "holding values over multiple cycles works in combination" $ do - comparePD (Arc 0 8) - ("0*4" |+ (_segment (1/8) $ saw)) - ("0*4" :: Pattern Double) - -} + {- + -- not sure what this is supposed to do! + it "holding values over multiple cycles works in combination" $ do + comparePD (Arc 0 8) + ("0*4" |+ (_segment (1/8) $ saw)) + ("0*4" :: Pattern Double) + -} describe "rolledBy" $ do it "shifts each start of events in a list correctly" $ do - let - overTimeSpan = (Arc 0 1) - testMe = rolledBy "0.5" $ n ("[0,1,2,3]") - expectedResult = n "[0, ~ 1@7, ~@2 2@6, ~@3 3@5]" - in - compareP overTimeSpan testMe expectedResult + let overTimeSpan = (Arc 0 1) + testMe = rolledBy "0.5" $ n ("[0,1,2,3]") + expectedResult = n "[0, ~ 1@7, ~@2 2@6, ~@3 3@5]" + in compareP overTimeSpan testMe expectedResult it "shifts each start of events in a list correctly in reverse order" $ do - let - overTimeSpan = (Arc 0 1) - testMe = rolledBy "-0.5" $ n ("[0,1,2,3]") - expectedResult = n "[3, ~ 2@7, ~@2 1@6, ~@3 0@5]" - in - compareP overTimeSpan testMe expectedResult + let overTimeSpan = (Arc 0 1) + testMe = rolledBy "-0.5" $ n ("[0,1,2,3]") + expectedResult = n "[3, ~ 2@7, ~@2 1@6, ~@3 0@5]" + in compareP overTimeSpan testMe expectedResult it "trims the result pattern if it becomes larger than the original pattern" $ do - let - overTimeSpan = (Arc 0 1) - testMe = rolledBy "1.5" $ n ("[0,1,2]") - expectedResult = n "[0, ~ 1]" - in - compareP overTimeSpan testMe expectedResult + let overTimeSpan = (Arc 0 1) + testMe = rolledBy "1.5" $ n ("[0,1,2]") + expectedResult = n "[0, ~ 1]" + in compareP overTimeSpan testMe expectedResult it "does nothing for continous functions" $ do - let - overTimeSpan = (Arc 0 1) - testMe = n (rolledBy "0.25" (irand 0) |+ "[0,12]") - expectedResult = n (irand 0) |+ n "[0, 12]" - in - compareP overTimeSpan testMe expectedResult + let overTimeSpan = (Arc 0 1) + testMe = n (rolledBy "0.25" (irand 0) |+ "[0,12]") + expectedResult = n (irand 0) |+ n "[0, 12]" + in compareP overTimeSpan testMe expectedResult it "does nothing when passing zero as time value" $ do - let - overTimeSpan = (Arc 0 1) - testMe = n (rolledBy "0" "[0,1,2,3]") - expectedResult = n "[0,1,2,3]" - in - compareP overTimeSpan testMe expectedResult - + let overTimeSpan = (Arc 0 1) + testMe = n (rolledBy "0" "[0,1,2,3]") + expectedResult = n "[0,1,2,3]" + in compareP overTimeSpan testMe expectedResult describe "sometimesBy" $ do it "does nothing when set at 0% probability" $ do - let - overTimeSpan = (Arc 0 1) - testMe = sometimesBy 0 (rev) (ps "bd*2 hh sn") - expectedResult = ps "bd*2 hh sn" - in - compareP overTimeSpan testMe expectedResult + let overTimeSpan = (Arc 0 1) + testMe = sometimesBy 0 (rev) (ps "bd*2 hh sn") + expectedResult = ps "bd*2 hh sn" + in compareP overTimeSpan testMe expectedResult it "applies the 'rev' function when set at 100% probability" $ do - let - overTimeSpan = (Arc 0 1) - testMe = sometimesBy 1 (rev) (ps "bd*2 hh cp") - expectedResult = ps "cp hh bd*2" - in - compareP overTimeSpan testMe expectedResult + let overTimeSpan = (Arc 0 1) + testMe = sometimesBy 1 (rev) (ps "bd*2 hh cp") + expectedResult = ps "cp hh bd*2" + in compareP overTimeSpan testMe expectedResult describe "sometimesBy'" $ do it "does nothing when set at 0% probability -- using const" $ do - let - overTimeSpan = (Arc 0 2) - testMe = sometimesBy' 0 (const $ s "cp") (s "bd*8") - expectedResult = s "bd*8" - in - compareP overTimeSpan testMe expectedResult + let overTimeSpan = (Arc 0 2) + testMe = sometimesBy' 0 (const $ s "cp") (s "bd*8") + expectedResult = s "bd*8" + in compareP overTimeSpan testMe expectedResult describe "rand" $ do it "generates a (pseudo-)random number between zero & one" $ do it "at the start of a cycle" $ (queryArc rand (Arc 0 0)) `shouldBe` [Event (Context []) Nothing (Arc 0 0) (0 :: Float)] it "at 1/4 of a cycle" $ - (queryArc rand (Arc 0.25 0.25)) `shouldBe` - [Event (Context []) Nothing (Arc 0.25 0.25) (0.6295689214020967:: Float)] + (queryArc rand (Arc 0.25 0.25)) + `shouldBe` [Event (Context []) Nothing (Arc 0.25 0.25) (0.6295689214020967 :: Float)] it "at 3/4 of a cycle" $ - (queryArc rand (Arc 0.75 0.75)) `shouldBe` - [Event (Context []) Nothing (Arc 0.75 0.75) (0.20052618719637394 :: Float)] + (queryArc rand (Arc 0.75 0.75)) + `shouldBe` [Event (Context []) Nothing (Arc 0.75 0.75) (0.20052618719637394 :: Float)] describe "irand" $ do it "generates a (pseudo-random) integer between zero & i" $ do @@ -135,311 +120,362 @@ run = it "at 1/4 of a cycle" $ (queryArc (irand 10) (Arc 0.25 0.25)) `shouldBe` [Event (Context []) Nothing (Arc 0.25 0.25) (6 :: Int)] it "is patternable" $ - (queryArc (irand "10 2") (Arc 0 1)) `shouldBe` [ - Event (Context [((1,1),(3,1))]) Nothing (Arc 0 0.5) (6 :: Int), Event (Context [((4,1),(5,1))]) Nothing (Arc 0.5 1) (0 :: Int) - ] + (queryArc (irand "10 2") (Arc 0 1)) + `shouldBe` [ Event (Context [((1, 1), (3, 1))]) Nothing (Arc 0 0.5) (6 :: Int), + Event (Context [((4, 1), (5, 1))]) Nothing (Arc 0.5 1) (0 :: Int) + ] describe "normal" $ do it "produces values within [0,1] in a bell curve" $ do it "at the start of a cycle" $ - queryArc normal (Arc 0 0.1) `shouldBe` - [Event (Context []) Nothing (Arc 0 0.1) (0.4614205864457064 :: Double)] + queryArc normal (Arc 0 0.1) + `shouldBe` [Event (Context []) Nothing (Arc 0 0.1) (0.4614205864457064 :: Double)] it "at 1/4 of a cycle" $ - queryArc normal (Arc 0.25 0.25) `shouldBe` - [Event (Context []) Nothing (Arc 0.25 0.25) (0.5 :: Double)] + queryArc normal (Arc 0.25 0.25) + `shouldBe` [Event (Context []) Nothing (Arc 0.25 0.25) (0.5 :: Double)] it "at 3/4 of a cycle" $ - queryArc normal (Arc 0.75 0.75) `shouldBe` - [Event (Context []) Nothing (Arc 0.75 0.75) (0.5 :: Double)] + queryArc normal (Arc 0.75 0.75) + `shouldBe` [Event (Context []) Nothing (Arc 0.75 0.75) (0.5 :: Double)] describe "range" $ do describe "scales a pattern to the supplied range" $ do describe "from 3 to 4" $ do it "at the start of a cycle" $ - (queryArc (Sound.Tidal.UI.range 3 4 saw) (Arc 0 0)) `shouldBe` - [Event (Context []) Nothing (Arc 0 0) (3 :: Float)] + (queryArc (Sound.Tidal.UI.range 3 4 saw) (Arc 0 0)) + `shouldBe` [Event (Context []) Nothing (Arc 0 0) (3 :: Float)] it "at 1/4 of a cycle" $ - (queryArc (Sound.Tidal.UI.range 3 4 saw) (Arc 0.25 0.25)) `shouldBe` - [Event (Context []) Nothing (Arc 0.25 0.25) (3.25 :: Float)] + (queryArc (Sound.Tidal.UI.range 3 4 saw) (Arc 0.25 0.25)) + `shouldBe` [Event (Context []) Nothing (Arc 0.25 0.25) (3.25 :: Float)] it "at 3/4 of a cycle" $ - (queryArc (Sound.Tidal.UI.range 3 4 saw) (Arc 0.75 0.75)) `shouldBe` - [Event (Context []) Nothing (Arc 0.75 0.75) (3.75 :: Float)] + (queryArc (Sound.Tidal.UI.range 3 4 saw) (Arc 0.75 0.75)) + `shouldBe` [Event (Context []) Nothing (Arc 0.75 0.75) (3.75 :: Float)] describe "from -1 to 1" $ do it "at 1/2 of a cycle" $ - (queryArc (Sound.Tidal.UI.range (-1) 1 saw) (Arc 0.5 0.5)) `shouldBe` - [Event (Context []) Nothing (Arc 0.5 0.5) (0 :: Float)] + (queryArc (Sound.Tidal.UI.range (-1) 1 saw) (Arc 0.5 0.5)) + `shouldBe` [Event (Context []) Nothing (Arc 0.5 0.5) (0 :: Float)] describe "from 4 to 2" $ do it "at the start of a cycle" $ - (queryArc (Sound.Tidal.UI.range 4 2 saw) (Arc 0 0)) `shouldBe` - [Event (Context []) Nothing (Arc 0 0) (4 :: Float)] + (queryArc (Sound.Tidal.UI.range 4 2 saw) (Arc 0 0)) + `shouldBe` [Event (Context []) Nothing (Arc 0 0) (4 :: Float)] it "at 1/4 of a cycle" $ - (queryArc (Sound.Tidal.UI.range 4 2 saw) (Arc 0.25 0.25)) `shouldBe` - [Event (Context []) Nothing (Arc 0.25 0.25) (3.5 :: Float)] + (queryArc (Sound.Tidal.UI.range 4 2 saw) (Arc 0.25 0.25)) + `shouldBe` [Event (Context []) Nothing (Arc 0.25 0.25) (3.5 :: Float)] it "at 3/4 of a cycle" $ - (queryArc (Sound.Tidal.UI.range 4 2 saw) (Arc 0.75 0.75)) `shouldBe` - [Event (Context []) Nothing (Arc 0.75 0.75) (2.5 :: Float)] + (queryArc (Sound.Tidal.UI.range 4 2 saw) (Arc 0.75 0.75)) + `shouldBe` [Event (Context []) Nothing (Arc 0.75 0.75) (2.5 :: Float)] describe "from 10 to 10" $ do it "at 1/2 of a cycle" $ - (queryArc (Sound.Tidal.UI.range 10 10 saw) (Arc 0.5 0.5)) `shouldBe` - [Event (Context []) Nothing (Arc 0.5 0.5) (10 :: Float)] + (queryArc (Sound.Tidal.UI.range 10 10 saw) (Arc 0.5 0.5)) + `shouldBe` [Event (Context []) Nothing (Arc 0.5 0.5) (10 :: Float)] describe "rot" $ do it "rotates values in a pattern irrespective of structure" $ - property $ comparePD (Arc 0 2) - (rot 1 "a ~ b c" :: Pattern String) - ( "b ~ c a" :: Pattern String) + property $ + comparePD + (Arc 0 2) + (rot 1 "a ~ b c" :: Pattern String) + ("b ~ c a" :: Pattern String) it "works with negative values" $ - property $ comparePD (Arc 0 2) - (rot (-1) "a ~ b c" :: Pattern String) - ( "c ~ a b" :: Pattern String) + property $ + comparePD + (Arc 0 2) + (rot (-1) "a ~ b c" :: Pattern String) + ("c ~ a b" :: Pattern String) it "works with complex patterns" $ - property $ comparePD (Arc 0 2) - (rot (1) "a ~ [b [c ~ d]] [e ]" :: Pattern String) - ( "b ~ [c [d ~ e]] [ a]" :: Pattern String) + property $ + comparePD + (Arc 0 2) + (rot (1) "a ~ [b [c ~ d]] [e ]" :: Pattern String) + ("b ~ [c [d ~ e]] [ a]" :: Pattern String) describe "ply" $ do it "can ply chords" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (ply 3 "[0,1] [3,4,5] 6") ("[0,1]*3 [3,4,5]*3 6*3" :: Pattern Int) it "can pattern the ply factor" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (ply "3 4 5" "[0,1] [3,4,5] 6") ("[0,1]*3 [3,4,5]*4 6*5" :: Pattern Int) describe "press" $ do it "can syncopate a pattern" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (press "a b [c d] e") ("[~ a] [~ b] [[~ c] [~ d]] [~ e]" :: Pattern String) describe "pressBy" $ do it "can syncopate a pattern by a given amount" $ do - compareP (Arc 0 1) - (pressBy (1/3) "a b [~ c]") + compareP + (Arc 0 1) + (pressBy (1 / 3) "a b [~ c]") ("[~ a@2] [~ b@2] [~ [~ c@2]]" :: Pattern String) describe "fix" $ do it "can apply functions conditionally" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (fix (|+ n 1) (s "sn") (s "bd sn cp" # n 1)) (s "bd sn cp" # n "1 2 1") it "works with complex matches" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (fix (|+ n 2) (s "sn" # n 2) (s "bd sn*4 cp" # n "1 2")) (s "bd sn*4 cp" # n "1 [1 4] 2") it "leaves unmatched controls in place" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (fix (|+ n 2) (s "sn" # n 2) (s "bd sn*4 cp" # n "1 2" # speed (sine + 1))) (s "bd sn*4 cp" # n "1 [1 4] 2" # speed (sine + 1)) it "ignores silence" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (fix (|+ n 2) (silence) $ s "bd sn*4 cp" # n "1 2" # speed (sine + 1)) (s "bd sn*4 cp" # n "1 2" # speed (sine + 1)) it "treats polyphony as 'or'" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (fix (# crush 2) (n "[1,2]") $ s "bd sn" # n "1 2") (s "bd sn" # n "1 2" # crush 2) describe "unfix" $ do it "does the opposite of fix" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (unfix (|+ n 2) (s "sn" # n 2) (s "bd sn*4 cp" # n "1 2" # speed (sine + 1))) (s "bd sn*4 cp" # n "3 [3 2] 4" # speed (sine + 1)) describe "contrast" $ do it "does both fix and unfix" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (contrast (|+ n 2) (|+ n 10) (s "sn" # n 2) (s "bd sn*4 cp" # n "1 2" # speed (sine + 1))) (s "bd sn*4 cp" # n "11 [11 4] 12" # speed (sine + 1)) describe "contrastRange" $ do it "matches using a pattern of ranges" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (contrastRange (# crush 3) (# crush 0) (pure $ Map.singleton "n" $ (VN 0, VN 3)) $ s "bd" >| n "1 4") (s "bd" >| n "1 4" >| crush "3 0") describe "euclidFull" $ do it "can match against silence" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (euclidFull 3 8 "bd" silence) ("bd(3,8)" :: Pattern String) describe "snowball" $ do - let testPattern = ("1 2 3 4"::Pattern Int) + let testPattern = ("1 2 3 4" :: Pattern Int) it "acummulates a transform version of a pattern and appends the result - addition" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (snowball 3 (+) (slow 2) (testPattern)) - (cat [testPattern,(testPattern+(slow 2 testPattern)),((testPattern+(slow 2 testPattern))+slow 2 (testPattern+(slow 2 testPattern)))]) + (cat [testPattern, (testPattern + (slow 2 testPattern)), ((testPattern + (slow 2 testPattern)) + slow 2 (testPattern + (slow 2 testPattern)))]) describe "soak" $ do it "applies a transform and then appends the result -- addition" $ do - compareP (Arc 0 3) + compareP + (Arc 0 3) (soak 3 (+ 1) "4 ~ 0 1") - (cat ["4 ~ 0 1"::Pattern Int,"5 ~ 1 2"::Pattern Int,"6 ~ 2 3"::Pattern Int]) + (cat ["4 ~ 0 1" :: Pattern Int, "5 ~ 1 2" :: Pattern Int, "6 ~ 2 3" :: Pattern Int]) it "applies a transform and then appends the result -- slow" $ do - compareP (Arc 0 7) + compareP + (Arc 0 7) (soak 3 (slow 2) "4 ~ 0 1") - (cat ["4 ~ 0 1"::Pattern Int, slow 2 "4 ~ 0 1"::Pattern Int, slow 4 "4 ~ 0 1"::Pattern Int]) + (cat ["4 ~ 0 1" :: Pattern Int, slow 2 "4 ~ 0 1" :: Pattern Int, slow 4 "4 ~ 0 1" :: Pattern Int]) it "applies a transform and then appends the result -- addition patterns" $ do - compareP (Arc 0 3) + compareP + (Arc 0 3) (soak 3 (+ "1 2 3") "1 1") - (cat ["1 1"::Pattern Int,"2 [3 3] 4"::Pattern Int,"3 [5 5] 7"::Pattern Int]) + (cat ["1 1" :: Pattern Int, "2 [3 3] 4" :: Pattern Int, "3 [5 5] 7" :: Pattern Int]) describe "euclid" $ do it "matches examples in Toussaint's paper" $ do - sequence_ $ map (\(a,b) -> it b $ compareP (Arc 0 1) a (parseBP_E b)) - ([(euclid 1 2 "x", "x ~"), - (euclid 1 3 "x", "x ~ ~"), - (euclid 1 4 "x", "x ~ ~ ~"), - (euclid 4 12 "x", "x ~ ~ x ~ ~ x ~ ~ x ~ ~"), - (euclid 2 5 "x", "x ~ x ~ ~"), - -- (euclid 3 4 "x", "x ~ x x"), -- Toussaint is wrong.. - (euclid 3 4 "x", "x x x ~"), -- correction - (euclid 3 5 "x", "x ~ x ~ x"), - (euclid 3 7 "x", "x ~ x ~ x ~ ~"), - (euclid 3 8 "x", "x ~ ~ x ~ ~ x ~"), - (euclid 4 7 "x", "x ~ x ~ x ~ x"), - (euclid 4 9 "x", "x ~ x ~ x ~ x ~ ~"), - (euclid 4 11 "x", "x ~ ~ x ~ ~ x ~ ~ x ~"), - -- (euclid 5 6 "x", "x ~ x x x x"), -- Toussaint is wrong.. - (euclid 5 6 "x", "x x x x x ~"), -- correction - (euclid 5 7 "x", "x ~ x x ~ x x"), - (euclid 5 8 "x", "x ~ x x ~ x x ~"), - (euclid 5 9 "x", "x ~ x ~ x ~ x ~ x"), - (euclid 5 11 "x", "x ~ x ~ x ~ x ~ x ~ ~"), - (euclid 5 12 "x", "x ~ ~ x ~ x ~ ~ x ~ x ~"), - -- (euclid 5 16 "x", "x ~ ~ x ~ ~ x ~ ~ x ~ ~ x ~ ~ ~ ~"), -- Toussaint is wrong.. - (euclid 5 16 "x", "x ~ ~ x ~ ~ x ~ ~ x ~ ~ x ~ ~ ~"), -- correction - -- (euclid 7 8 "x", "x ~ x x x x x x"), -- Toussaint is wrong.. - (euclid 7 8 "x", "x x x x x x x ~"), -- Correction - (euclid 7 12 "x", "x ~ x x ~ x ~ x x ~ x ~"), - (euclid 7 16 "x", "x ~ ~ x ~ x ~ x ~ ~ x ~ x ~ x ~"), - (euclid 9 16 "x", "x ~ x x ~ x ~ x ~ x x ~ x ~ x ~"), - (euclid 11 24 "x", "x ~ ~ x ~ x ~ x ~ x ~ x ~ ~ x ~ x ~ x ~ x ~ x ~"), - (euclid 13 24 "x", "x ~ x x ~ x ~ x ~ x ~ x ~ x x ~ x ~ x ~ x ~ x ~") - ] :: [(Pattern String, String)]) + sequence_ $ + map + (\(a, b) -> it b $ compareP (Arc 0 1) a (parseBP_E b)) + ( [ (euclid 1 2 "x", "x ~"), + (euclid 1 3 "x", "x ~ ~"), + (euclid 1 4 "x", "x ~ ~ ~"), + (euclid 4 12 "x", "x ~ ~ x ~ ~ x ~ ~ x ~ ~"), + (euclid 2 5 "x", "x ~ x ~ ~"), + -- (euclid 3 4 "x", "x ~ x x"), -- Toussaint is wrong.. + (euclid 3 4 "x", "x x x ~"), -- correction + (euclid 3 5 "x", "x ~ x ~ x"), + (euclid 3 7 "x", "x ~ x ~ x ~ ~"), + (euclid 3 8 "x", "x ~ ~ x ~ ~ x ~"), + (euclid 4 7 "x", "x ~ x ~ x ~ x"), + (euclid 4 9 "x", "x ~ x ~ x ~ x ~ ~"), + (euclid 4 11 "x", "x ~ ~ x ~ ~ x ~ ~ x ~"), + -- (euclid 5 6 "x", "x ~ x x x x"), -- Toussaint is wrong.. + (euclid 5 6 "x", "x x x x x ~"), -- correction + (euclid 5 7 "x", "x ~ x x ~ x x"), + (euclid 5 8 "x", "x ~ x x ~ x x ~"), + (euclid 5 9 "x", "x ~ x ~ x ~ x ~ x"), + (euclid 5 11 "x", "x ~ x ~ x ~ x ~ x ~ ~"), + (euclid 5 12 "x", "x ~ ~ x ~ x ~ ~ x ~ x ~"), + -- (euclid 5 16 "x", "x ~ ~ x ~ ~ x ~ ~ x ~ ~ x ~ ~ ~ ~"), -- Toussaint is wrong.. + (euclid 5 16 "x", "x ~ ~ x ~ ~ x ~ ~ x ~ ~ x ~ ~ ~"), -- correction + -- (euclid 7 8 "x", "x ~ x x x x x x"), -- Toussaint is wrong.. + (euclid 7 8 "x", "x x x x x x x ~"), -- Correction + (euclid 7 12 "x", "x ~ x x ~ x ~ x x ~ x ~"), + (euclid 7 16 "x", "x ~ ~ x ~ x ~ x ~ ~ x ~ x ~ x ~"), + (euclid 9 16 "x", "x ~ x x ~ x ~ x ~ x x ~ x ~ x ~"), + (euclid 11 24 "x", "x ~ ~ x ~ x ~ x ~ x ~ x ~ ~ x ~ x ~ x ~ x ~ x ~"), + (euclid 13 24 "x", "x ~ x x ~ x ~ x ~ x ~ x ~ x x ~ x ~ x ~ x ~ x ~") + ] :: + [(Pattern String, String)] + ) it "can be called with a negative first value to give the inverse" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (euclid (-3) 8 ("bd" :: Pattern String)) (euclidInv 3 8 ("bd" :: Pattern String)) it "can be called with a negative first value to give the inverse (patternable)" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (euclid (-3) 8 ("bd" :: Pattern String)) ("bd(-3,8)" :: Pattern String) - describe "wedge" $ do it "should not freeze tidal amount is 1" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (wedge (1) (s "ho ho:2 ho:3 hc") (rev $ s "ho ho:2 ho:3 hc")) (s "ho ho:2 ho:3 hc") it "should not freeze tidal amount is 0" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (wedge (0) (s "ho ho:2 ho:3 hc") (rev $ s "ho ho:2 ho:3 hc")) (rev $ s "ho ho:2 ho:3 hc") describe "bite" $ do it "can slice a pattern into bits" $ do - compareP (Arc 0 4) + compareP + (Arc 0 4) (bite 4 "0 2*2" (Sound.Tidal.Core.run 8)) ("[0 1] [4 5]*2" :: Pattern Int) it "can slice a pattern into patternable bits number" $ do - compareP (Arc 0 4) + compareP + (Arc 0 4) (bite "8 4" "0 2*2" (Sound.Tidal.Core.run 8)) ("[0] [4 5]*2" :: Pattern Int) describe "chooseBy" $ do it "chooses from elements based on closest scaled double value" $ do - compareP (Arc 0 4) - (("0"::Pattern Int) |+ chooseBy ((/ 4)$(sig fromRational)) [0,1,2,3]) - ("<0 1 2 3>"::Pattern Int) + compareP + (Arc 0 4) + (("0" :: Pattern Int) |+ chooseBy ((/ 4) $ (sig fromRational)) [0, 1, 2, 3]) + ("<0 1 2 3>" :: Pattern Int) it "never gets an index out of bounds" $ do - compareP (Arc 0 4) - ("0" |+ chooseBy (sig fromRational) [0,1,2,3]) - ("2"::Pattern Int) + compareP + (Arc 0 4) + ("0" |+ chooseBy (sig fromRational) [0, 1, 2, 3]) + ("2" :: Pattern Int) describe "arpeggiate" $ do it "can arpeggiate" $ do - compareP (Arc 0 1) - (arpeggiate ("[bd, sn] [hh:1, cp]" :: Pattern String)) - ("bd sn hh:1 cp" :: Pattern String) + compareP + (Arc 0 1) + (arpeggiate ("[bd, sn] [hh:1, cp]" :: Pattern String)) + ("bd sn hh:1 cp" :: Pattern String) it "can arpeggiate" $ do - compareP (Arc 0 4) + compareP + (Arc 0 4) (arpeggiate $ "[0,0] [0,0]") ("0 0 0 0" :: Pattern Int) it "can arpeggiate a 'sped up' pattern" $ do - compareP (Arc 0 4) + compareP + (Arc 0 4) (arpeggiate $ "[0,0]*2") ("0 0 0 0" :: Pattern Int) describe "chunk" $ do it "can chunk a rev pattern" $ do - compareP (Arc 0 4) - (chunk 2 (rev) $ ("a b c d" :: Pattern String)) + compareP + (Arc 0 4) + (chunk 2 (rev) $ ("a b c d" :: Pattern String)) (slow 2 $ "d c c d a b b a" :: Pattern String) it "can chunk a fast pattern" $ do - compareP (Arc 0 4) + compareP + (Arc 0 4) (chunk 2 (fast 2) $ "a b" :: Pattern String) (slow 2 $ "a b b _ a _ a b" :: Pattern String) it "should chunk backward with a negative number" $ do - compareP (Arc 0 4) + compareP + (Arc 0 4) (chunk (-2) (rev) $ ("a b c d" :: Pattern String)) (slow 2 $ "a b b a d c c d" :: Pattern String) describe "binary" $ do it "converts a number to a pattern of boolean" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (binary "128") ("t f f f f f f f" :: Pattern Bool) describe "binaryN" $ do it "converts a number to a pattern of boolean of specified length" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (binaryN 4 "8") ("t f f f" :: Pattern Bool) it "converts a number to a pattern of boolean of specified patternable length" $ do - compareP (Arc 0 2) + compareP + (Arc 0 2) (binaryN "<4 8>" "8") (cat ["t f f f", "f f f f t f f f"] :: Pattern Bool) describe "off" $ do it "superimposes and shifts pattern" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (off "-e" id $ s "0") (superimpose ("e" <~) $ s "0") describe "loopFirst" $ do it "plays the first cycle" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (loopFirst $ rotL 3 $ slow 8 $ "0 .. 7" :: Pattern Int) ("3") describe "loopCycles" $ do it "plays the first n cycles" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (loopFirst $ rotL 3 $ slow 8 $ "0 .. 7" :: Pattern Int) ("3") describe "timeLoop" $ do it "can loop time" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) ((3 <~) $ (timeLoop 3 $ sound "")) (sound "a") describe "timeLoop" $ do it "can pattern time" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) ((1 <~) $ timeLoop "<2 1>" $ sound "b") (sound "b") describe "necklace" $ do it "can specify rhythm by IOI" $ do - compareP (Arc 0 1) - (necklace 12 [4,2]) + compareP + (Arc 0 1) + (necklace 12 [4, 2]) ("t f f f t f t f f f t f") describe "quantise" $ do it "can quantise notes" $ do - compareP (Arc 0 1) + compareP + (Arc 0 1) (segment 2 $ quantise 1 $ sine :: Pattern Note) ("1 0" :: Pattern Note) diff --git a/test/Sound/Tidal/UtilsTest.hs b/test/Sound/Tidal/UtilsTest.hs index a73821fc..acca534d 100644 --- a/test/Sound/Tidal/UtilsTest.hs +++ b/test/Sound/Tidal/UtilsTest.hs @@ -2,55 +2,53 @@ module Sound.Tidal.UtilsTest where -import Test.Microspec - -import Prelude hiding ((<*), (*>)) - import Sound.Tidal.Utils +import Test.Microspec +import Prelude hiding ((*>), (<*)) run :: Microspec () run = describe "Sound.Tidal.Utils" $ do describe "delta" $ do it "subtracts the second element of a tuple from the first" $ do - property $ delta (3,10) === (7 :: Int) - + property $ delta (3, 10) === (7 :: Int) + describe "applies function to both elements of tuple" $ do - let res = mapBoth (+1) (2,5) - property $ ((3,6) :: (Int, Int)) === res + let res = mapBoth (+ 1) (2, 5) + property $ ((3, 6) :: (Int, Int)) === res describe "apply function to first element of tuple" $ do - let res = mapFst (+1) (2, 5) - property $ ((3, 5) :: (Int, Int)) === res + let res = mapFst (+ 1) (2, 5) + property $ ((3, 5) :: (Int, Int)) === res describe "apply function to second element of tuple" $ do - let res = mapSnd (+1) (2, 5) - property $ ((2, 6) :: (Int, Int)) === res - + let res = mapSnd (+ 1) (2, 5) + property $ ((2, 6) :: (Int, Int)) === res + describe "return midpoint between first and second tuple value" $ do - let res = mid (2, 5) - property $ (3.5 :: Double) === res + let res = mid (2, 5) + property $ (3.5 :: Double) === res describe "return of two lists, with unique values to each list" $ do - let res = removeCommon [1,2,5,7,12,16] [2,3,4,5,15,16] - property $ (([1,7,12],[3,4,15]) :: ([Int], [Int])) === res + let res = removeCommon [1, 2, 5, 7, 12, 16] [2, 3, 4, 5, 15, 16] + property $ (([1, 7, 12], [3, 4, 15]) :: ([Int], [Int])) === res describe "wrap around indexing" $ do - let res = (!!!) [1..5] 7 - property $ (3 :: Int) === res + let res = (!!!) [1 .. 5] 7 + property $ (3 :: Int) === res - describe "safe list indexing" $ do - let res = nth 2 ([] :: [Int]) - property $ Nothing === res + describe "safe list indexing" $ do + let res = nth 2 ([] :: [Int]) + property $ Nothing === res describe "list accumulation with given list elements" $ do - let res = accumulate ([1..5] :: [Int]) - property $ [1,3,6,10,15] === res + let res = accumulate ([1 .. 5] :: [Int]) + property $ [1, 3, 6, 10, 15] === res describe "index elements in list" $ do - let res = enumerate ['a', 'b', 'c'] - property $ [(0,'a'),(1,'b'),(2,'c')] === res + let res = enumerate ['a', 'b', 'c'] + property $ [(0, 'a'), (1, 'b'), (2, 'c')] === res - describe "split list by given pred" $ do - let res = wordsBy (== ':') "bd:3" - property $ ["bd", "3"] === res + describe "split list by given pred" $ do + let res = wordsBy (== ':') "bd:3" + property $ ["bd", "3"] === res diff --git a/tidal-link/src/hs/Sound/Tidal/Clock.hs b/tidal-link/src/hs/Sound/Tidal/Clock.hs index cfb153fb..50704753 100644 --- a/tidal-link/src/hs/Sound/Tidal/Clock.hs +++ b/tidal-link/src/hs/Sound/Tidal/Clock.hs @@ -1,64 +1,59 @@ module Sound.Tidal.Clock where -import qualified Sound.Tidal.Link as Link +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVar, readTVar, retry, swapTVar) +import Control.Monad (when) +import Control.Monad.Reader (ReaderT, ask, runReaderT) +import Control.Monad.State (StateT, evalStateT, get, liftIO, modify, put) +import Data.Coerce (coerce) +import Data.Int (Int64) +import Foreign.C.Types (CDouble (..)) import qualified Sound.Osc.Fd as O - -import Control.Concurrent (forkIO, threadDelay) -import Control.Concurrent.STM (TVar, atomically, readTVar, newTVar, modifyTVar', swapTVar, retry) -import Control.Monad (when) -import Control.Monad.Reader (ReaderT, runReaderT, ask) -import Control.Monad.State (StateT, liftIO, evalStateT, get, put, modify) - -import Foreign.C.Types (CDouble (..)) -import Data.Int (Int64) -import Data.Coerce (coerce) -import System.IO (hPutStrLn, stderr) +import qualified Sound.Tidal.Link as Link +import System.IO (hPutStrLn, stderr) type Time = Rational -- | representation of a tick based clock -type Clock - = ReaderT ClockMemory (StateT ClockState IO) +type Clock = + ReaderT ClockMemory (StateT ClockState IO) -- | internal read-only memory of the clock -data ClockMemory - = ClockMemory - {clockConfig :: ClockConfig - ,clockRef :: ClockRef - ,clockAction :: TickAction +data ClockMemory = ClockMemory + { clockConfig :: ClockConfig, + clockRef :: ClockRef, + clockAction :: TickAction } -- | internal mutable state of the clock -data ClockState - = ClockState - {ticks :: Int64 - ,start :: Link.Micros - ,nowArc :: (Time, Time) - ,nudged :: Double - } deriving Show +data ClockState = ClockState + { ticks :: Int64, + start :: Link.Micros, + nowArc :: (Time, Time), + nudged :: Double + } + deriving (Show) -- | reference to interact with the clock, while it is running -data ClockRef - = ClockRef - {rAction :: TVar ClockAction - ,rAbletonLink :: Link.AbletonLink +data ClockRef = ClockRef + { rAction :: TVar ClockAction, + rAbletonLink :: Link.AbletonLink } -- | configuration of the clock -data ClockConfig - = ClockConfig - {cQuantum :: CDouble - ,cBeatsPerCycle :: CDouble - ,cFrameTimespan :: Double - ,cEnableLink :: Bool - ,cSkipTicks :: Int64 - ,cProcessAhead :: Double +data ClockConfig = ClockConfig + { cQuantum :: CDouble, + cBeatsPerCycle :: CDouble, + cFrameTimespan :: Double, + cEnableLink :: Bool, + cSkipTicks :: Int64, + cProcessAhead :: Double } -- | action to be executed on a tick, -- | given the current timespan, nudge and reference to the clock -type TickAction - = (Time,Time) -> Double -> ClockConfig -> ClockRef -> (Link.SessionState, Link.SessionState) -> IO () +type TickAction = + (Time, Time) -> Double -> ClockConfig -> ClockRef -> (Link.SessionState, Link.SessionState) -> IO () -- | possible actions for interacting with the clock data ClockAction @@ -71,14 +66,15 @@ defaultCps :: Double defaultCps = 0.575 defaultConfig :: ClockConfig -defaultConfig = ClockConfig - {cFrameTimespan = 1/20 - ,cEnableLink = False - ,cProcessAhead = 3/10 - ,cSkipTicks = 10 - ,cQuantum = 4 - ,cBeatsPerCycle = 4 - } +defaultConfig = + ClockConfig + { cFrameTimespan = 1 / 20, + cEnableLink = False, + cProcessAhead = 3 / 10, + cSkipTicks = 10, + cQuantum = 4, + cBeatsPerCycle = 4 + } -- | creates a clock according to the config and runs it -- | in a seperate thread @@ -89,31 +85,33 @@ clocked config ac = runClock config ac clockCheck -- | by initClock, hands the ClockRef for interaction from outside runClock :: ClockConfig -> TickAction -> Clock () -> IO ClockRef runClock config ac clock = do - (mem, st) <- initClock config ac - _ <- forkIO $ evalStateT (runReaderT clock mem) st - return (clockRef mem) + (mem, st) <- initClock config ac + _ <- forkIO $ evalStateT (runReaderT clock mem) st + return (clockRef mem) -- | creates a ableton link instance and an MVar for interacting -- | with the clock from outside and computes the initial clock state initClock :: ClockConfig -> TickAction -> IO (ClockMemory, ClockState) initClock config ac = do - abletonLink <- Link.create bpm - when (cEnableLink config) $ Link.enable abletonLink - sessionState <- Link.createAndCaptureAppSessionState abletonLink - now <- Link.clock abletonLink - let startAt = now + processAhead - Link.requestBeatAtTime sessionState 0 startAt (cQuantum config) - Link.commitAndDestroyAppSessionState abletonLink sessionState - clockMV <- atomically $ newTVar NoAction - let st = ClockState {ticks = 0, - start = now, - nowArc = (0,0), - nudged = 0 - } - return (ClockMemory config (ClockRef clockMV abletonLink) ac, st) - where processAhead = round $ (cProcessAhead config) * 1000000 - bpm = (coerce defaultCps) * 60 * (cBeatsPerCycle config) - + abletonLink <- Link.create bpm + when (cEnableLink config) $ Link.enable abletonLink + sessionState <- Link.createAndCaptureAppSessionState abletonLink + now <- Link.clock abletonLink + let startAt = now + processAhead + Link.requestBeatAtTime sessionState 0 startAt (cQuantum config) + Link.commitAndDestroyAppSessionState abletonLink sessionState + clockMV <- atomically $ newTVar NoAction + let st = + ClockState + { ticks = 0, + start = now, + nowArc = (0, 0), + nudged = 0 + } + return (ClockMemory config (ClockRef clockMV abletonLink) ac, st) + where + processAhead = round $ (cProcessAhead config) * 1000000 + bpm = (coerce defaultCps) * 60 * (cBeatsPerCycle config) -- The reference time Link uses, -- is the time the audio for a certain beat hits the speaker. @@ -125,23 +123,23 @@ initClock config ac = do -- previously called checkArc clockCheck :: Clock () clockCheck = do - (ClockMemory config (ClockRef clockMV abletonLink) _) <- ask + (ClockMemory config (ClockRef clockMV abletonLink) _) <- ask - action <- liftIO $ atomically $ swapTVar clockMV NoAction - processAction action + action <- liftIO $ atomically $ swapTVar clockMV NoAction + processAction action - st <- get + st <- get - let logicalEnd = logicalTime config (start st) $ ticks st + 1 - nextArcStartCycle = arcEnd $ nowArc st + let logicalEnd = logicalTime config (start st) $ ticks st + 1 + nextArcStartCycle = arcEnd $ nowArc st - ss <- liftIO $ Link.createAndCaptureAppSessionState abletonLink - arcStartTime <- liftIO $ cyclesToTime config ss nextArcStartCycle - liftIO $ Link.destroySessionState ss + ss <- liftIO $ Link.createAndCaptureAppSessionState abletonLink + arcStartTime <- liftIO $ cyclesToTime config ss nextArcStartCycle + liftIO $ Link.destroySessionState ss - if (arcStartTime < logicalEnd) - then clockProcess - else tick + if (arcStartTime < logicalEnd) + then clockProcess + else tick -- tick moves the logical time forward or recalculates the ticks in case -- the logical time is out of sync with Link time. @@ -157,9 +155,10 @@ tick = do logicalNow = logicalTime config (start st) preferredNewTick aheadOfNow = now + processAhead actualTick = (aheadOfNow - start st) `div` frameTimespan - drifted = abs (actualTick - preferredNewTick) > (cSkipTicks config) - newTick | drifted = actualTick - | otherwise = preferredNewTick + drifted = abs (actualTick - preferredNewTick) > (cSkipTicks config) + newTick + | drifted = actualTick + | otherwise = preferredNewTick delta = min frameTimespan (logicalNow - aheadOfNow) put $ st {ticks = newTick} @@ -174,42 +173,42 @@ tick = do -- hands the current link operations to the TickAction clockProcess :: Clock () clockProcess = do - (ClockMemory config ref@(ClockRef _ abletonLink) action) <- ask - st <- get - let logicalEnd = logicalTime config (start st) $ ticks st + 1 - startCycle = arcEnd $ nowArc st + (ClockMemory config ref@(ClockRef _ abletonLink) action) <- ask + st <- get + let logicalEnd = logicalTime config (start st) $ ticks st + 1 + startCycle = arcEnd $ nowArc st - sessionState <- liftIO $ Link.createAndCaptureAppSessionState abletonLink - endCycle <- liftIO $ timeToCycles config sessionState logicalEnd + sessionState <- liftIO $ Link.createAndCaptureAppSessionState abletonLink + endCycle <- liftIO $ timeToCycles config sessionState logicalEnd - liftIO $ action (startCycle,endCycle) (nudged st) config ref (sessionState, sessionState) + liftIO $ action (startCycle, endCycle) (nudged st) config ref (sessionState, sessionState) - liftIO $ Link.commitAndDestroyAppSessionState abletonLink sessionState + liftIO $ Link.commitAndDestroyAppSessionState abletonLink sessionState - put (st {nowArc = (startCycle,endCycle)}) - tick + put (st {nowArc = (startCycle, endCycle)}) + tick processAction :: ClockAction -> Clock () processAction NoAction = return () -processAction (SetNudge n) = modify (\st -> st {nudged = n}) +processAction (SetNudge n) = modify (\st -> st {nudged = n}) processAction (SetTempo bpm) = do - (ClockMemory _ (ClockRef _ abletonLink) _) <- ask - sessionState <- liftIO $ Link.createAndCaptureAppSessionState abletonLink - now <- liftIO $ Link.clock abletonLink - liftIO $ Link.setTempo sessionState (fromRational bpm) now - liftIO $ Link.commitAndDestroyAppSessionState abletonLink sessionState + (ClockMemory _ (ClockRef _ abletonLink) _) <- ask + sessionState <- liftIO $ Link.createAndCaptureAppSessionState abletonLink + now <- liftIO $ Link.clock abletonLink + liftIO $ Link.setTempo sessionState (fromRational bpm) now + liftIO $ Link.commitAndDestroyAppSessionState abletonLink sessionState processAction (SetCycle cyc) = do - (ClockMemory config (ClockRef _ abletonLink) _) <- ask - sessionState <- liftIO $ Link.createAndCaptureAppSessionState abletonLink + (ClockMemory config (ClockRef _ abletonLink) _) <- ask + sessionState <- liftIO $ Link.createAndCaptureAppSessionState abletonLink - now <- liftIO $ Link.clock abletonLink - let processAhead = round $ (cProcessAhead config) * 1000000 - startAt = now + processAhead - beat = (fromRational cyc) * (cBeatsPerCycle config) - liftIO $ Link.requestBeatAtTime sessionState beat startAt (cQuantum config) - liftIO $ Link.commitAndDestroyAppSessionState abletonLink sessionState + now <- liftIO $ Link.clock abletonLink + let processAhead = round $ (cProcessAhead config) * 1000000 + startAt = now + processAhead + beat = (fromRational cyc) * (cBeatsPerCycle config) + liftIO $ Link.requestBeatAtTime sessionState beat startAt (cQuantum config) + liftIO $ Link.commitAndDestroyAppSessionState abletonLink sessionState - modify (\st -> st {ticks = 0, start = now, nowArc = (cyc,cyc)}) + modify (\st -> st {ticks = 0, start = now, nowArc = (cyc, cyc)}) --------------------------------------------------------------- ----------- functions representing link operations ------------ @@ -235,11 +234,12 @@ getSessionState (ClockRef _ abletonLink) = Link.createAndCaptureAppSessionState -- But using forceBeatAtTime means we can not commit its session state. getZeroedSessionState :: ClockConfig -> ClockRef -> IO Link.SessionState getZeroedSessionState config (ClockRef _ abletonLink) = do - ss <- Link.createAndCaptureAppSessionState abletonLink - nowLink <- liftIO $ Link.clock abletonLink - Link.forceBeatAtTime ss 0 (nowLink + processAhead) (cQuantum config) - return ss - where processAhead = round $ (cProcessAhead config) * 1000000 + ss <- Link.createAndCaptureAppSessionState abletonLink + nowLink <- liftIO $ Link.clock abletonLink + Link.forceBeatAtTime ss 0 (nowLink + processAhead) (cQuantum config) + return ss + where + processAhead = round $ (cProcessAhead config) * 1000000 getTempo :: Link.SessionState -> IO Time getTempo ss = fmap toRational $ Link.getTempo ss @@ -247,7 +247,7 @@ getTempo ss = fmap toRational $ Link.getTempo ss setTempoCPS :: Time -> Link.Micros -> ClockConfig -> Link.SessionState -> IO () setTempoCPS cps now conf ss = Link.setTempo ss (coerce $ cyclesToBeat conf ((fromRational cps) * 60)) now -timeAtBeat :: ClockConfig -> Link.SessionState -> Double -> IO Link.Micros +timeAtBeat :: ClockConfig -> Link.SessionState -> Double -> IO Link.Micros timeAtBeat config ss beat = Link.timeAtBeat ss (coerce beat) (cQuantum config) timeToCycles :: ClockConfig -> Link.SessionState -> Link.Micros -> IO Time @@ -263,9 +263,9 @@ cyclesToTime config ss cyc = do linkToOscTime :: ClockRef -> Link.Micros -> IO O.Time linkToOscTime (ClockRef _ abletonLink) lt = do - nowOsc <- O.time - nowLink <- liftIO $ Link.clock abletonLink - return $ addMicrosToOsc (lt - nowLink) nowOsc + nowOsc <- O.time + nowLink <- liftIO $ Link.clock abletonLink + return $ addMicrosToOsc (lt - nowLink) nowOsc addMicrosToOsc :: Link.Micros -> O.Time -> O.Time addMicrosToOsc m t = ((fromIntegral m) / 1000000) + t @@ -275,7 +275,8 @@ addMicrosToOsc m t = ((fromIntegral m) / 1000000) + t -- processing first started. logicalTime :: ClockConfig -> Link.Micros -> Int64 -> Link.Micros logicalTime config startTime ticks' = startTime + ticks' * frameTimespan - where frameTimespan = round $ (cFrameTimespan config) * 1000000 + where + frameTimespan = round $ (cFrameTimespan config) * 1000000 --------------------------------------------------------------- ----------- functions for interacting with the clock ---------- @@ -283,49 +284,50 @@ logicalTime config startTime ticks' = startTime + ticks' * frameTimespan getBPM :: ClockRef -> IO Time getBPM (ClockRef _ abletonLink) = do - ss <- Link.createAndCaptureAppSessionState abletonLink - bpm <- Link.getTempo ss - Link.destroySessionState ss - return $! toRational bpm + ss <- Link.createAndCaptureAppSessionState abletonLink + bpm <- Link.getTempo ss + Link.destroySessionState ss + return $! toRational bpm getCPS :: ClockConfig -> ClockRef -> IO Time getCPS config ref = fmap (\bpm -> bpm / (toRational $ cBeatsPerCycle config) / 60) (getBPM ref) getCycleTime :: ClockConfig -> ClockRef -> IO Time getCycleTime config (ClockRef _ abletonLink) = do - now <- Link.clock abletonLink - ss <- Link.createAndCaptureAppSessionState abletonLink - c <- timeToCycles config ss now - Link.destroySessionState ss - return $! c + now <- Link.clock abletonLink + ss <- Link.createAndCaptureAppSessionState abletonLink + c <- timeToCycles config ss now + Link.destroySessionState ss + return $! c resetClock :: ClockRef -> IO () resetClock clock = setClock clock 0 setClock :: ClockRef -> Time -> IO () setClock (ClockRef clock _) t = atomically $ do - action <- readTVar clock - case action of - NoAction -> modifyTVar' clock (const $ SetCycle t) - _ -> retry + action <- readTVar clock + case action of + NoAction -> modifyTVar' clock (const $ SetCycle t) + _ -> retry setBPM :: ClockRef -> Time -> IO () setBPM (ClockRef clock _) t = atomically $ do - action <- readTVar clock - case action of - NoAction -> modifyTVar' clock (const $ SetTempo t) - _ -> retry + action <- readTVar clock + case action of + NoAction -> modifyTVar' clock (const $ SetTempo t) + _ -> retry setCPS :: ClockConfig -> ClockRef -> Time -> IO () setCPS config ref cps = setBPM ref bpm - where bpm = cps * 60 * (toRational $ cBeatsPerCycle config) + where + bpm = cps * 60 * (toRational $ cBeatsPerCycle config) setNudge :: ClockRef -> Double -> IO () setNudge (ClockRef clock _) n = atomically $ do - action <- readTVar clock - case action of - NoAction -> modifyTVar' clock (const $ SetNudge n) - _ -> retry + action <- readTVar clock + case action of + NoAction -> modifyTVar' clock (const $ SetNudge n) + _ -> retry -- Used for Tempo callback -- Tempo changes will be applied. @@ -334,12 +336,12 @@ setNudge (ClockRef clock _) n = atomically $ do -- in the normal stream (the one handled by onTick). clockOnce :: TickAction -> ClockConfig -> ClockRef -> IO () clockOnce action config ref@(ClockRef _ abletonLink) = do - ss <- getZeroedSessionState config ref - temposs <- Link.createAndCaptureAppSessionState abletonLink - -- The nowArc is a full cycle - action (0,1) 0 config ref (ss, temposs) - Link.destroySessionState ss - Link.commitAndDestroyAppSessionState abletonLink temposs + ss <- getZeroedSessionState config ref + temposs <- Link.createAndCaptureAppSessionState abletonLink + -- The nowArc is a full cycle + action (0, 1) 0 config ref (ss, temposs) + Link.destroySessionState ss + Link.commitAndDestroyAppSessionState abletonLink temposs disableLink :: ClockRef -> IO () disableLink (ClockRef _ abletonLink) = Link.disable abletonLink diff --git a/tidal-parse/src/Sound/Tidal/Parse.hs b/tidal-parse/src/Sound/Tidal/Parse.hs index 72468687..81911bb6 100644 --- a/tidal-parse/src/Sound/Tidal/Parse.hs +++ b/tidal-parse/src/Sound/Tidal/Parse.hs @@ -1,24 +1,28 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} module Sound.Tidal.Parse (parseTidal) where -import Control.Applicative -import Control.Monad.Except -import Data.Bifunctor -import Data.Char -import Data.List (dropWhileEnd) +import Control.Applicative +import Control.Monad.Except +import Data.Bifunctor +import Data.Char +import Data.List (dropWhileEnd) import qualified Data.Text -import Language.Haskellish as Haskellish - -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 +import Language.Haskellish as Haskellish +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 () @@ -29,11 +33,10 @@ parseTidal x = if x' == [] then (return T.silence) else r x' = dropWhileEnd isSpace $ dropWhile isSpace $ Haskellish.removeComments x r = bimap showSyntaxError fst $ Haskellish.parseAndRun parser () x -showSyntaxError :: (Span,Data.Text.Text) -> String -showSyntaxError (((lineNumber,columnNumber),(_,_)),msg) = +showSyntaxError :: (Span, Data.Text.Text) -> String +showSyntaxError (((lineNumber, columnNumber), (_, _)), msg) = show lineNumber ++ ":" ++ show columnNumber ++ " " ++ Data.Text.unpack msg - -- The class Parse is a class for all of the types that we know how to parse. -- For each type, we provide all the ways we can think of producing that type -- via expressions in Parse. @@ -61,23 +64,27 @@ instance Parse T.Note where instance Parse String where parser = - string <|> - (parser :: H (String -> String)) <*!> parser - "expected String" + string + <|> (parser :: H (String -> String)) <*!> parser + "expected String" -instance (Parse a, Parse b) => Parse (a,b) where +instance (Parse a, Parse b) => Parse (a, b) where parser = Haskellish.tuple parser parser - -- Parse instances for lists of things -- for Num types we define the common pathway numList that includes chords -- then for other types we default to just parsing "literal" lists [a,a,...] instance Parse [Int] where parser = numList + instance Parse [Integer] where parser = numList + instance Parse [Time] where parser = numList + instance Parse [Double] where parser = numList + instance Parse [T.Note] where parser = numList + instance {-# OVERLAPPABLE #-} Parse a => Parse [a] where parser = list parser numList :: (Parse a, Num a) => H [a] @@ -85,41 +92,85 @@ numList = list parser <|> chords chords :: Num a => H [a] chords = - $(fromTidalList ["major","aug","six","sixNine","major7","major9","add9","major11", - "add11","major13","add13","dom7","dom9","dom11","dom13","sevenFlat5","sevenSharp5", - "sevenFlat9","nine","eleven","thirteen","minor","diminished","minorSharp5","minor6", - "minorSixNine","minor7flat5","minor7","minor7sharp5","minor7flat9","minor7sharp9", - "diminished7","minor9","minor11","minor13","one","five","sus2","sus4","sevenSus2", - "sevenSus4","nineSus4","sevenFlat10","nineSharp5","minor9sharp5","sevenSharp5flat9", - "minor7sharp5flat9","elevenSharp","minor11sharp"]) - + $( fromTidalList + [ "major", + "aug", + "six", + "sixNine", + "major7", + "major9", + "add9", + "major11", + "add11", + "major13", + "add13", + "dom7", + "dom9", + "dom11", + "dom13", + "sevenFlat5", + "sevenSharp5", + "sevenFlat9", + "nine", + "eleven", + "thirteen", + "minor", + "diminished", + "minorSharp5", + "minor6", + "minorSixNine", + "minor7flat5", + "minor7", + "minor7sharp5", + "minor7flat9", + "minor7sharp9", + "diminished7", + "minor9", + "minor11", + "minor13", + "one", + "five", + "sus2", + "sus4", + "sevenSus2", + "sevenSus4", + "nineSus4", + "sevenFlat10", + "nineSharp5", + "minor9sharp5", + "sevenSharp5flat9", + "minor7sharp5flat9", + "elevenSharp", + "minor11sharp" + ] + ) instance Parse ValueMap where parser = empty instance Parse ControlPattern where parser = - (parser :: H (Pattern String -> ControlPattern)) <*!> parser <|> - (parser :: H (Pattern Double -> ControlPattern)) <*!> parser <|> - (parser :: H (Pattern T.Note -> ControlPattern)) <*!> parser <|> - (parser :: H (Pattern Int -> ControlPattern)) <*!> parser <|> - listCp_cp <*!> parser <|> - genericPatternExpressions - "expected ControlPattern" - -genericPatternExpressions :: forall a. (Parse a, Parse (Pattern a),Parse (Pattern a -> Pattern a),Parse [a]) => H (Pattern a) + (parser :: H (Pattern String -> ControlPattern)) <*!> parser + <|> (parser :: H (Pattern Double -> ControlPattern)) <*!> parser + <|> (parser :: H (Pattern T.Note -> ControlPattern)) <*!> parser + <|> (parser :: H (Pattern Int -> ControlPattern)) <*!> parser + <|> listCp_cp <*!> parser + <|> genericPatternExpressions + "expected ControlPattern" + +genericPatternExpressions :: forall a. (Parse a, Parse (Pattern a), Parse (Pattern a -> Pattern a), Parse [a]) => H (Pattern a) genericPatternExpressions = - (parser :: H (Pattern a -> Pattern a)) <*!> parser <|> - (parser :: H ([a] -> Pattern a)) <*!> parser <|> - (parser :: H ([Pattern a] -> Pattern a)) <*!> parser <|> - (parser :: H ([(Pattern a, Double)] -> Pattern a)) <*!> parser <|> - (parser :: H ([Pattern a -> Pattern a] -> Pattern a)) <*!> parser <|> - (parser :: H ([(Time, Pattern a)] -> Pattern a)) <*!> parser <|> - pInt_p <*!> parser <|> - list_p <*!> parser <|> - tupleADouble_p <*!> parser <|> - listTupleStringTransformation_p <*!> parser <|> - silence + (parser :: H (Pattern a -> Pattern a)) <*!> parser + <|> (parser :: H ([a] -> Pattern a)) <*!> parser + <|> (parser :: H ([Pattern a] -> Pattern a)) <*!> parser + <|> (parser :: H ([(Pattern a, Double)] -> Pattern a)) <*!> parser + <|> (parser :: H ([Pattern a -> Pattern a] -> Pattern a)) <*!> parser + <|> (parser :: H ([(Time, Pattern a)] -> Pattern a)) <*!> parser + <|> pInt_p <*!> parser + <|> list_p <*!> parser + <|> tupleADouble_p <*!> parser + <|> listTupleStringTransformation_p <*!> parser + <|> silence listTupleStringTransformation_p :: forall a. (Parse (Pattern a), Parse (Pattern a -> Pattern a)) => H ([(String, Pattern a -> Pattern a)] -> Pattern a) listTupleStringTransformation_p = listTupleStringPattern_listTupleStringTransformation_p <*!> parser @@ -133,107 +184,107 @@ pString_listTupleStringPattern_listTupleStringTransformation_p = time_pString_li time_pString_listTupleStringPattern_listTupleStringTransformation_p :: H (Time -> Pattern String -> [(String, Pattern a)] -> [(String, Pattern a -> Pattern a)] -> Pattern a) time_pString_listTupleStringPattern_listTupleStringTransformation_p = $(fromTidal "ur") -numPatternExpressions :: (Num a,Parse a,Parse [a]) => H (Pattern a) +numPatternExpressions :: (Num a, Parse a, Parse [a]) => H (Pattern a) numPatternExpressions = - $(fromTidal "irand") <*!> parser <|> - pInt_pNumA <*!> parser + $(fromTidal "irand") <*!> parser + <|> pInt_pNumA <*!> parser fractionalPatternExpressions :: Fractional a => H (Pattern a) fractionalPatternExpressions = - $(fromTidal "rand") <|> - $(fromTidal "perlin") <|> - pInt_pFractionalA <*!> parser <|> - pDouble_pFractionalA <*!> parser + $(fromTidal "rand") + <|> $(fromTidal "perlin") + <|> pInt_pFractionalA <*!> parser + <|> pDouble_pFractionalA <*!> parser silence :: H (Pattern a) silence = $(fromTidal "silence") -- ie. T.silence <$ reserved "silence", see Sound.Tidal.Parse.TH instance Parse (Pattern Bool) where parser = - parseBP <|> - (parser :: H (Pattern String -> Pattern Bool)) <*!> parser <|> - (parser :: H (Pattern Int -> Pattern Bool)) <*!> parser <|> - genericPatternExpressions - "expected Pattern Bool" + parseBP + <|> (parser :: H (Pattern String -> Pattern Bool)) <*!> parser + <|> (parser :: H (Pattern Int -> Pattern Bool)) <*!> parser + <|> genericPatternExpressions + "expected Pattern Bool" instance Parse (Pattern String) where parser = - parseBP <|> - genericPatternExpressions <|> - (parser :: H (Pattern Int -> Pattern String)) <*!> parser <|> - (parser :: H (String -> Pattern String)) <*!> parser <|> - (parser :: H ([(String, String)] -> Pattern String)) <*!> parser - "expected Pattern String" + parseBP + <|> genericPatternExpressions + <|> (parser :: H (Pattern Int -> Pattern String)) <*!> parser + <|> (parser :: H (String -> Pattern String)) <*!> parser + <|> (parser :: H ([(String, String)] -> Pattern String)) <*!> parser + "expected Pattern String" parseBP :: (Enumerable a, T.Parseable a) => H (Pattern a) parseBP = do - (b,_) <- Haskellish.span + (b, _) <- Haskellish.span p <- T.parseBP <$> string case p of Left e -> throwError $ Data.Text.pack $ show e Right p' -> do return $ T.withContext (updateContext b) p' where - updateContext (dx,dy) c@T.Context {T.contextPosition = poss} = - c {T.contextPosition = map (\((bx,by), (ex,ey)) -> ((bx+dx,by+dy),(ex+dx,ey+dy))) poss} + updateContext (dx, dy) c@T.Context {T.contextPosition = poss} = + c {T.contextPosition = map (\((bx, by), (ex, ey)) -> ((bx + dx, by + dy), (ex + dx, ey + dy))) poss} instance Parse (Pattern Int) where parser = - pure . fromIntegral <$> integer <|> - parseBP <|> - genericPatternExpressions <|> - numPatternExpressions - "expected Pattern Int" + pure . fromIntegral <$> integer + <|> parseBP + <|> genericPatternExpressions + <|> numPatternExpressions + "expected Pattern Int" instance Parse (Pattern Integer) where parser = - pure <$> integer <|> - parseBP <|> - genericPatternExpressions <|> - numPatternExpressions - "expected Pattern Integer" + pure <$> integer + <|> parseBP + <|> genericPatternExpressions + <|> numPatternExpressions + "expected Pattern Integer" instance Parse (Pattern Double) where parser = - pure . fromIntegral <$> integer <|> - pure . realToFrac <$> rational <|> - parseBP <|> - genericPatternExpressions <|> - numPatternExpressions <|> - fractionalPatternExpressions <|> - $(fromTidal "sine") <|> - $(fromTidal "saw") <|> - $(fromTidal "isaw") <|> - $(fromTidal "tri") <|> - $(fromTidal "square") <|> - $(fromTidal "cosine") <|> - $(fromTidal "envEq") <|> - $(fromTidal "envEqR") <|> - $(fromTidal "envL") <|> - $(fromTidal "envLR") <|> - (parser :: H (String -> Pattern Double)) <*!> parser <|> - $(fromTidalList (fmap (\x -> "in" ++ show x) ([0..127] :: [Int]))) - "expected Pattern Double" + pure . fromIntegral <$> integer + <|> pure . realToFrac <$> rational + <|> parseBP + <|> genericPatternExpressions + <|> numPatternExpressions + <|> fractionalPatternExpressions + <|> $(fromTidal "sine") + <|> $(fromTidal "saw") + <|> $(fromTidal "isaw") + <|> $(fromTidal "tri") + <|> $(fromTidal "square") + <|> $(fromTidal "cosine") + <|> $(fromTidal "envEq") + <|> $(fromTidal "envEqR") + <|> $(fromTidal "envL") + <|> $(fromTidal "envLR") + <|> (parser :: H (String -> Pattern Double)) <*!> parser + <|> $(fromTidalList (fmap (\x -> "in" ++ show x) ([0 .. 127] :: [Int]))) + "expected Pattern Double" instance Parse (Pattern T.Note) where parser = - pure . fromIntegral <$> integer <|> - pure . realToFrac <$> rational <|> - parseBP <|> - genericPatternExpressions <|> - numPatternExpressions <|> - fractionalPatternExpressions - "expected Pattern Note" + pure . fromIntegral <$> integer + <|> pure . realToFrac <$> rational + <|> parseBP + <|> genericPatternExpressions + <|> numPatternExpressions + <|> fractionalPatternExpressions + "expected Pattern Note" instance Parse (Pattern Time) where parser = - pure . fromIntegral <$> integer <|> - pure <$> rational <|> - parseBP <|> - genericPatternExpressions <|> - numPatternExpressions <|> - fractionalPatternExpressions - "expected Pattern Time" + pure . fromIntegral <$> integer + <|> pure <$> rational + <|> parseBP + <|> genericPatternExpressions + <|> numPatternExpressions + <|> fractionalPatternExpressions + "expected Pattern Time" -- * -> * @@ -242,8 +293,8 @@ a_patternB = listAtoPatternB_a_patternB <*> parser "expected a -> Pattern b" listAtoPatternB_a_patternB :: H ([a -> Pattern b] -> a -> Pattern b) listAtoPatternB_a_patternB = - $(fromTidal "layer") <|> - $(fromTidal "spreadf") + $(fromTidal "layer") + <|> $(fromTidal "spreadf") {- -- a_patternB2 :: (Parse (a -> b -> Pattern c),Parse [a]) => H (b -> Pattern c) -- a_patternB2 = return id @@ -255,70 +306,78 @@ listA_b_patternC = (parser :: H ((a -> b -> Pattern c) -> [a] -> b -> Pattern c) instance Parse (ControlPattern -> ControlPattern) where parser = - genericTransformations <|> - $(fromTidal "ghost") <|> - $(fromTidal "silent") <|> - (parser :: H (Pattern Int -> ControlPattern -> ControlPattern)) <*!> parser <|> - (parser :: H (Pattern Double -> ControlPattern -> ControlPattern)) <*!> parser <|> - (parser :: H (Pattern Time -> ControlPattern -> ControlPattern)) <*!> parser - -- lCpCp_cp_cp <*!> parser - "expected ControlPattern -> ControlPattern" + genericTransformations + <|> $(fromTidal "ghost") + <|> $(fromTidal "silent") + <|> (parser :: H (Pattern Int -> ControlPattern -> ControlPattern)) <*!> parser + <|> (parser :: H (Pattern Double -> ControlPattern -> ControlPattern)) <*!> parser + <|> (parser :: H (Pattern Time -> ControlPattern -> ControlPattern)) <*!> parser + -- lCpCp_cp_cp <*!> parser + "expected ControlPattern -> ControlPattern" instance Parse (Pattern Bool -> Pattern Bool) where parser = genericTransformations <|> ordTransformations <|> fBool_fBool "expected Pattern Bool -> Pattern Bool" + instance Parse (Pattern String -> Pattern String) where parser = genericTransformations <|> ordTransformations "expected Pattern String -> Pattern String" + instance Parse (Pattern Int -> Pattern Int) where parser = genericTransformations <|> numTransformations <|> ordTransformations "expected Pattern Int -> Pattern Int" + instance Parse (Pattern Integer -> Pattern Integer) where parser = genericTransformations <|> numTransformations <|> ordTransformations "expected Pattern Integer -> Pattern Integer" + instance Parse (Pattern Time -> Pattern Time) where parser = genericTransformations <|> numTransformations <|> ordTransformations <|> realFracTransformations "expected Pattern Time -> Pattern Time" + instance Parse (Pattern Double -> Pattern Double) where parser = - genericTransformations <|> - numTransformations <|> - floatingTransformations <|> - ordTransformations <|> - realFracTransformations <|> - $(fromTidal "perlin2") - "expected Pattern Double -> Pattern Double" + genericTransformations + <|> numTransformations + <|> floatingTransformations + <|> ordTransformations + <|> realFracTransformations + <|> $(fromTidal "perlin2") + "expected Pattern Double -> Pattern Double" + instance Parse (Pattern T.Note -> Pattern T.Note) where parser = genericTransformations <|> numTransformations <|> floatingTransformations <|> ordTransformations "expected Pattern Note -> Pattern Note" genericTransformations :: forall a. (Parse (Pattern a), Parse (Pattern a -> Pattern a), Parse (Pattern a -> Pattern a -> Pattern a), Parse ((Pattern a -> Pattern a) -> Pattern a -> Pattern a), Parse ([Pattern a -> Pattern a] -> Pattern a -> Pattern a)) => H (Pattern a -> Pattern a) genericTransformations = - simpleComposition <|> - $(fromHaskell "id") <|> - (parser :: H (Pattern a -> Pattern a -> Pattern a)) <*!> parser <|> - asRightSection (parser :: H (Pattern a -> Pattern a -> Pattern a)) (required parser) <|> - (parser :: H ((Pattern a -> Pattern a) -> Pattern a -> Pattern a)) <*!> parser <|> - $(fromTidal "brak") <|> - $(fromTidal "rev") <|> - $(fromTidal "palindrome") <|> - $(fromTidal "stretch") <|> - $(fromTidal "loopFirst") <|> - $(fromTidal "degrade") <|> - $(fromTidal "arpeggiate") <|> - $(fromTidal "trigger") <|> - constParser <*!> parser <|> + simpleComposition + <|> $(fromHaskell "id") + <|> (parser :: H (Pattern a -> Pattern a -> Pattern a)) <*!> parser + <|> asRightSection (parser :: H (Pattern a -> Pattern a -> Pattern a)) (required parser) + <|> (parser :: H ((Pattern a -> Pattern a) -> Pattern a -> Pattern a)) <*!> parser + <|> $(fromTidal "brak") + <|> $(fromTidal "rev") + <|> $(fromTidal "palindrome") + <|> $(fromTidal "stretch") + <|> $(fromTidal "loopFirst") + <|> $(fromTidal "degrade") + <|> $(fromTidal "arpeggiate") + <|> $(fromTidal "trigger") + <|> constParser <*!> parser + <|> -- more complex possibilities that would involve overlapped Parse instances if they were instances - pTime_p_p <*!> parser <|> - pInt_p_p <*!> parser <|> - pDouble_p_p <*!> parser <|> - pBool_p_p <*!> parser <|> - lpInt_p_p <*!> parser <|> - pString_p_p <*!> parser <|> + pTime_p_p <*!> parser + <|> pInt_p_p <*!> parser + <|> pDouble_p_p <*!> parser + <|> pBool_p_p <*!> parser + <|> lpInt_p_p <*!> parser + <|> pString_p_p <*!> parser + <|> -- more complex possibilities that wouldn't involve overlapped Parse instances - (parser :: H (Time -> Pattern a -> Pattern a)) <*!> parser <|> - (parser :: H ((Time,Time) -> Pattern a -> Pattern a)) <*!> parser <|> - (parser :: H ([Time] -> Pattern a -> Pattern a)) <*!> parser <|> - (parser :: H ([Pattern Time] -> Pattern a -> Pattern a)) <*!> parser <|> - (parser :: H ([Pattern Double] -> Pattern a -> Pattern a)) <*!> parser <|> - (parser :: H ([Pattern a -> Pattern a] -> Pattern a -> Pattern a)) <*!> parser <|> - lp_p_p <*!> parser <|> - a_patternB <|> - pA_pB + (parser :: H (Time -> Pattern a -> Pattern a)) <*!> parser + <|> (parser :: H ((Time, Time) -> Pattern a -> Pattern a)) <*!> parser + <|> (parser :: H ([Time] -> Pattern a -> Pattern a)) <*!> parser + <|> (parser :: H ([Pattern Time] -> Pattern a -> Pattern a)) <*!> parser + <|> (parser :: H ([Pattern Double] -> Pattern a -> Pattern a)) <*!> parser + <|> (parser :: H ([Pattern a -> Pattern a] -> Pattern a -> Pattern a)) <*!> parser + <|> lp_p_p <*!> parser + <|> a_patternB + <|> pA_pB -- this only matches the case where the functions being composed are both a -> a (with the same a) -- nonetheless, this is an extremely common case with Tidal @@ -335,117 +394,121 @@ ordTransformations = floatingTransformations :: (Floating a, Parse a, Parse (Pattern a)) => H (Pattern a -> Pattern a) floatingTransformations = - floatingMergeOperator <*!> parser <|> - floating_pFloating_pFloating <*!> parser + floatingMergeOperator <*!> parser + <|> floating_pFloating_pFloating <*!> parser realFracTransformations :: (RealFrac a, Parse a) => H (Pattern a -> Pattern a) realFracTransformations = realFrac_pRealFrac_pRealFrac <*!> parser instance Parse ([a] -> Pattern a) where parser = - $(fromTidal "listToPat") <|> - $(fromTidal "choose") <|> - $(fromTidal "cycleChoose") <|> - a_patternB + $(fromTidal "listToPat") + <|> $(fromTidal "choose") + <|> $(fromTidal "cycleChoose") + <|> a_patternB -instance Parse ([Pattern a] -> Pattern a) where +instance Parse ([Pattern a] -> Pattern a) where parser = - $(fromTidal "stack") <|> - $(fromTidal "fastcat") <|> $(fromTidal "fastCat") <|> - $(fromTidal "slowcat") <|> $(fromTidal "slowCat") <|> - $(fromTidal "cat") <|> - $(fromTidal "randcat") <|> - (parser :: H (Pattern Double -> [Pattern a] -> Pattern a)) <*!> parser <|> - (parser :: H (Pattern Int -> [Pattern a] -> Pattern a)) <*!> parser <|> - a_patternB + $(fromTidal "stack") + <|> $(fromTidal "fastcat") + <|> $(fromTidal "fastCat") + <|> $(fromTidal "slowcat") + <|> $(fromTidal "slowCat") + <|> $(fromTidal "cat") + <|> $(fromTidal "randcat") + <|> (parser :: H (Pattern Double -> [Pattern a] -> Pattern a)) <*!> parser + <|> (parser :: H (Pattern Int -> [Pattern a] -> Pattern a)) <*!> parser + <|> a_patternB instance Parse ([(Pattern a, Double)] -> Pattern a) where parser = - $(fromTidal "wrandcat") <|> - a_patternB + $(fromTidal "wrandcat") + <|> a_patternB pInt_p :: Parse [a] => H (Pattern Int -> Pattern a) pInt_p = (parser :: H ([a] -> Pattern Int -> Pattern a)) <*!> parser - -- ??? a_patternB -- also missing from all non-instance entries in this section - -- ??? pA_pB + +-- ??? a_patternB -- also missing from all non-instance entries in this section +-- ??? pA_pB instance Parse (Pattern String -> ControlPattern) where parser = - $(fromTidal "s") <|> - $(fromTidal "sound") <|> - $(fromTidal "vowel") <|> - (parser :: H (String -> Pattern String -> ControlPattern)) <*!> parser <|> - pA_pB <|> - a_patternB + $(fromTidal "s") + <|> $(fromTidal "sound") + <|> $(fromTidal "vowel") + <|> (parser :: H (String -> Pattern String -> ControlPattern)) <*!> parser + <|> pA_pB + <|> a_patternB instance Parse (Pattern Int -> ControlPattern) where parser = - $(fromTidal "cut") <|> - (parser :: H (String -> Pattern Int -> ControlPattern)) <*!> parser <|> - pA_pB <|> - a_patternB + $(fromTidal "cut") + <|> (parser :: H (String -> Pattern Int -> ControlPattern)) <*!> parser + <|> pA_pB + <|> a_patternB instance Parse (Pattern String -> Pattern Bool) where parser = - $(fromTidal "ascii") <|> - pA_pB <|> - a_patternB + $(fromTidal "ascii") + <|> pA_pB + <|> a_patternB instance Parse (Pattern Int -> Pattern Bool) where parser = - $(fromTidal "binary") <|> - (parser :: H (Pattern Int -> Pattern Int -> Pattern Bool)) <*!> parser <|> - pA_pB <|> - a_patternB + $(fromTidal "binary") + <|> (parser :: H (Pattern Int -> Pattern Int -> Pattern Bool)) <*!> parser + <|> pA_pB + <|> a_patternB instance Parse (Pattern T.Note -> ControlPattern) where - parser = $(fromTidal "up") <|> - $(fromTidal "n") <|> - $(fromTidal "note") <|> - (parser :: H (String -> Pattern T.Note -> ControlPattern)) <*!> parser <|> - pA_pB <|> - a_patternB + parser = + $(fromTidal "up") + <|> $(fromTidal "n") + <|> $(fromTidal "note") + <|> (parser :: H (String -> Pattern T.Note -> ControlPattern)) <*!> parser + <|> pA_pB + <|> a_patternB instance Parse (Pattern Double -> ControlPattern) where parser = - $(fromTidal "speed") <|> - $(fromTidal "pan") <|> - $(fromTidal "shape") <|> - $(fromTidal "gain") <|> - $(fromTidal "overgain") <|> - $(fromTidal "overshape") <|> - $(fromTidal "accelerate") <|> - $(fromTidal "bandf") <|> - $(fromTidal "bandq") <|> - $(fromTidal "begin") <|> - $(fromTidal "crush") <|> - $(fromTidal "legato") <|> - $(fromTidal "cutoff") <|> - $(fromTidal "delayfeedback") <|> - $(fromTidal "delaytime") <|> - $(fromTidal "delay") <|> - $(fromTidal "end") <|> - $(fromTidal "hcutoff") <|> - $(fromTidal "hresonance") <|> - $(fromTidal "resonance") <|> - $(fromTidal "loop") <|> - $(fromTidal "coarse") <|> - $(fromTidal "nudge") <|> - (parser :: H (String -> Pattern Double -> ControlPattern)) <*!> parser <|> - pA_pB <|> - a_patternB + $(fromTidal "speed") + <|> $(fromTidal "pan") + <|> $(fromTidal "shape") + <|> $(fromTidal "gain") + <|> $(fromTidal "overgain") + <|> $(fromTidal "overshape") + <|> $(fromTidal "accelerate") + <|> $(fromTidal "bandf") + <|> $(fromTidal "bandq") + <|> $(fromTidal "begin") + <|> $(fromTidal "crush") + <|> $(fromTidal "legato") + <|> $(fromTidal "cutoff") + <|> $(fromTidal "delayfeedback") + <|> $(fromTidal "delaytime") + <|> $(fromTidal "delay") + <|> $(fromTidal "end") + <|> $(fromTidal "hcutoff") + <|> $(fromTidal "hresonance") + <|> $(fromTidal "resonance") + <|> $(fromTidal "loop") + <|> $(fromTidal "coarse") + <|> $(fromTidal "nudge") + <|> (parser :: H (String -> Pattern Double -> ControlPattern)) <*!> parser + <|> pA_pB + <|> a_patternB instance Parse (Pattern Int -> Pattern String) where parser = - pString_pInt_pString <*!> parser <|> - pA_pB <|> - a_patternB + pString_pInt_pString <*!> parser + <|> pA_pB + <|> a_patternB instance Parse (String -> Pattern String) where parser = - (parser :: H (String -> String -> Pattern String)) <*> parser <|> - (parser :: H ([String] -> String -> Pattern String )) <*> parser + (parser :: H (String -> String -> Pattern String)) <*> parser + <|> (parser :: H ([String] -> String -> Pattern String)) <*> parser instance Parse ([(String, String)] -> Pattern String) where parser = $(fromTidal "sseqs") @@ -470,8 +533,8 @@ listCp_cp = (parser :: H (ControlPattern -> [ControlPattern] -> ControlPattern)) instance Parse (Pattern a) => Parse ([Pattern a -> Pattern a] -> Pattern a) where parser = - (parser :: H (Pattern a -> [Pattern a -> Pattern a] -> Pattern a)) <*!> parser <|> - a_patternB + (parser :: H (Pattern a -> [Pattern a -> Pattern a] -> Pattern a)) <*!> parser + <|> a_patternB -- note: mising a_patternB pathway (? maybe not necessary here though ?) pA_pB :: Parse (Pattern a -> Pattern b) => H (Pattern a -> Pattern b) @@ -485,20 +548,19 @@ list_p :: Parse a => H ([a] -> Pattern a) list_p = pDouble_list_p <*!> parser -- note: mising a_patternB pathway -tupleADouble_p :: Parse a => H ([(a,Double)] -> Pattern a) +tupleADouble_p :: Parse a => H ([(a, Double)] -> Pattern a) tupleADouble_p = - $(fromTidal "wchoose") <|> - pDouble_tupleADouble_p <*!> parser + $(fromTidal "wchoose") + <|> pDouble_tupleADouble_p <*!> parser instance Parse ([(Time, Pattern a)] -> Pattern a) where parser = $(fromTidal "timeCat") <|> $(fromTidal "timecat") instance Parse (String -> Pattern Double) where parser = - $(fromTidal "cF_") <|> - $(fromTidal "cF0") <|> - (parser :: H (Double -> String -> Pattern Double)) <*!> parser - + $(fromTidal "cF_") + <|> $(fromTidal "cF0") + <|> (parser :: H (Double -> String -> Pattern Double)) <*!> parser -- * -> * -> * @@ -511,188 +573,188 @@ instance Parse (Pattern String -> Pattern String -> Pattern String) where instance Parse (Pattern Int -> Pattern Int -> Pattern Int) where parser = - genericBinaryPatternFunctions <|> - numMergeOperator <|> - pInt_p_p - "expected Pattern Int -> Pattern Int -> Pattern Int" + genericBinaryPatternFunctions + <|> numMergeOperator + <|> pInt_p_p + "expected Pattern Int -> Pattern Int -> Pattern Int" instance Parse (Pattern Integer -> Pattern Integer -> Pattern Integer) where parser = - genericBinaryPatternFunctions <|> - numMergeOperator - "expected Pattern Integer -> Pattern Integer -> Pattern Integer" + genericBinaryPatternFunctions + <|> numMergeOperator + "expected Pattern Integer -> Pattern Integer -> Pattern Integer" instance Parse (Pattern Time -> Pattern Time -> Pattern Time) where parser = - genericBinaryPatternFunctions <|> - numMergeOperator <|> - realMergeOperator <|> - fractionalMergeOperator <|> - pTime_p_p - "expected Pattern Time -> Pattern Time -> Pattern Time" + genericBinaryPatternFunctions + <|> numMergeOperator + <|> realMergeOperator + <|> fractionalMergeOperator + <|> pTime_p_p + "expected Pattern Time -> Pattern Time -> Pattern Time" instance Parse (Pattern Double -> Pattern Double -> Pattern Double) where parser = - genericBinaryPatternFunctions <|> - numMergeOperator <|> - realMergeOperator <|> - fractionalMergeOperator <|> - $(fromTidal "perlin2With") <|> - pDouble_p_p - "expected Pattern Double -> Pattern Double -> Pattern Double" + genericBinaryPatternFunctions + <|> numMergeOperator + <|> realMergeOperator + <|> fractionalMergeOperator + <|> $(fromTidal "perlin2With") + <|> pDouble_p_p + "expected Pattern Double -> Pattern Double -> Pattern Double" instance Parse (Pattern T.Note -> Pattern T.Note -> Pattern T.Note) where parser = - genericBinaryPatternFunctions <|> - numMergeOperator <|> - realMergeOperator <|> - fractionalMergeOperator - "expected Pattern Note -> Pattern Note -> Pattern Note" + genericBinaryPatternFunctions + <|> numMergeOperator + <|> realMergeOperator + <|> fractionalMergeOperator + "expected Pattern Note -> Pattern Note -> Pattern Note" instance Parse (ControlPattern -> ControlPattern -> ControlPattern) where parser = - genericBinaryPatternFunctions <|> - numMergeOperator <|> - fractionalMergeOperator <|> - $(fromTidal "interlace") <|> - (parser :: H ((ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern -> ControlPattern)) <*!> parser - "expected ControlPattern -> ControlPattern -> ControlPattern" + genericBinaryPatternFunctions + <|> numMergeOperator + <|> fractionalMergeOperator + <|> $(fromTidal "interlace") + <|> (parser :: H ((ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern -> ControlPattern)) <*!> parser + "expected ControlPattern -> ControlPattern -> ControlPattern" genericBinaryPatternFunctions :: T.Unionable a => H (Pattern a -> Pattern a -> Pattern a) genericBinaryPatternFunctions = - $(fromTidal "overlay") <|> - $(fromTidal "append") <|> - $(fromTidal "slowAppend") <|> - $(fromTidal "slowappend") <|> - $(fromTidal "fastAppend") <|> - $(fromTidal "fastappend") <|> - unionableMergeOperator <|> - pInt_p_p_p <*!> parser <|> - pBool_p_p_p <*!> parser <|> - pTime_p_p_p <*!> parser <|> - (parser :: H (Pattern Bool -> Pattern a -> Pattern a -> Pattern a)) <*!> parser <|> - constParser + $(fromTidal "overlay") + <|> $(fromTidal "append") + <|> $(fromTidal "slowAppend") + <|> $(fromTidal "slowappend") + <|> $(fromTidal "fastAppend") + <|> $(fromTidal "fastappend") + <|> unionableMergeOperator + <|> pInt_p_p_p <*!> parser + <|> pBool_p_p_p <*!> parser + <|> pTime_p_p_p <*!> parser + <|> (parser :: H (Pattern Bool -> Pattern a -> Pattern a -> Pattern a)) <*!> parser + <|> constParser unionableMergeOperator :: T.Unionable a => H (Pattern a -> Pattern a -> Pattern a) unionableMergeOperator = - $(fromTidal "#") <|> - $(fromTidal "|>|") <|> - $(fromTidal "|>") <|> - $(fromTidal ">|") <|> - $(fromTidal "|<|") <|> - $(fromTidal "|<") <|> - $(fromTidal "<|") <|> - $(fromHaskell "<>") + $(fromTidal "#") + <|> $(fromTidal "|>|") + <|> $(fromTidal "|>") + <|> $(fromTidal ">|") + <|> $(fromTidal "|<|") + <|> $(fromTidal "|<") + <|> $(fromTidal "<|") + <|> $(fromHaskell "<>") numMergeOperator :: (Num a, Parse (Pattern a)) => H (Pattern a -> Pattern a -> Pattern a) numMergeOperator = - numTernaryTransformations <*!> parser <|> - $(fromTidal "|+|") <|> - $(fromTidal "|+") <|> - $(fromTidal "+|") <|> - $(fromTidal "|-|") <|> - $(fromTidal "|-") <|> - $(fromTidal "-|") <|> - $(fromTidal "|*|") <|> - $(fromTidal "|*") <|> - $(fromTidal "*|") <|> - $(fromHaskell "+") <|> - $(fromHaskell "*") <|> - $(fromHaskell "-") + numTernaryTransformations <*!> parser + <|> $(fromTidal "|+|") + <|> $(fromTidal "|+") + <|> $(fromTidal "+|") + <|> $(fromTidal "|-|") + <|> $(fromTidal "|-") + <|> $(fromTidal "-|") + <|> $(fromTidal "|*|") + <|> $(fromTidal "|*") + <|> $(fromTidal "*|") + <|> $(fromHaskell "+") + <|> $(fromHaskell "*") + <|> $(fromHaskell "-") realMergeOperator :: T.Moddable a => H (Pattern a -> Pattern a -> Pattern a) realMergeOperator = - $(fromTidal "|%|") <|> - $(fromTidal "|%") <|> - $(fromTidal "%|") + $(fromTidal "|%|") + <|> $(fromTidal "|%") + <|> $(fromTidal "%|") fractionalMergeOperator :: Fractional a => H (Pattern a -> Pattern a -> Pattern a) fractionalMergeOperator = - $(fromTidal "|/|") <|> - $(fromTidal "|/") <|> - $(fromTidal "/|") <|> - $(fromHaskell "/") + $(fromTidal "|/|") + <|> $(fromTidal "|/") + <|> $(fromTidal "/|") + <|> $(fromHaskell "/") floatingMergeOperator :: Floating a => H (Pattern a -> Pattern a -> Pattern a) floatingMergeOperator = - $(fromTidal "|**") <|> - $(fromTidal "**|") <|> - $(fromTidal "|**|") + $(fromTidal "|**") + <|> $(fromTidal "**|") + <|> $(fromTidal "|**|") constParser :: H (a -> b -> a) constParser = $(fromHaskell "const") instance Parse (Time -> Pattern a -> Pattern a) where parser = - $(fromTidal "rotL") <|> - $(fromTidal "rotR") <|> - (parser :: H (Time -> Time -> Pattern a -> Pattern a)) <*!> parser <|> - integral_time_pA_pA <*!> (parser :: H Int) -- we over-specialized this to Int since don't know of case where this wouldn't suffice - + $(fromTidal "rotL") + <|> $(fromTidal "rotR") + <|> (parser :: H (Time -> Time -> Pattern a -> Pattern a)) <*!> parser + <|> integral_time_pA_pA <*!> (parser :: H Int) -- we over-specialized this to Int since don't know of case where this wouldn't suffice instance Parse (Pattern Int -> Pattern Int -> Pattern Bool) where parser = $(fromTidal "binaryN") -instance Parse ((Time,Time) -> Pattern a -> Pattern a) where +instance Parse ((Time, Time) -> Pattern a -> Pattern a) where parser = - $(fromTidal "compress") <|> - $(fromTidal "zoom") <|> - $(fromTidal "compressTo") + $(fromTidal "compress") + <|> $(fromTidal "zoom") + <|> $(fromTidal "compressTo") pString_pInt_pString :: H (Pattern String -> Pattern Int -> Pattern String) pString_pInt_pString = $(fromTidal "samples") pTime_p_p :: H (Pattern Time -> Pattern a -> Pattern a) pTime_p_p = - $(fromTidal "fast") <|> - $(fromTidal "fastGap") <|> - $(fromTidal "density") <|> - $(fromTidal "slow") <|> - $(fromTidal "trunc") <|> - $(fromTidal "densityGap") <|> - $(fromTidal "sparsity") <|> - $(fromTidal "linger") <|> - $(fromTidal "segment") <|> - $(fromTidal "discretise") <|> - $(fromTidal "timeLoop") <|> - $(fromTidal "swing") <|> - $(fromTidal "<~") <|> - $(fromTidal "~>") <|> - $(fromTidal "ply") <|> - (parser :: H (Pattern Time -> Pattern Time -> Pattern a -> Pattern a)) <*!> parser + $(fromTidal "fast") + <|> $(fromTidal "fastGap") + <|> $(fromTidal "density") + <|> $(fromTidal "slow") + <|> $(fromTidal "trunc") + <|> $(fromTidal "densityGap") + <|> $(fromTidal "sparsity") + <|> $(fromTidal "linger") + <|> $(fromTidal "segment") + <|> $(fromTidal "discretise") + <|> $(fromTidal "timeLoop") + <|> $(fromTidal "swing") + <|> $(fromTidal "<~") + <|> $(fromTidal "~>") + <|> $(fromTidal "ply") + <|> (parser :: H (Pattern Time -> Pattern Time -> Pattern a -> Pattern a)) <*!> parser pInt_p_p :: H (Pattern Int -> Pattern a -> Pattern a) pInt_p_p = - $(fromTidal "iter") <|> - $(fromTidal "iter'") <|> - $(fromTidal "substruct'") <|> - $(fromTidal "slowstripe") <|> - $(fromTidal "shuffle") <|> - $(fromTidal "scramble") <|> - $(fromTidal "repeatCycles") <|> - $(fromTidal "stripe") <|> - pInt_pInt_p_p <*!> parser + $(fromTidal "iter") + <|> $(fromTidal "iter'") + <|> $(fromTidal "substruct'") + <|> $(fromTidal "slowstripe") + <|> $(fromTidal "shuffle") + <|> $(fromTidal "scramble") + <|> $(fromTidal "repeatCycles") + <|> $(fromTidal "stripe") + <|> pInt_pInt_p_p <*!> parser pInt_pOrd_pOrd :: Ord a => H (Pattern Int -> Pattern a -> Pattern a) pInt_pOrd_pOrd = $(fromTidal "rot") pDouble_p_p :: H (Pattern Double -> Pattern a -> Pattern a) pDouble_p_p = - $(fromTidal "degradeBy") <|> - $(fromTidal "unDegradeBy") <|> - (parser :: H (Int -> Pattern Double -> Pattern a -> Pattern a)) <*!> parser + $(fromTidal "degradeBy") + <|> $(fromTidal "unDegradeBy") + <|> (parser :: H (Int -> Pattern Double -> Pattern a -> Pattern a)) <*!> parser pBool_p_p :: H (Pattern Bool -> Pattern a -> Pattern a) pBool_p_p = - $(fromTidal "mask") <|> - $(fromTidal "struct") <|> - $(fromTidal "substruct") + $(fromTidal "mask") + <|> $(fromTidal "struct") + <|> $(fromTidal "substruct") instance Parse ([ControlPattern -> ControlPattern] -> ControlPattern -> ControlPattern) where parser = - $(fromTidal "jux'") <|> - $(fromTidal "juxcut'") <|> - lPatApatA_patA_patA + $(fromTidal "jux'") + <|> $(fromTidal "juxcut'") + <|> lPatApatA_patA_patA + -- *** pathway leading to spread(etc) should be incorporated above instance {-# OVERLAPPABLE #-} Parse ((Pattern a -> Pattern a) -> Pattern a -> Pattern a) => Parse ([Pattern a -> Pattern a] -> Pattern a -> Pattern a) where @@ -700,9 +762,9 @@ instance {-# OVERLAPPABLE #-} Parse ((Pattern a -> Pattern a) -> Pattern a -> Pa lPatApatA_patA_patA :: Parse ((Pattern a -> Pattern a) -> Pattern a -> Pattern a) => H ([Pattern a -> Pattern a] -> Pattern a -> Pattern a) lPatApatA_patA_patA = - (parser :: H (((Pattern a -> Pattern a) -> Pattern a -> Pattern a) -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a)) <*> parser <|> - (parser :: H (Pattern Int -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a)) <*> parser <|> - (parser :: H (Pattern Double -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a)) <*> parser + (parser :: H (((Pattern a -> Pattern a) -> Pattern a -> Pattern a) -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a)) <*> parser + <|> (parser :: H (Pattern Int -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a)) <*> parser + <|> (parser :: H (Pattern Double -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a)) <*> parser lp_p_p :: Parse (Pattern a -> Pattern a -> Pattern a) => H ([Pattern a] -> Pattern a -> Pattern a) lp_p_p = (parser :: H ((Pattern a -> Pattern a -> Pattern a) -> [Pattern a] -> Pattern a -> Pattern a)) <*> parser @@ -715,79 +777,86 @@ instance Parse ([Pattern Time] -> Pattern a -> Pattern a) where lpInt_p_p :: H ([Pattern Int] -> Pattern a -> Pattern a) lpInt_p_p = - $(fromTidal "distrib") <|> - (parser :: H ((Pattern Int -> Pattern a -> Pattern a) -> [Pattern Int] -> Pattern a -> Pattern a)) <*> pInt_p_p + $(fromTidal "distrib") + <|> (parser :: H ((Pattern Int -> Pattern a -> Pattern a) -> [Pattern Int] -> Pattern a -> Pattern a)) <*> pInt_p_p instance Parse ([Time] -> Pattern a -> Pattern a) where parser = $(fromTidal "spaceOut") - -- *** pathway leading to spread(etc) should be incorporated here + +-- pathway leading to spread(etc) should be incorporated here instance Parse (Pattern Int -> ControlPattern -> ControlPattern) where parser = - $(fromTidal "chop") <|> - $(fromTidal "striate") <|> - $(fromTidal "gap") <|> - $(fromTidal "randslice") <|> - $(fromTidal "spin") <|> - (parser :: H (Pattern Int -> Pattern Int -> ControlPattern -> ControlPattern)) <*!> parser + $(fromTidal "chop") + <|> $(fromTidal "striate") + <|> $(fromTidal "gap") + <|> $(fromTidal "randslice") + <|> $(fromTidal "spin") + <|> (parser :: H (Pattern Int -> Pattern Int -> ControlPattern -> ControlPattern)) <*!> parser instance Parse (Pattern Double -> ControlPattern -> ControlPattern) where parser = - (parser :: H (Pattern Int -> Pattern Double -> ControlPattern -> ControlPattern)) <*!> parser <|> - (parser :: H (Pattern Rational -> Pattern Double -> ControlPattern -> ControlPattern)) <*!> parser + (parser :: H (Pattern Int -> Pattern Double -> ControlPattern -> ControlPattern)) <*!> parser + <|> (parser :: H (Pattern Rational -> Pattern Double -> ControlPattern -> ControlPattern)) <*!> parser instance Parse (Pattern Time -> ControlPattern -> ControlPattern) where parser = - $(fromTidal "hurry") <|> - $(fromTidal "loopAt") <|> - (parser :: H (Pattern Double -> Pattern Time -> ControlPattern -> ControlPattern)) <*!> parser + $(fromTidal "hurry") + <|> $(fromTidal "loopAt") + <|> (parser :: H (Pattern Double -> Pattern Time -> ControlPattern -> ControlPattern)) <*!> parser instance Parse ((ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern) where parser = - genericAppliedTransformations <|> - $(fromTidal "jux") <|> - $(fromTidal "juxcut") <|> - $(fromTidal "jux4") <|> - pDouble_controlMapToValueMap_controlMap_controlMap <*!> parser + genericAppliedTransformations + <|> $(fromTidal "jux") + <|> $(fromTidal "juxcut") + <|> $(fromTidal "jux4") + <|> pDouble_controlMapToValueMap_controlMap_controlMap <*!> parser instance Parse ((Pattern Bool -> Pattern Bool) -> Pattern Bool -> Pattern Bool) where parser = genericAppliedTransformations + instance Parse ((Pattern String -> Pattern String) -> Pattern String -> Pattern String) where parser = genericAppliedTransformations + instance Parse ((Pattern Int -> Pattern Int) -> Pattern Int -> Pattern Int) where parser = genericAppliedTransformations + instance Parse ((Pattern Integer -> Pattern Integer) -> Pattern Integer -> Pattern Integer) where parser = genericAppliedTransformations + instance Parse ((Pattern Time -> Pattern Time) -> Pattern Time -> Pattern Time) where parser = genericAppliedTransformations + instance Parse ((Pattern Double -> Pattern Double) -> Pattern Double -> Pattern Double) where parser = genericAppliedTransformations + instance Parse ((Pattern T.Note -> Pattern T.Note) -> Pattern T.Note -> Pattern T.Note) where parser = genericAppliedTransformations genericAppliedTransformations :: H ((Pattern a -> Pattern a) -> Pattern a -> Pattern a) genericAppliedTransformations = - $(fromHaskell "$") <|> - $(fromTidal "sometimes") <|> - $(fromTidal "often") <|> - $(fromTidal "rarely") <|> - $(fromTidal "almostNever") <|> - $(fromTidal "almostAlways") <|> - $(fromTidal "never") <|> - $(fromTidal "always") <|> - $(fromTidal "superimpose") <|> - $(fromTidal "someCycles") <|> - (parser :: H (Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)) <*!> parser <|> - (parser :: H (Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)) <*!> parser <|> - (parser :: H (Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)) <*!> parser <|> - (parser :: H ([Int] -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)) <*!> parser <|> - (parser :: H ((Time,Time) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)) <*!> parser <|> - (parser :: H (Pattern Bool -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)) <*!> parser - + $(fromHaskell "$") + <|> $(fromTidal "sometimes") + <|> $(fromTidal "often") + <|> $(fromTidal "rarely") + <|> $(fromTidal "almostNever") + <|> $(fromTidal "almostAlways") + <|> $(fromTidal "never") + <|> $(fromTidal "always") + <|> $(fromTidal "superimpose") + <|> $(fromTidal "someCycles") + <|> (parser :: H (Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)) <*!> parser + <|> (parser :: H (Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)) <*!> parser + <|> (parser :: H (Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)) <*!> parser + <|> (parser :: H ([Int] -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)) <*!> parser + <|> (parser :: H ((Time, Time) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)) <*!> parser + <|> (parser :: H (Pattern Bool -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)) <*!> parser instance Parse ([a] -> Pattern Int -> Pattern a) where parser = (parser :: H (Pattern Int -> [a] -> Pattern Int -> Pattern a)) <*!> parser - -- *** pathway leading to spread(etc) should be incorporated here + +-- pathway leading to spread(etc) should be incorporated here instance Parse (String -> Pattern Double -> ControlPattern) where parser = $(fromTidal "pF") @@ -812,6 +881,7 @@ instance Fractional a => Parse (Pattern String -> Pattern Int -> Pattern a) wher listNumA_pInt_pA :: Num a => H ([a] -> Pattern Int -> Pattern a) listNumA_pInt_pA = $(fromTidal "toScale") + -- *** pathway leading to spread(etc) should be incorporated here pString_p_p :: H (Pattern String -> Pattern a -> Pattern a) @@ -829,7 +899,7 @@ pAB_pA_pB = pTime_pAB_pA_pB <*!> parser pDouble_list_p :: Parse a => H (Pattern Double -> [a] -> Pattern a) pDouble_list_p = $(fromTidal "chooseBy") -pDouble_tupleADouble_p :: Parse a => H (Pattern Double -> [(a,Double)] -> Pattern a) +pDouble_tupleADouble_p :: Parse a => H (Pattern Double -> [(a, Double)] -> Pattern a) pDouble_tupleADouble_p = $(fromTidal "wchooseBy") instance Parse (String -> String -> Pattern String) where @@ -850,17 +920,17 @@ realFrac_pRealFrac_pRealFrac = $(fromTidal "quantise") instance Parse (Double -> String -> Pattern Double) where parser = $(fromTidal "cF") - -- * -> * -> * -> * numTernaryTransformations :: Num a => H (Pattern a -> Pattern a -> Pattern a -> Pattern a) numTernaryTransformations = $(fromTidal "range") instance Parse (Pattern Int -> Pattern Int -> ControlPattern -> ControlPattern) where - parser = $(fromTidal "slice") <|> - $(fromTidal "splice") <|> - $(fromTidal "chew") <|> - $(fromTidal "bite") + parser = + $(fromTidal "slice") + <|> $(fromTidal "splice") + <|> $(fromTidal "chew") + <|> $(fromTidal "bite") instance Parse (Time -> Time -> Pattern a -> Pattern a) where parser = $(fromTidal "playFor") @@ -879,20 +949,20 @@ instance Parse (Pattern Bool -> (Pattern a -> Pattern a) -> Pattern a -> Pattern pInt_pInt_p_p :: H (Pattern Int -> Pattern Int -> Pattern a -> Pattern a) pInt_pInt_p_p = - $(fromTidal "euclid") <|> - $(fromTidal "euclidInv") <|> - (parser :: H (Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a)) <*!> parser + $(fromTidal "euclid") + <|> $(fromTidal "euclidInv") + <|> (parser :: H (Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a)) <*!> parser instance Parse (Int -> Pattern Double -> Pattern a -> Pattern a) where parser = $(fromTidal "degradeOverBy") instance Parse ((a -> b -> Pattern c) -> [a] -> b -> Pattern c) where parser = - $(fromTidal "spread") <|> - $(fromTidal "slowspread") <|> - $(fromTidal "fastspread") <|> - $(fromTidal "spreadChoose") <|> - $(fromTidal "spreadr") + $(fromTidal "spread") + <|> $(fromTidal "slowspread") + <|> $(fromTidal "fastspread") + <|> $(fromTidal "spreadChoose") + <|> $(fromTidal "spreadr") pInt_p_p_p :: H (Pattern Int -> Pattern a -> Pattern a -> Pattern a) pInt_p_p_p = (parser :: H (Pattern Int -> Pattern Int -> Pattern a -> Pattern a -> Pattern a)) <*!> parser @@ -908,47 +978,46 @@ instance Parse (Pattern Double -> Pattern Time -> ControlPattern -> ControlPatte instance Parse (Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a) where parser = - $(fromTidal "off") <|> - $(fromTidal "plyWith") <|> - (parser :: H (Pattern Time -> Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)) <*!> parser <|> - (parser :: H (Pattern Int -> Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)) <*!> parser - + $(fromTidal "off") + <|> $(fromTidal "plyWith") + <|> (parser :: H (Pattern Time -> Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)) <*!> parser + <|> (parser :: H (Pattern Int -> Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)) <*!> parser pTime_pAB_pA_pB :: H (Pattern Time -> (Pattern a -> Pattern b) -> Pattern a -> Pattern b) pTime_pAB_pA_pB = - $(fromTidal "inside") <|> - $(fromTidal "outside") + $(fromTidal "inside") + <|> $(fromTidal "outside") instance Parse (Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a) where parser = - $(fromTidal "every") <|> - $(fromTidal "plyWith") <|> - $(fromTidal "chunk") <|> - $(fromTidal "chunk'") <|> -- note: chunk' is actually generalized to Integral, but not clear what non-Int cases would be - (parser :: H (Pattern Int -> Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)) <*!> parser + $(fromTidal "every") + <|> $(fromTidal "plyWith") + <|> $(fromTidal "chunk") + <|> $(fromTidal "chunk'") + <|> (parser :: H (Pattern Int -> Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a)) <*!> parser -- note: chunk' is actually generalized to Integral, but not clear what non-Int cases would be instance Parse (Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a) where parser = - $(fromTidal "sometimesBy") <|> - $(fromTidal "someCyclesBy") <|> - $(fromTidal "plyWith") + $(fromTidal "sometimesBy") + <|> $(fromTidal "someCyclesBy") + <|> $(fromTidal "plyWith") pDouble_controlMapToValueMap_controlMap_controlMap :: H (Pattern Double -> (Pattern ValueMap -> Pattern ValueMap) -> Pattern ValueMap -> Pattern ValueMap) pDouble_controlMapToValueMap_controlMap_controlMap = - $(fromTidal "juxBy") <|> - (parser :: H (Pattern Double -> (Pattern ValueMap -> Pattern ValueMap) -> Pattern ValueMap -> Pattern ValueMap)) + $(fromTidal "juxBy") + <|> (parser :: H (Pattern Double -> (Pattern ValueMap -> Pattern ValueMap) -> Pattern ValueMap -> Pattern ValueMap)) instance Parse ((ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern -> ControlPattern) where parser = - $(fromTidal "fix") <|> - $(fromTidal "unfix") <|> - (parser :: H ((ControlPattern -> ControlPattern) -> (ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern -> ControlPattern)) <*!> parser - "expected (ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern -> ControlPattern" + $(fromTidal "fix") + <|> $(fromTidal "unfix") + <|> (parser :: H ((ControlPattern -> ControlPattern) -> (ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern -> ControlPattern)) <*!> parser + "expected (ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern -> ControlPattern" instance Parse ([Int] -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a) where parser = $(fromTidal "foldEvery") -instance Parse ((Time,Time) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a) where +instance Parse ((Time, Time) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a) where parser = $(fromTidal "within") instance Parse (Pattern Int -> [a] -> Pattern Int -> Pattern a) where @@ -971,6 +1040,7 @@ instance Parse (Int -> String -> String -> String) where floating_floating_pFloating_pFloating :: Floating a => H (a -> a -> Pattern a -> Pattern a) floating_floating_pFloating_pFloating = $(fromTidal "rangex") + -- note: rangex actually generalized to Functor a rather than Pattern a, so we are over-specializing integral_time_pA_pA :: Integral i => H (i -> Time -> Pattern a -> Pattern a) @@ -998,8 +1068,8 @@ instance Parse (Pattern Int -> Pattern Int -> (Pattern a -> Pattern a) -> Patter instance Parse (Pattern Int -> Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a) where parser = - $(fromTidal "stutWith") <|> - $(fromTidal "echoWith") + $(fromTidal "stutWith") + <|> $(fromTidal "echoWith") instance Parse (Pattern Time -> Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a) where parser = $(fromTidal "whenmod") @@ -1007,8 +1077,6 @@ instance Parse (Pattern Time -> Pattern Time -> (Pattern a -> Pattern a) -> Patt instance Parse ((ControlPattern -> ControlPattern) -> (ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern -> ControlPattern) where parser = $(fromTidal "contrast") - - -- * -> * -> * -> * -> * -> * instance Parse (Pattern Time -> Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a) where diff --git a/tidal-parse/test/Sound/Tidal/TidalParseTest.hs b/tidal-parse/test/Sound/Tidal/TidalParseTest.hs index 4d071313..ec60b1bd 100644 --- a/tidal-parse/test/Sound/Tidal/TidalParseTest.hs +++ b/tidal-parse/test/Sound/Tidal/TidalParseTest.hs @@ -2,20 +2,21 @@ module Sound.Tidal.TidalParseTest where -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) +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 [] parsesTo :: String -> ControlPattern -> Property parsesTo str p = x `shouldBe` y - where x = query . stripContext <$> parseTidal str <*> Right (State (Arc 0 16) Map.empty) - y = Right $ queryArc (stripContext p) (Arc 0 16) + where + x = query . stripContext <$> parseTidal str <*> Right (State (Arc 0 16) Map.empty) + y = Right $ queryArc (stripContext p) (Arc 0 16) causesParseError :: String -> Property causesParseError str = isLeft (parseTidal str :: Either String ControlPattern) `shouldBe` True @@ -23,7 +24,6 @@ causesParseError str = isLeft (parseTidal str :: Either String ControlPattern) ` run :: Microspec () run = describe "parseTidal" $ do - it "parses the empty string as silence" $ "" `parsesTo` silence @@ -43,10 +43,10 @@ run = "s \"bd cp\"" `parsesTo` s "bd cp" it "parses a very simple single 's' pattern with a same line comment" $ - "s \"bd cp\" -- comment " `parsesTo` s "bd cp" + "s \"bd cp\" -- comment " `parsesTo` s "bd cp" it "parses a very simple single 's' pattern with a multi line comment" $ - "s \"bd cp\" {- \n comment -}" `parsesTo` s "bd cp" + "s \"bd cp\" {- \n comment -}" `parsesTo` s "bd cp" it "parses a very simple single 'sound' pattern" $ "sound \"bd cp\"" `parsesTo` sound "bd cp" @@ -75,24 +75,24 @@ run = "s \"bd cp\" # pan \"0 1\"" `parsesTo` (s "bd cp" # pan "0 1") it "parses three merged patterns" $ - "s \"bd cp\" # pan \"0 1\" # gain \"0.5 0.7\"" `parsesTo` - (s "bd cp" # pan "0 1" # gain "0.5 0.7") + "s \"bd cp\" # pan \"0 1\" # gain \"0.5 0.7\"" + `parsesTo` (s "bd cp" # pan "0 1" # gain "0.5 0.7") it "parses three merged patterns, everything in brackets" $ - "(s \"bd cp\" # pan \"0 1\" # gain \"0.5 0.7\")" `parsesTo` - ((s "bd cp" # pan "0 1" # gain "0.5 0.7")) + "(s \"bd cp\" # pan \"0 1\" # gain \"0.5 0.7\")" + `parsesTo` ((s "bd cp" # pan "0 1" # gain "0.5 0.7")) it "parses three merged patterns, everything in muliple layers of brackets" $ - "(((s \"bd cp\" # pan \"0 1\" # gain \"0.5 0.7\")))" `parsesTo` - ((((s "bd cp" # pan "0 1" # gain "0.5 0.7")))) + "(((s \"bd cp\" # pan \"0 1\" # gain \"0.5 0.7\")))" + `parsesTo` ((((s "bd cp" # pan "0 1" # gain "0.5 0.7")))) it "parses three merged patterns with right associative brackets" $ - "s \"bd cp\" # (pan \"0 1\" # gain \"0.5 0.7\")" `parsesTo` - (s "bd cp" # (pan "0 1" # gain "0.5 0.7")) + "s \"bd cp\" # (pan \"0 1\" # gain \"0.5 0.7\")" + `parsesTo` (s "bd cp" # (pan "0 1" # gain "0.5 0.7")) it "parses three merged patterns with left associative brackets" $ - "(s \"bd cp\" # pan \"0 1\") # gain \"0.5 0.7\"" `parsesTo` - ((s "bd cp" # pan "0 1") # gain "0.5 0.7") + "(s \"bd cp\" # pan \"0 1\") # gain \"0.5 0.7\"" + `parsesTo` ((s "bd cp" # pan "0 1") # gain "0.5 0.7") it "parses simple patterns in brackets applied to ParamPattern functions" $ "s (\"bd cp\")" `parsesTo` (s ("bd cp")) @@ -137,12 +137,12 @@ run = "(rev) $ s \"bd cp\"" `parsesTo` ((rev) $ s "bd cp") it "parses jux transformations with transformations in brackets" $ - "jux (rev) $ s \"arpy*8\" # up \"0 2 3 5 3 5 7 8\"" `parsesTo` - (jux (rev) $ s "arpy*8" # up "0 2 3 5 3 5 7 8") + "jux (rev) $ s \"arpy*8\" # up \"0 2 3 5 3 5 7 8\"" + `parsesTo` (jux (rev) $ s "arpy*8" # up "0 2 3 5 3 5 7 8") it "parses jux transformations with transformations not in brackets" $ - "jux rev $ s \"arpy*8\" # up \"0 2 3 5 3 5 7 8\"" `parsesTo` - (jux rev $ s "arpy*8" # up "0 2 3 5 3 5 7 8") + "jux rev $ s \"arpy*8\" # up \"0 2 3 5 3 5 7 8\"" + `parsesTo` (jux rev $ s "arpy*8" # up "0 2 3 5 3 5 7 8") it "doesn't parse when a transformation requiring an argument is provided without parens or $ to jux" $ causesParseError "jux fast 2 $ s \"bd*4 cp\"" @@ -157,141 +157,141 @@ run = "(every 2 (fast 2) $ s \"arpy*8\") # up (\"[0 4 7 2,16 12 12 16]\" - \"<0 3 5 7>\")" `parsesTo` ((every 2 (fast 2) $ s "arpy*8") # up ("[0 4 7 2,16 12 12 16]" - "<0 3 5 7>")) it "parses a fast transformation applied to a simple (ie. non-param) pattern" $ - "up (fast 2 \"<0 2 3 5>\")" `parsesTo` - (up (fast 2 "<0 2 3 5>")) + "up (fast 2 \"<0 2 3 5>\")" + `parsesTo` (up (fast 2 "<0 2 3 5>")) it "parses a partially-applied pattern transformation spread over patterns" $ - "spread (fast) [2,1,1.5] $ s \"bd sn cp sn\"" `parsesTo` - (spread (fast) [2,1,1.5] $ s "bd sn cp sn") + "spread (fast) [2,1,1.5] $ s \"bd sn cp sn\"" + `parsesTo` (spread (fast) [2, 1, 1.5] $ s "bd sn cp sn") it "parses a binary Num function spread over a simple Num pattern" $ - "n (spread (+) [2,3,4] \"1 2 3\")" `parsesTo` - (n (spread (+) [2,3,4] "1 2 3")) + "n (spread (+) [2,3,4] \"1 2 3\")" + `parsesTo` (n (spread (+) [2, 3, 4] "1 2 3")) it "parses an $ application spread over partially applied transformations of a non-Control Pattern" $ - "n (spread ($) [density 2, rev, slow 2] $ \"1 2 3 4\")" `parsesTo` - (n (spread ($) [density 2, rev, slow 2] $ "1 2 3 4")) + "n (spread ($) [density 2, rev, slow 2] $ \"1 2 3 4\")" + `parsesTo` (n (spread ($) [density 2, rev, slow 2] $ "1 2 3 4")) it "parses an $ application spread over transformations of a control pattern" $ - "spread ($) [fast 2,fast 4] $ s \"bd cp\"" `parsesTo` - (spread ($) [fast 2,fast 4] $ s "bd cp") + "spread ($) [fast 2,fast 4] $ s \"bd cp\"" + `parsesTo` (spread ($) [fast 2, fast 4] $ s "bd cp") it "parses functions spread over transformations of a control pattern, via spreadf" $ - "spreadf [fast 2,fast 4] $ s \"bd cp\"" `parsesTo` - (spreadf [fast 2,fast 4] $ s "bd cp") + "spreadf [fast 2,fast 4] $ s \"bd cp\"" + `parsesTo` (spreadf [fast 2, fast 4] $ s "bd cp") it "parses an $ application spread over partially applied transformations of a Control Pattern" $ - "spread ($) [density 2, rev, slow 2, striate 3] $ sound \"[bd*2 [~ bd]] [sn future]*2 cp jvbass*4\"" `parsesTo` - (spread ($) [density 2, rev, slow 2, striate 3] $ sound "[bd*2 [~ bd]] [sn future]*2 cp jvbass*4") + "spread ($) [density 2, rev, slow 2, striate 3] $ sound \"[bd*2 [~ bd]] [sn future]*2 cp jvbass*4\"" + `parsesTo` (spread ($) [density 2, rev, slow 2, striate 3] $ sound "[bd*2 [~ bd]] [sn future]*2 cp jvbass*4") it "parses an off transformation" $ - "off 0.125 (fast 2) $ s \"bd sn cp glitch\"" `parsesTo` - (off 0.125 (fast 2) $ s "bd sn cp glitch") + "off 0.125 (fast 2) $ s \"bd sn cp glitch\"" + `parsesTo` (off 0.125 (fast 2) $ s "bd sn cp glitch") it "parses a pattern rotation operator (1)" $ - "0.25 <~ (s \"bd sn cp glitch\")" `parsesTo` - (0.25 <~ (s "bd sn cp glitch")) + "0.25 <~ (s \"bd sn cp glitch\")" + `parsesTo` (0.25 <~ (s "bd sn cp glitch")) it "parses a pattern rotation operator (2)" $ - "0.25 <~ s \"bd sn cp glitch\"" `parsesTo` - (0.25 <~ s "bd sn cp glitch") + "0.25 <~ s \"bd sn cp glitch\"" + `parsesTo` (0.25 <~ s "bd sn cp glitch") it "parses a pattern rotation operator (3)" $ - "\"0.25 0.125 0 0.5\" <~ s \"bd sn cp glitch\"" `parsesTo` - ("0.25 0.125 0 0.5" <~ s "bd sn cp glitch") + "\"0.25 0.125 0 0.5\" <~ s \"bd sn cp glitch\"" + `parsesTo` ("0.25 0.125 0 0.5" <~ s "bd sn cp glitch") it "parses a pattern rotation operator (3) applied to a transformation with $" $ - "fast 4 $ \"<0 [0.125,0.25]>\" <~ s \"bd cp sn glitch:2\"" `parsesTo` - (fast 4 $ "<0 [0.125,0.25]>" <~ s "bd cp sn glitch:2") + "fast 4 $ \"<0 [0.125,0.25]>\" <~ s \"bd cp sn glitch:2\"" + `parsesTo` (fast 4 $ "<0 [0.125,0.25]>" <~ s "bd cp sn glitch:2") it "parses a left section transformation of a controlpattern" $ - "every 2 (s \"arpy*8\" #) $ s \"drum\"" `parsesTo` - (every 2 (s "arpy*8" #) $ s "drum") + "every 2 (s \"arpy*8\" #) $ s \"drum\"" + `parsesTo` (every 2 (s "arpy*8" #) $ s "drum") it "parses a right section transformation of a controlpattern" $ - "every 2 (# n \"3 4\") $ s \"drum\"" `parsesTo` - (every 2 (# n "3 4") $ s "drum") + "every 2 (# n \"3 4\") $ s \"drum\"" + `parsesTo` (every 2 (# n "3 4") $ s "drum") it "parses right sections in a list with spread" $ - "spread ($) [(# n \"4 5 6 7\"),(# n \"0 1 2 3\")] $ s \"drum*4\"" `parsesTo` - (spread ($) [(# n "4 5 6 7"),(# n "0 1 2 3")] $ s "drum*4") + "spread ($) [(# n \"4 5 6 7\"),(# n \"0 1 2 3\")] $ s \"drum*4\"" + `parsesTo` (spread ($) [(# n "4 5 6 7"), (# n "0 1 2 3")] $ s "drum*4") it "parses pattern merges spread with #" $ - "spread (#) [n \"4 5 6 7\",n \"0 1 2 3\"] $ s \"drum*4\"" `parsesTo` - (spread (#) [n "4 5 6 7",n "0 1 2 3"] $ s "drum*4") + "spread (#) [n \"4 5 6 7\",n \"0 1 2 3\"] $ s \"drum*4\"" + `parsesTo` (spread (#) [n "4 5 6 7", n "0 1 2 3"] $ s "drum*4") it "parses a left section pattern rotation operator in an every expression" $ - "every 2 (0.0625 ~>) $ (0.5 ~>) $ s \"snare\"" `parsesTo` - (every 2 (0.0625 ~>) $ (0.5 ~>) $ s "snare") + "every 2 (0.0625 ~>) $ (0.5 ~>) $ s \"snare\"" + `parsesTo` (every 2 (0.0625 ~>) $ (0.5 ~>) $ s "snare") it "parses a right section |> operator in an every expression" $ - "every 2 (|> speed \"2\") $ sound \"arpy*4\" |> speed \"1\"" `parsesTo` - (every 2 (|> speed "2") $ sound "arpy*4" |> speed "1") + "every 2 (|> speed \"2\") $ sound \"arpy*4\" |> speed \"1\"" + `parsesTo` (every 2 (|> speed "2") $ sound "arpy*4" |> speed "1") it "parses a complex expression with multiple every, left sections and |>" $ - "every 3 (|- note \"3\") $ every 2 (|+ up \"5\") $ sound \"arpy*4\" |> note \"0 2 4 5\"" `parsesTo` - (every 3 (|- note "3") $ every 2 (|+ up "5") $ sound "arpy*4" |> note "0 2 4 5") + "every 3 (|- note \"3\") $ every 2 (|+ up \"5\") $ sound \"arpy*4\" |> note \"0 2 4 5\"" + `parsesTo` (every 3 (|- note "3") $ every 2 (|+ up "5") $ sound "arpy*4" |> note "0 2 4 5") it "parses an expression with run" $ - "up (run 12) # sound \"arpy\"" `parsesTo` - (up (Tidal.run 12) # sound "arpy") + "up (run 12) # sound \"arpy\"" + `parsesTo` (up (Tidal.run 12) # sound "arpy") it "parses an expression with range" $ - "sound \"bd*8 sn*8\" # speed (range 1 3 $ tri)" `parsesTo` - (sound "bd*8 sn*8" # speed (range 1 3 $ tri)) + "sound \"bd*8 sn*8\" # speed (range 1 3 $ tri)" + `parsesTo` (sound "bd*8 sn*8" # speed (range 1 3 $ tri)) it "parses a rotation operator with BP pattern as left argument" $ - "\"[0 0.25]/4\" <~ (sound \"bd*2 cp*2 hh sn\")" `parsesTo` - ("[0 0.25]/4" <~ (sound "bd*2 cp*2 hh sn")) + "\"[0 0.25]/4\" <~ (sound \"bd*2 cp*2 hh sn\")" + `parsesTo` ("[0 0.25]/4" <~ (sound "bd*2 cp*2 hh sn")) it "parses a sometimesBy application with a right section" $ - "sometimesBy 0.75 (# crush 4) $ sound \"bd arpy sn ~\"" `parsesTo` - (sometimesBy 0.75 (# crush 4) $ sound "bd arpy sn ~") + "sometimesBy 0.75 (# crush 4) $ sound \"bd arpy sn ~\"" + `parsesTo` (sometimesBy 0.75 (# crush 4) $ sound "bd arpy sn ~") it "parses a whenmod application" $ - "whenmod 8 6 (rev) $ sound \"bd*2 arpy*2 cp hh*4\"" `parsesTo` - (whenmod 8 6 (rev) $ sound "bd*2 arpy*2 cp hh*4") + "whenmod 8 6 (rev) $ sound \"bd*2 arpy*2 cp hh*4\"" + `parsesTo` (whenmod 8 6 (rev) $ sound "bd*2 arpy*2 cp hh*4") it "parses a complex example with const" $ - "every 12 (const $ sound \"bd*4 sn*2\") $ sound \"bd sn bass2 sn\"" `parsesTo` - (every 12 (const $ sound "bd*4 sn*2") $ sound "bd sn bass2 sn") + "every 12 (const $ sound \"bd*4 sn*2\") $ sound \"bd sn bass2 sn\"" + `parsesTo` (every 12 (const $ sound "bd*4 sn*2") $ sound "bd sn bass2 sn") it "parses an example with fastcat" $ - "fastcat [sound \"bd sn:2\" # vowel \"[a o]/2\", sound \"casio casio:1 casio:2*2\"]" `parsesTo` - (fastcat [sound "bd sn:2" # vowel "[a o]/2",sound "casio casio:1 casio:2*2"]) + "fastcat [sound \"bd sn:2\" # vowel \"[a o]/2\", sound \"casio casio:1 casio:2*2\"]" + `parsesTo` (fastcat [sound "bd sn:2" # vowel "[a o]/2", sound "casio casio:1 casio:2*2"]) it "parses an example with stack" $ - "stack [s \"bd cp\",s \"arpy*8\"]" `parsesTo` - (stack [s "bd cp",s "arpy*8"]) + "stack [s \"bd cp\",s \"arpy*8\"]" + `parsesTo` (stack [s "bd cp", s "arpy*8"]) it "parses an example with samples and cut" $ - "sound (samples \"arpy*8\" (run 8)) # speed \"0.25\" # cut \"1\"" `parsesTo` - (sound (samples "arpy*8" (Tidal.run 8)) # speed "0.25" # cut "1") + "sound (samples \"arpy*8\" (run 8)) # speed \"0.25\" # cut \"1\"" + `parsesTo` (sound (samples "arpy*8" (Tidal.run 8)) # speed "0.25" # cut "1") it "parses an example with sew" $ - "sound \"cp*16\" |+| gain (sew \"t(3,8)\" \"1*8\" \"0.75*8\")" `parsesTo` - (sound "cp*16" |+| gain (sew "t(3,8)" "1*8" "0.75*8")) + "sound \"cp*16\" |+| gain (sew \"t(3,8)\" \"1*8\" \"0.75*8\")" + `parsesTo` (sound "cp*16" |+| gain (sew "t(3,8)" "1*8" "0.75*8")) it "parses an example with stutWith" $ - "stutWith 16 0.125 (|* gain 0.9) $ s \"bass:2/2\"" `parsesTo` - (stutWith 16 0.125 (|* gain 0.9) $ s "bass:2/2") + "stutWith 16 0.125 (|* gain 0.9) $ s \"bass:2/2\"" + `parsesTo` (stutWith 16 0.125 (|* gain 0.9) $ s "bass:2/2") it "parses an example with choose and a chords from Sound.Tidal.Chords" $ - "s \"arpy*8\" # note (choose major)" `parsesTo` - (s "arpy*8" # note (Tidal.choose major)) + "s \"arpy*8\" # note (choose major)" + `parsesTo` (s "arpy*8" # note (Tidal.choose major)) it "parses an example with the SemiGroup operator" $ - "s \"bd*4\" <> s \"cp*5\"" `parsesTo` - (s "bd*4" <> s "cp*5") + "s \"bd*4\" <> s \"cp*5\"" + `parsesTo` (s "bd*4" <> s "cp*5") it "parses an example with sseq" $ - "s (sseq \"tink\" \"xx x\")" `parsesTo` - (s (sseq "tink" "xx x")) + "s (sseq \"tink\" \"xx x\")" + `parsesTo` (s (sseq "tink" "xx x")) it "parses an example with sseq'" $ - "s (sseq' [\"tink\",\"feel\"] \"01 0\")" `parsesTo` - (s (sseq' ["tink","feel"] "01 0")) + "s (sseq' [\"tink\",\"feel\"] \"01 0\")" + `parsesTo` (s (sseq' ["tink", "feel"] "01 0")) it "parses an example with sseqs" $ - "s (sseqs [(\"tink\",\" x x\"),(\"feel\", \"x x \")])" `parsesTo` - (s (sseqs [("tink"," x x"),("feel", "x x ")])) + "s (sseqs [(\"tink\",\" x x\"),(\"feel\", \"x x \")])" + `parsesTo` (s (sseqs [("tink", " x x"), ("feel", "x x ")])) diff --git a/tidal-parse/test/Test.hs b/tidal-parse/test/Test.hs index 35748607..3931b24e 100644 --- a/tidal-parse/test/Test.hs +++ b/tidal-parse/test/Test.hs @@ -1,8 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -import Test.Microspec - import Sound.Tidal.TidalParseTest +import Test.Microspec main :: IO () main = microspec $ do From 8d7823aebb7f2742cdbcb69fe53a352628d78927 Mon Sep 17 00:00:00 2001 From: alex Date: Mon, 27 Jan 2025 17:07:28 +0100 Subject: [PATCH 03/12] run again with latest ormolu --- bench/Memory/Main.hs | 10 +- bench/Memory/Tidal/Inputs.hs | 40 +- bench/Memory/Tidal/UIB.hs | 18 +- bench/Speed/Main.hs | 12 +- bench/Speed/Tidal/CoreB.hs | 82 +- bench/Speed/Tidal/Inputs.hs | 39 +- bench/Speed/Tidal/PatternB.hs | 57 +- bench/Speed/Tidal/UIB.hs | 30 +- bin/generate-params.hs | 703 ++++++++++-------- bin/params-header.hs | 56 +- main/Main.hs | 198 +++-- old/bin/rip.hs | 102 +-- old/sync/list-ports.hs | 46 +- old/tests/test.hs | 53 +- src/Sound/Tidal/Boot.hs | 68 +- src/Sound/Tidal/Chords.hs | 104 +-- src/Sound/Tidal/Control.hs | 7 +- src/Sound/Tidal/Core.hs | 67 +- src/Sound/Tidal/Params.hs | 119 +-- src/Sound/Tidal/ParseBP.hs | 40 +- src/Sound/Tidal/Pattern.hs | 29 +- src/Sound/Tidal/Scales.hs | 160 ++-- src/Sound/Tidal/Show.hs | 12 +- src/Sound/Tidal/Stream/Listen.hs | 12 +- src/Sound/Tidal/Stream/Process.hs | 42 +- src/Sound/Tidal/Stream/Target.hs | 10 +- src/Sound/Tidal/Stream/UI.hs | 2 +- src/Sound/Tidal/Time.hs | 10 +- src/Sound/Tidal/UI.hs | 108 +-- src/Sound/Tidal/Utils.hs | 14 +- test/Sound/Tidal/PatternTest.hs | 9 +- test/Sound/Tidal/UITest.hs | 3 +- test/Test.hs | 9 +- test/TestUtils.hs | 34 +- test/dontcrash.hs | 54 +- tidal-listener/Setup.hs | 1 + tidal-listener/app/Main.hs | 2 +- tidal-listener/src/Sound/Tidal/Hint.hs | 142 ++-- tidal-listener/src/Sound/Tidal/Listener.hs | 121 +-- .../src/Sound/Tidal/Listener/Command.hs | 80 +- .../src/Sound/Tidal/Listener/Config.hs | 221 +++--- .../src/Sound/Tidal/Listener/Parse.hs | 37 +- tidal-listener/src/Sound/Tidal/Tidali.hs | 93 ++- tidal-parse/src/Sound/Tidal/Parse.hs | 117 +-- vis/Sound/Tidal/Cycle.hs | 388 +++++----- vis/Sound/Tidal/Vis.hs | 87 ++- vis/Sound/Tidal/Vis2.hs | 149 ++-- vis/examples/example.hs | 81 +- 48 files changed, 2008 insertions(+), 1870 deletions(-) diff --git a/bench/Memory/Main.hs b/bench/Memory/Main.hs index 83b84254..9cca0af9 100644 --- a/bench/Memory/Main.hs +++ b/bench/Memory/Main.hs @@ -1,10 +1,10 @@ -module Main where +module Main where -import Weigh import Tidal.UIB +import Weigh -main :: IO () -main = - mainWith $ do +main :: IO () +main = + mainWith $ do euclidB fixB diff --git a/bench/Memory/Tidal/Inputs.hs b/bench/Memory/Tidal/Inputs.hs index 463d8ca9..59a3b786 100644 --- a/bench/Memory/Tidal/Inputs.hs +++ b/bench/Memory/Tidal/Inputs.hs @@ -2,11 +2,11 @@ module Tidal.Inputs where -import Sound.Tidal.Pattern +import Sound.Tidal.Control import Sound.Tidal.Core -import Sound.Tidal.ParseBP() import Sound.Tidal.Params -import Sound.Tidal.Control +import Sound.Tidal.ParseBP () +import Sound.Tidal.Pattern import Sound.Tidal.UI import Weigh @@ -15,19 +15,19 @@ columns = setColumns [Case, Allocated, Max, Live, GCs] {- Pattern inputs -} xs3 :: [Time] -xs3 = [1..10000] +xs3 = [1 .. 10000] xs4 :: [Time] -xs4 = [1..100000] +xs4 = [1 .. 100000] xs5 :: [Time] -xs5 = [1..1000000] +xs5 = [1 .. 1000000] xs6 :: [Time] -xs6 = [1..10000000] +xs6 = [1 .. 10000000] xsA :: [Time] -xsA = [500000..1500000] +xsA = [500000 .. 1500000] catPattSmall :: [Pattern Time] catPattSmall = pure <$> xs3 @@ -72,18 +72,18 @@ fixArg1 = pF "cc64" 1 fixArg2 :: ControlPattern fixArg2 = - fix ( # crush 4 ) (pF "cc65" 1) - $ fix ( stut' 4 (0.125/4) ( + up "1" )) (pF "cc66" 1) - $ fix ( |*| speed "-1" ) (pF "cc67" 1) - $ fix ( (# delaytime 0.125).(# delay 0.5)) (pF "cc68" 1) - $ fix ( # coarse 12) (pF "cc69" 1) - $ s "[808bd:1(3,8), dr(7,8)]" - # pF "cc64" (cF 0 "64") - # pF "cc65" (cF 0 "65") - # pF "cc66" (cF 0 "66") - # pF "cc67" (cF 0 "67") - # pF "cc68" (cF 0 "68") - #  pF "cc69" (cF 0 "69") + fix (# crush 4) (pF "cc65" 1) $ + fix (stut' 4 (0.125 / 4) (+ up "1")) (pF "cc66" 1) $ + fix (|*| speed "-1") (pF "cc67" 1) $ + fix ((# delaytime 0.125) . (# delay 0.5)) (pF "cc68" 1) $ + fix (# coarse 12) (pF "cc69" 1) $ + s "[808bd:1(3,8), dr(7,8)]" + # pF "cc64" (cF 0 "64") + # pF "cc65" (cF 0 "65") + # pF "cc66" (cF 0 "66") + # pF "cc67" (cF 0 "67") + # pF "cc68" (cF 0 "68") + # pF "cc69" (cF 0 "69") {- Euclid inputs -} ecA1 :: [Pattern Int] diff --git a/bench/Memory/Tidal/UIB.hs b/bench/Memory/Tidal/UIB.hs index 9d416d2e..a35c17fa 100644 --- a/bench/Memory/Tidal/UIB.hs +++ b/bench/Memory/Tidal/UIB.hs @@ -1,19 +1,19 @@ -module Tidal.UIB where +module Tidal.UIB where -import Weigh -import Tidal.Inputs import Sound.Tidal.Context +import Tidal.Inputs +import Weigh -fixB :: Weigh () -fixB = +fixB :: Weigh () +fixB = wgroup "fix weigh" $ do columns func "fix 1" (fix (fast 2) fixArg1) fixArg2 -euclidB :: Weigh () -euclidB = - wgroup "euclid" $ do - columns +euclidB :: Weigh () +euclidB = + wgroup "euclid" $ do + columns func "euclid" (euclid (head ecA1) (head $ drop 1 ecA1)) ecA2 func "euclidFull" (euclidFull (head ecA1) (head $ drop 1 ecA1) ecA2) ecA2 func "euclidBool" (_euclidBool 1) 100000 diff --git a/bench/Speed/Main.hs b/bench/Speed/Main.hs index 5d4c8f46..30bfcd93 100644 --- a/bench/Speed/Main.hs +++ b/bench/Speed/Main.hs @@ -1,22 +1,22 @@ module Main where -import Criterion.Main -import Tidal.PatternB +import Criterion.Main import Tidal.CoreB +import Tidal.PatternB import Tidal.UIB -patternBs :: [IO ()] +patternBs :: [IO ()] patternBs = defaultMain <$> [withQueryTimeB, withQueryArcB, withResultArcB, withQueryTimeB, subArcB] -coreBs :: [IO ()] +coreBs :: [IO ()] coreBs = defaultMain <$> [fromListB, stackB, appendB, concatB, _fastB] uiBs :: [IO ()] uiBs = defaultMain <$> [euclidB, fixB] main :: IO () -main = do - _ <- sequence coreBs +main = do + _ <- sequence coreBs _ <- sequence patternBs _ <- sequence uiBs return () diff --git a/bench/Speed/Tidal/CoreB.hs b/bench/Speed/Tidal/CoreB.hs index fa6964ca..855c8855 100644 --- a/bench/Speed/Tidal/CoreB.hs +++ b/bench/Speed/Tidal/CoreB.hs @@ -1,50 +1,60 @@ -module Tidal.CoreB where +module Tidal.CoreB where -import Criterion.Main -import Tidal.Inputs +import Criterion.Main +import Sound.Tidal.Core import Sound.Tidal.Pattern -import Sound.Tidal.Core +import Tidal.Inputs _fastB :: [Benchmark] -_fastB = - [ bgroup "_fast" [ - bench "_fast < 0" $ whnf (_fast (-2)) pattApp2 - , bench "_fast > 0" $ whnf (_fast (toTime $ 10^6)) (cat catPattBig) ] +_fastB = + [ bgroup + "_fast" + [ bench "_fast < 0" $ whnf (_fast (-2)) pattApp2, + bench "_fast > 0" $ whnf (_fast (toTime $ 10 ^ 6)) (cat catPattBig) + ] ] -concatB :: [Benchmark] -concatB = - [ bgroup "concat" [ - bench "fastCat 10^3" $ whnf fastCat catPattSmall - , bench "fastCat 10^4" $ whnf fastCat catPattMed - , bench "fastCat 10^5" $ whnf fastCat catPattMedB - , bench "fastCat 10^6" $ whnf fastCat catPattBig - , bench "timeCat 10^5" $ whnf timeCat timeCatMed - , bench "timeCat 10^6" $ whnf timeCat timeCatBig ] +concatB :: [Benchmark] +concatB = + [ bgroup + "concat" + [ bench "fastCat 10^3" $ whnf fastCat catPattSmall, + bench "fastCat 10^4" $ whnf fastCat catPattMed, + bench "fastCat 10^5" $ whnf fastCat catPattMedB, + bench "fastCat 10^6" $ whnf fastCat catPattBig, + bench "timeCat 10^5" $ whnf timeCat timeCatMed, + bench "timeCat 10^6" $ whnf timeCat timeCatBig + ] ] fromListB :: [Benchmark] -fromListB = - [ bgroup "fromList" [ - bench "fromList" $ whnf fromList xs6 - , bench "fromList nf" $ nf fromList xs6 - , bench "fastFromList 10^3" $ whnf fastFromList xs3 - , bench "fastFromList 10^4" $ whnf fastFromList xs4 - , bench "fastFromList 10^5" $ whnf fastFromList xs5 - , bench "fastFromList 10^6" $ whnf fastFromList xs6 - , bench "fastFromList 10^6 nf" $ nf fastFromList xs6 ] +fromListB = + [ bgroup + "fromList" + [ bench "fromList" $ whnf fromList xs6, + bench "fromList nf" $ nf fromList xs6, + bench "fastFromList 10^3" $ whnf fastFromList xs3, + bench "fastFromList 10^4" $ whnf fastFromList xs4, + bench "fastFromList 10^5" $ whnf fastFromList xs5, + bench "fastFromList 10^6" $ whnf fastFromList xs6, + bench "fastFromList 10^6 nf" $ nf fastFromList xs6 + ] ] -appendB :: [Benchmark] -appendB = - [ bgroup "append" [ - bench "append" $ whnf (append pattApp1) pattApp2 - , bench "fastAppend" $ whnf (fastAppend pattApp1) pattApp2 ] +appendB :: [Benchmark] +appendB = + [ bgroup + "append" + [ bench "append" $ whnf (append pattApp1) pattApp2, + bench "fastAppend" $ whnf (fastAppend pattApp1) pattApp2 + ] ] -stackB :: [Benchmark] -stackB = - [ bgroup "stack" [ - bench "overlay" $ whnf (overlay pattApp1) pattApp2 - , bench "stack" $ whnf stack catPattBig ] +stackB :: [Benchmark] +stackB = + [ bgroup + "stack" + [ bench "overlay" $ whnf (overlay pattApp1) pattApp2, + bench "stack" $ whnf stack catPattBig + ] ] diff --git a/bench/Speed/Tidal/Inputs.hs b/bench/Speed/Tidal/Inputs.hs index 44aea4e9..e4792055 100644 --- a/bench/Speed/Tidal/Inputs.hs +++ b/bench/Speed/Tidal/Inputs.hs @@ -2,27 +2,27 @@ module Tidal.Inputs where -import Sound.Tidal.Pattern import Sound.Tidal.Core -import Sound.Tidal.ParseBP() import Sound.Tidal.Params +import Sound.Tidal.ParseBP () +import Sound.Tidal.Pattern import Sound.Tidal.UI {- Pattern inputs -} xs3 :: [Time] -xs3 = [1..10000] +xs3 = [1 .. 10000] xs4 :: [Time] -xs4 = [1..100000] +xs4 = [1 .. 100000] xs5 :: [Time] -xs5 = [1..1000000] +xs5 = [1 .. 1000000] xs6 :: [Time] -xs6 = [1..10000000] +xs6 = [1 .. 10000000] xsA :: [Time] -xsA = [500000..1500000] +xsA = [500000 .. 1500000] catPattSmall :: [Pattern Time] catPattSmall = pure <$> xs3 @@ -67,18 +67,19 @@ fixArg1 = pF "cc64" 1 fixArg2 :: ControlPattern fixArg2 = - fix ( # crush 4 ) (pF "cc65" 1) - -- $ fix ( stut' 4 (0.125/4) ( + up "1" )) (pF "cc66" 1) - $ fix ( |*| speed "-1" ) (pF "cc67" 1) - $ fix ( (# delaytime 0.125).(# delay 0.5)) (pF "cc68" 1) - $ fix ( # coarse 12) (pF "cc69" 1) - $ s "[808bd:1(3,8), dr(7,8)]" - # pF "cc64" (cF 0 "64") - # pF "cc65" (cF 0 "65") - # pF "cc66" (cF 0 "66") - # pF "cc67" (cF 0 "67") - # pF "cc68" (cF 0 "68") - #  pF "cc69" (cF 0 "69") + fix (# crush 4) (pF "cc65" 1) + -- fix ( stut' 4 (0.125/4) ( + up "1" )) (pF "cc66" 1) + $ + fix (|*| speed "-1") (pF "cc67" 1) $ + fix ((# delaytime 0.125) . (# delay 0.5)) (pF "cc68" 1) $ + fix (# coarse 12) (pF "cc69" 1) $ + s "[808bd:1(3,8), dr(7,8)]" + # pF "cc64" (cF 0 "64") + # pF "cc65" (cF 0 "65") + # pF "cc66" (cF 0 "66") + # pF "cc67" (cF 0 "67") + # pF "cc68" (cF 0 "68") + # pF "cc69" (cF 0 "69") {- Euclid inputs -} ecA1 :: [Pattern Int] diff --git a/bench/Speed/Tidal/PatternB.hs b/bench/Speed/Tidal/PatternB.hs index aafecd8f..07896172 100644 --- a/bench/Speed/Tidal/PatternB.hs +++ b/bench/Speed/Tidal/PatternB.hs @@ -1,45 +1,56 @@ -module Tidal.PatternB where +module Tidal.PatternB where import Criterion.Main -import Tidal.Inputs import Sound.Tidal.Pattern +import Tidal.Inputs + +arc1 = Arc 3 5 -arc1 = Arc 3 5 arc2 = Arc 4 6 + arc3 = Arc 0 1 + arc4 = Arc 1 2 -withQueryTimeB :: [Benchmark] -withQueryTimeB = - [ bgroup "withQueryTime" [ - bench "wqt whnf" $ whnf withQueryTime (*2) - , bench "wqt2 whnf" $ whnf withQueryTime (+1) - , bench "wqt nf" $ nf withQueryTime (*2) ] +withQueryTimeB :: [Benchmark] +withQueryTimeB = + [ bgroup + "withQueryTime" + [ bench "wqt whnf" $ whnf withQueryTime (* 2), + bench "wqt2 whnf" $ whnf withQueryTime (+ 1), + bench "wqt nf" $ nf withQueryTime (* 2) + ] ] withResultArcB :: [Benchmark] -withResultArcB = - [ bgroup "withResultArc" [ - bench "wqa med" $ whnf (withResultArc arcFunc) wqaMed - , bench "wqa big" $ whnf (withResultArc arcFunc) wqaBig ] +withResultArcB = + [ bgroup + "withResultArc" + [ bench "wqa med" $ whnf (withResultArc arcFunc) wqaMed, + bench "wqa big" $ whnf (withResultArc arcFunc) wqaBig + ] ] withQueryArcB :: [Benchmark] -withQueryArcB = - [ bgroup "withQueryArc" [ - bench "wqa med" $ whnf (withQueryArc arcFunc) wqaMed - , bench "wqa big" $ whnf (withQueryArc arcFunc) wqaBig ] +withQueryArcB = + [ bgroup + "withQueryArc" + [ bench "wqa med" $ whnf (withQueryArc arcFunc) wqaMed, + bench "wqa big" $ whnf (withQueryArc arcFunc) wqaBig + ] ] subArcB :: [Benchmark] -subArcB = - [ bgroup "subArc" [ - bench "intersecting" $ whnf (subArc arc1) arc2 - , bench "non-intersecting" $ whnf (subArc arc3) arc4 ] +subArcB = + [ bgroup + "subArc" + [ bench "intersecting" $ whnf (subArc arc1) arc2, + bench "non-intersecting" $ whnf (subArc arc3) arc4 + ] ] -sectB :: Benchmark +sectB :: Benchmark sectB = bench "sect" $ whnf (sect arc1) arc2 -hullB :: Benchmark +hullB :: Benchmark hullB = bench "hull" $ whnf (hull arc1) arc2 diff --git a/bench/Speed/Tidal/UIB.hs b/bench/Speed/Tidal/UIB.hs index 3f41cdd3..8136d5fe 100644 --- a/bench/Speed/Tidal/UIB.hs +++ b/bench/Speed/Tidal/UIB.hs @@ -1,22 +1,26 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} -module Tidal.UIB where +module Tidal.UIB where import Criterion.Main -import Tidal.Inputs import Sound.Tidal.Context +import Tidal.Inputs fixB :: [Benchmark] -fixB = - [ bgroup "fix" [ - bench "fix whnf" $ whnf (fix (fast 2) fixArg1) fixArg2 - , bench "fix nf" $ nf (fix (fast 2) fixArg1) fixArg2 ] +fixB = + [ bgroup + "fix" + [ bench "fix whnf" $ whnf (fix (fast 2) fixArg1) fixArg2, + bench "fix nf" $ nf (fix (fast 2) fixArg1) fixArg2 + ] ] -euclidB :: [Benchmark] -euclidB = - [ bgroup "euclid" [ - bench "euclid" $ whnf (euclid (head ecA1) (head $ drop 1 ecA1)) ecA2 - , bench "euclidFull" $ whnf (euclidFull (head ecA1) (head $ drop 1 ecA1) ecA2) ecA2 - , bench "euclidBool" $ whnf (_euclidBool 1) 100000] +euclidB :: [Benchmark] +euclidB = + [ bgroup + "euclid" + [ bench "euclid" $ whnf (euclid (head ecA1) (head $ drop 1 ecA1)) ecA2, + bench "euclidFull" $ whnf (euclidFull (head ecA1) (head $ drop 1 ecA1) ecA2) ecA2, + bench "euclidBool" $ whnf (_euclidBool 1) 100000 + ] ] diff --git a/bin/generate-params.hs b/bin/generate-params.hs index 58745996..536c70b8 100755 --- a/bin/generate-params.hs +++ b/bin/generate-params.hs @@ -3,8 +3,8 @@ -- This can be run with e.g.: -- runhaskell generate-params.hs > ../src/Sound/Tidal/Params.hs -import Data.List import Data.Function +import Data.List import System.IO toType :: String -> String @@ -22,332 +22,397 @@ toFunc "note" = "pN" toFunc "[word8]" = "pX" main :: IO () -main = do header - putStr controls - putStr "\n\n\n-- aliases\n\n" - putStr aliases +main = do + header + putStr controls + putStr "\n\n\n-- aliases\n\n" + putStr aliases header :: IO () -header = do x <- openFile "params-header.hs" ReadMode - y <- hGetContents x - putStr y - -controls = intercalate "\n" $ map fs $ sortBy (compare `on` (\(_,x,_) -> x)) genericParams - where fs x = control x ++ bus x - control (t, name, desc) = - concat ["-- | " ++ desc ++ "\n", - name, " :: ", toType t, " -> ControlPattern\n", - name, " = ", toFunc t, " \"", name, "\"\n", - name, "Take :: String -> [Double] -> ControlPattern\n", - name, "Take name xs = pStateListF \"",name,"\" name xs\n", - counters t name - ] - counters "note" name = counters "f" name - counters "i" name = counters "f" name - counters "f" name = concat [name, "Count :: String -> ControlPattern\n", - name, "Count name = pStateF \"",name,"\" name (maybe 0 (+1))\n", - name, "CountTo :: String -> Pattern Double -> Pattern ValueMap\n", - name, "CountTo name ipat = innerJoin $ (\\i -> pStateF \"",name,"\" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat\n\n" - ] - counters _ _ = "" - bus (t,name,desc) | elem name nobus = concat [ - name, "bus :: Pattern Int -> ", toType t, " -> ControlPattern\n", - name, "bus _ _ = error $ \"Control parameter '" ++ name ++ "' can't be sent to a bus.\"\n" - ] - | otherwise = - concat [name, "bus :: Pattern Int -> ", toType t, " -> ControlPattern\n", - name, "bus busid pat = (", toFunc t, " \"", name, "\" pat) # (pI \"^", name, "\" busid)\n", - name, "recv :: Pattern Int -> ControlPattern\n", - name, "recv busid = pI \"^", name, "\" busid\n" - ] +header = do + x <- openFile "params-header.hs" ReadMode + y <- hGetContents x + putStr y -aliases = intercalate "\n" $ map fs $ sortBy (flip compare `on` (\(_,x,_) -> x)) aliasParams - where fs (t, from, to) = - concat [from, " :: ", toType t, " -> ControlPattern\n", - from, " = ", to, "\n", - if elem to nobus - then "" - else concat [ - from, "bus :: Pattern Int -> ", toType t, " -> ControlPattern\n", - from, "bus = ", to, "bus\n", - from, "recv :: Pattern Int -> ControlPattern\n", - from, "recv = ", to, "recv\n" - ] - ] +controls = intercalate "\n" $ map fs $ sortBy (compare `on` (\(_, x, _) -> x)) genericParams + where + fs x = control x ++ bus x + control (t, name, desc) = + concat + [ "-- | " ++ desc ++ "\n", + name, + " :: ", + toType t, + " -> ControlPattern\n", + name, + " = ", + toFunc t, + " \"", + name, + "\"\n", + name, + "Take :: String -> [Double] -> ControlPattern\n", + name, + "Take name xs = pStateListF \"", + name, + "\" name xs\n", + counters t name + ] + counters "note" name = counters "f" name + counters "i" name = counters "f" name + counters "f" name = + concat + [ name, + "Count :: String -> ControlPattern\n", + name, + "Count name = pStateF \"", + name, + "\" name (maybe 0 (+1))\n", + name, + "CountTo :: String -> Pattern Double -> Pattern ValueMap\n", + name, + "CountTo name ipat = innerJoin $ (\\i -> pStateF \"", + name, + "\" name (maybe 0 ((`mod'` i) . (+1)))) <$> ipat\n\n" + ] + counters _ _ = "" + bus (t, name, desc) + | elem name nobus = + concat + [ name, + "bus :: Pattern Int -> ", + toType t, + " -> ControlPattern\n", + name, + "bus _ _ = error $ \"Control parameter '" ++ name ++ "' can't be sent to a bus.\"\n" + ] + | otherwise = + concat + [ name, + "bus :: Pattern Int -> ", + toType t, + " -> ControlPattern\n", + name, + "bus busid pat = (", + toFunc t, + " \"", + name, + "\" pat) # (pI \"^", + name, + "\" busid)\n", + name, + "recv :: Pattern Int -> ControlPattern\n", + name, + "recv busid = pI \"^", + name, + "\" busid\n" + ] -nobus = ["midinote", - "note", - "n", - "octave", - "begin", - "end", - "sustain", - "legato", - "loop", - "unit", - "length", - "fadeTime", - "fadeInTime", - "speed", - "endSpeed", - "gain", - "overgain", - "channel", - "lag", - "offset", - "sound", - "array", - "midichan", - "control", - "ccn", - "ccv", - "polyTouch", - "midibend", - "miditouch", - "ctlNum", - "frameRate", - "frames", - "hours", - "midicmd", - "minutes", - "progNum", - "seconds", - "songPtr", - "uid", - "val", - "timescale", - "timescalewin", - "accelerate" +aliases = intercalate "\n" $ map fs $ sortBy (flip compare `on` (\(_, x, _) -> x)) aliasParams + where + fs (t, from, to) = + concat + [ from, + " :: ", + toType t, + " -> ControlPattern\n", + from, + " = ", + to, + "\n", + if elem to nobus + then "" + else + concat + [ from, + "bus :: Pattern Int -> ", + toType t, + " -> ControlPattern\n", + from, + "bus = ", + to, + "bus\n", + from, + "recv :: Pattern Int -> ControlPattern\n", + from, + "recv = ", + to, + "recv\n" + ] ] +nobus = + [ "midinote", + "note", + "n", + "octave", + "begin", + "end", + "sustain", + "legato", + "loop", + "unit", + "length", + "fadeTime", + "fadeInTime", + "speed", + "endSpeed", + "gain", + "overgain", + "channel", + "lag", + "offset", + "sound", + "array", + "midichan", + "control", + "ccn", + "ccv", + "polyTouch", + "midibend", + "miditouch", + "ctlNum", + "frameRate", + "frames", + "hours", + "midicmd", + "minutes", + "progNum", + "seconds", + "songPtr", + "uid", + "val", + "timescale", + "timescalewin", + "accelerate" + ] + genericParams :: [(String, String, String)] -genericParams = [ - ("s", "toArg", "for internal sound routing"), - ("f", "from", "for internal sound routing"), - ("f", "to", "for internal sound routing"), - ("f", "accelerate", "a pattern of numbers that speed up (or slow down) samples while they play."), - ("f", "amp", "like @gain@, but linear."), - ("f", "attack", "a pattern of numbers to specify the attack time (in seconds) of an envelope applied to each sample."), - ("f", "bandf", "a pattern of numbers from 0 to 1. Sets the center frequency of the band-pass filter."), - ("f", "bandq", "a pattern of anumbers from 0 to 1. Sets the q-factor of the band-pass filter."), - ("f", "begin", "a pattern of numbers from 0 to 1. Skips the beginning of each sample, e.g. `0.25` to cut off the first quarter from each sample."), - ("f", "legato", "controls the amount of overlap between two adjacent sounds"), - ("f", "clhatdecay", ""), - ("f", "crush", "bit crushing, a pattern of numbers from 1 (for drastic reduction in bit-depth) to 16 (for barely no reduction)."), - ("f", "coarse", "fake-resampling, a pattern of numbers for lowering the sample rate, i.e. 1 for original 2 for half, 3 for a third and so on."), - ("i", "channel", "choose the channel the pattern is sent to in superdirt"), - ("i", "cut", "In the style of classic drum-machines, `cut` will stop a playing sample as soon as another samples with in same cutgroup is to be played. An example would be an open hi-hat followed by a closed one, essentially muting the open."), - ("f", "cutoff", "a pattern of numbers from 0 to 1. Applies the cutoff frequency of the low-pass filter."), - ("f", "cutoffegint", ""), - ("f", "decay", ""), - ("f", "delay", "a pattern of numbers from 0 to 1. Sets the level of the delay signal."), - ("f", "delayfeedback", "a pattern of numbers from 0 to 1. Sets the amount of delay feedback."), - ("f", "delaytime", "a pattern of numbers from 0 to 1. Sets the length of the delay."), - ("f", "detune", ""), - ("f", "djf", "DJ filter, below 0.5 is low pass filter, above is high pass filter."), - ("f", "dry", "when set to `1` will disable all reverb for this pattern. See `room` and `size` for more information about reverb."), - ("f", "end", "the same as `begin`, but cuts the end off samples, shortening them; e.g. `0.75` to cut off the last quarter of each sample."), - ("f", "fadeTime", "Used when using begin/end or chop/striate and friends, to change the fade out time of the 'grain' envelope."), - ("f", "fadeInTime", "As with fadeTime, but controls the fade in time of the grain envelope. Not used if the grain begins at position 0 in the sample."), - ("f", "freq", ""), - ("f", "gain", "a pattern of numbers that specify volume. Values less than 1 make the sound quieter. Values greater than 1 make the sound louder. For the linear equivalent, see @amp@."), - ("f", "gate", ""), - ("f", "hatgrain", ""), - ("f", "hcutoff", "a pattern of numbers from 0 to 1. Applies the cutoff frequency of the high-pass filter. Also has alias @hpf@"), - ("f", "hold", "a pattern of numbers to specify the hold time (in seconds) of an envelope applied to each sample. Only takes effect if `attack` and `release` are also specified."), - ("f", "hresonance", "a pattern of numbers from 0 to 1. Applies the resonance of the high-pass filter. Has alias @hpq@"), - ("f", "lagogo", ""), - ("f", "lclap", ""), - ("f", "lclaves", ""), - ("f", "lclhat", ""), - ("f", "lcrash", ""), - ("f", "leslie", ""), - ("f", "lrate", ""), - ("f", "lsize", ""), - ("f", "lfo", ""), - ("f", "lfocutoffint", ""), - ("f", "lfodelay", ""), - ("f", "lfoint", ""), - ("f", "lfopitchint", ""), - ("f", "lfoshape", ""), - ("f", "lfosync", ""), - ("f", "lhitom", ""), - ("f", "lkick", ""), - ("f", "llotom", ""), - ("f", "lock", "A pattern of numbers. Specifies whether delaytime is calculated relative to cps. When set to 1, delaytime is a direct multiple of a cycle."), - ("f", "loop", "loops the sample (from `begin` to `end`) the specified number of times."), - ("f", "lophat", ""), - ("f", "lsnare", ""), - ("f", "metatune", "A pattern of numbers. Specifies whether the pitch of played samples should be tuned relative to their pitch metadata, if it exists. When set to 1, pitch metadata is applied. When set to 0, pitch metadata is ignored."), - ("note", "n", "The note or sample number to choose for a synth or sampleset"), - ("note", "note", "The note or pitch to play a sound or synth with"), - ("f", "degree", ""), - ("f", "mtranspose", ""), - ("f", "ctranspose", ""), - ("f", "harmonic", ""), - ("f", "stepsPerOctave", ""), - ("f", "octaveR", ""), - ("f", "nudge", "Nudges events into the future by the specified number of seconds. Negative numbers work up to a point as well (due to internal latency)"), - ("i", "octave", ""), - ("f", "offset", ""), - ("f", "ophatdecay", ""), - ("i", "orbit", "a pattern of numbers. An `orbit` is a global parameter context for patterns. Patterns with the same orbit will share hardware output bus offset and global effects, e.g. reverb and delay. The maximum number of orbits is specified in the superdirt startup, numbers higher than maximum will wrap around."), - ("f", "overgain", ""), - ("f", "overshape", ""), - ("f", "pan", "a pattern of numbers between 0 and 1, from left to right (assuming stereo), once round a circle (assuming multichannel)"), - ("f", "panspan", "a pattern of numbers between -inf and inf, which controls how much multichannel output is fanned out (negative is backwards ordering)"), - ("f", "pansplay", "a pattern of numbers between 0.0 and 1.0, which controls the multichannel spread range (multichannel only)"), - ("f", "panwidth", "a pattern of numbers between 0.0 and inf, which controls how much each channel is distributed over neighbours (multichannel only)"), - ("f", "panorient", "a pattern of numbers between -1.0 and 1.0, which controls the relative position of the centre pan in a pair of adjacent speakers (multichannel only)"), - ("f", "pitch1", ""), - ("f", "pitch2", ""), - ("f", "pitch3", ""), - ("f", "portamento", ""), - ("f", "rate", "used in SuperDirt softsynths as a control rate or 'speed'"), - ("f", "release", "a pattern of numbers to specify the release time (in seconds) of an envelope applied to each sample."), - ("f", "resonance", "a pattern of numbers from 0 to 1. Specifies the resonance of the low-pass filter."), - ("f", "room", "a pattern of numbers from 0 to 1. Sets the level of reverb."), - ("f", "sagogo", ""), - ("f", "sclap", ""), - ("f", "sclaves", ""), - ("f", "scrash", ""), - ("f", "semitone", ""), - ("f", "shape", "wave shaping distortion, a pattern of numbers from 0 for no distortion up to 1 for loads of distortion."), - ("f", "size", "a pattern of numbers from 0 to 1. Sets the perceptual size (reverb time) of the `room` to be used in reverb."), - ("f", "slide", ""), - ("f", "speed", "a pattern of numbers which changes the speed of sample playback, i.e. a cheap way of changing pitch. Negative values will play the sample backwards!"), - ("f", "squiz", ""), - ("f", "stutterdepth", ""), - ("f", "stuttertime", ""), - ("f", "sustain", ""), - ("f", "timescale", "time stretch amount"), - ("f", "timescalewin", "time stretch window size"), - ("f", "tomdecay", ""), - ("s", "unit", "used in conjunction with `speed`, accepts values of \"r\" (rate, default behavior), \"c\" (cycles), or \"s\" (seconds). Using `unit \"c\"` means `speed` will be interpreted in units of cycles, e.g. `speed \"1\"` means samples will be stretched to fill a cycle. Using `unit \"s\"` means the playback speed will be adjusted so that the duration is the number of seconds specified by `speed`."), - ("f", "velocity", ""), - ("f", "vcfegint", ""), - ("f", "vcoegint", ""), - ("f", "voice", ""), - ("s", "vowel", "formant filter to make things sound like vowels, a pattern of either `a`, `e`, `i`, `o` or `u`. Use a rest (`~`) for no effect."), - ("f", "waveloss", ""), - ("f", "dur", ""), - ("f", "modwheel", ""), - ("f", "expression", ""), - ("f", "sustainpedal", ""), - ("f", "tremolodepth", "Tremolo Audio DSP effect | params are 'tremolorate' and 'tremolodepth'"), - ("f", "tremolorate", "Tremolo Audio DSP effect | params are 'tremolorate' and 'tremolodepth'"), - ("f", "phaserdepth", "Phaser Audio DSP effect | params are 'phaserrate' and 'phaserdepth'"), - ("f", "phaserrate", "Phaser Audio DSP effect | params are 'phaserrate' and 'phaserdepth'"), - ("f", "fshift", "frequency shifter"), - ("f", "fshiftnote", "frequency shifter"), - ("f", "fshiftphase", "frequency shifter"), - ("f", "triode", "tube distortion"), - ("f", "krush", "shape/bass enhancer"), - ("f", "kcutoff", ""), - ("f", "octer", "octaver effect"), - ("f", "octersub", "octaver effect"), - ("f", "octersubsub", "octaver effect"), - ("f", "ring", "ring modulation"), - ("f", "ringf", "ring modulation"), - ("f", "ringdf", "ring modulation"), - ("f", "distort", "noisy fuzzy distortion"), - ("f", "freeze", "Spectral freeze"), - ("f", "xsdelay", ""), - ("f", "tsdelay", ""), - ("f", "real", "Spectral conform"), - ("f", "imag", ""), - ("f", "enhance", "Spectral enhance"), - ("f", "partials", ""), - ("f", "comb", "Spectral comb"), - ("f", "smear", "Spectral smear"), - ("f", "scram", "Spectral scramble"), - ("f", "binshift", "Spectral binshift"), - ("f", "hbrick", "High pass sort of spectral filter"), - ("f", "lbrick", "Low pass sort of spectral filter"), - -- SuperDirt MIDI Params - ("[word8]", "array", ""), - ("f", "midichan", ""), - ("f", "control", ""), - ("f", "ccn", ""), - ("f", "ccv", ""), - ("f", "polyTouch", ""), - ("f", "midibend", ""), - ("f", "miditouch", ""), - ("f", "ctlNum", ""), - ("f", "frameRate", ""), - ("f", "frames", ""), - ("f", "hours", ""), - ("s", "midicmd", ""), - ("f", "minutes", ""), - ("f", "progNum", ""), - ("f", "seconds", ""), - ("f", "songPtr", ""), - ("f", "uid", ""), - ("f", "val", ""), - ("f", "cps", "") - ] - ++ (map (\i -> ("f", "slider" ++ show i, "")) [0 .. 15]) - ++ (map (\i -> ("f", "button" ++ show i, "")) [0 .. 15]) +genericParams = + [ ("s", "toArg", "for internal sound routing"), + ("f", "from", "for internal sound routing"), + ("f", "to", "for internal sound routing"), + ("f", "accelerate", "a pattern of numbers that speed up (or slow down) samples while they play."), + ("f", "amp", "like @gain@, but linear."), + ("f", "attack", "a pattern of numbers to specify the attack time (in seconds) of an envelope applied to each sample."), + ("f", "bandf", "a pattern of numbers from 0 to 1. Sets the center frequency of the band-pass filter."), + ("f", "bandq", "a pattern of anumbers from 0 to 1. Sets the q-factor of the band-pass filter."), + ("f", "begin", "a pattern of numbers from 0 to 1. Skips the beginning of each sample, e.g. `0.25` to cut off the first quarter from each sample."), + ("f", "legato", "controls the amount of overlap between two adjacent sounds"), + ("f", "clhatdecay", ""), + ("f", "crush", "bit crushing, a pattern of numbers from 1 (for drastic reduction in bit-depth) to 16 (for barely no reduction)."), + ("f", "coarse", "fake-resampling, a pattern of numbers for lowering the sample rate, i.e. 1 for original 2 for half, 3 for a third and so on."), + ("i", "channel", "choose the channel the pattern is sent to in superdirt"), + ("i", "cut", "In the style of classic drum-machines, `cut` will stop a playing sample as soon as another samples with in same cutgroup is to be played. An example would be an open hi-hat followed by a closed one, essentially muting the open."), + ("f", "cutoff", "a pattern of numbers from 0 to 1. Applies the cutoff frequency of the low-pass filter."), + ("f", "cutoffegint", ""), + ("f", "decay", ""), + ("f", "delay", "a pattern of numbers from 0 to 1. Sets the level of the delay signal."), + ("f", "delayfeedback", "a pattern of numbers from 0 to 1. Sets the amount of delay feedback."), + ("f", "delaytime", "a pattern of numbers from 0 to 1. Sets the length of the delay."), + ("f", "detune", ""), + ("f", "djf", "DJ filter, below 0.5 is low pass filter, above is high pass filter."), + ("f", "dry", "when set to `1` will disable all reverb for this pattern. See `room` and `size` for more information about reverb."), + ("f", "end", "the same as `begin`, but cuts the end off samples, shortening them; e.g. `0.75` to cut off the last quarter of each sample."), + ("f", "fadeTime", "Used when using begin/end or chop/striate and friends, to change the fade out time of the 'grain' envelope."), + ("f", "fadeInTime", "As with fadeTime, but controls the fade in time of the grain envelope. Not used if the grain begins at position 0 in the sample."), + ("f", "freq", ""), + ("f", "gain", "a pattern of numbers that specify volume. Values less than 1 make the sound quieter. Values greater than 1 make the sound louder. For the linear equivalent, see @amp@."), + ("f", "gate", ""), + ("f", "hatgrain", ""), + ("f", "hcutoff", "a pattern of numbers from 0 to 1. Applies the cutoff frequency of the high-pass filter. Also has alias @hpf@"), + ("f", "hold", "a pattern of numbers to specify the hold time (in seconds) of an envelope applied to each sample. Only takes effect if `attack` and `release` are also specified."), + ("f", "hresonance", "a pattern of numbers from 0 to 1. Applies the resonance of the high-pass filter. Has alias @hpq@"), + ("f", "lagogo", ""), + ("f", "lclap", ""), + ("f", "lclaves", ""), + ("f", "lclhat", ""), + ("f", "lcrash", ""), + ("f", "leslie", ""), + ("f", "lrate", ""), + ("f", "lsize", ""), + ("f", "lfo", ""), + ("f", "lfocutoffint", ""), + ("f", "lfodelay", ""), + ("f", "lfoint", ""), + ("f", "lfopitchint", ""), + ("f", "lfoshape", ""), + ("f", "lfosync", ""), + ("f", "lhitom", ""), + ("f", "lkick", ""), + ("f", "llotom", ""), + ("f", "lock", "A pattern of numbers. Specifies whether delaytime is calculated relative to cps. When set to 1, delaytime is a direct multiple of a cycle."), + ("f", "loop", "loops the sample (from `begin` to `end`) the specified number of times."), + ("f", "lophat", ""), + ("f", "lsnare", ""), + ("f", "metatune", "A pattern of numbers. Specifies whether the pitch of played samples should be tuned relative to their pitch metadata, if it exists. When set to 1, pitch metadata is applied. When set to 0, pitch metadata is ignored."), + ("note", "n", "The note or sample number to choose for a synth or sampleset"), + ("note", "note", "The note or pitch to play a sound or synth with"), + ("f", "degree", ""), + ("f", "mtranspose", ""), + ("f", "ctranspose", ""), + ("f", "harmonic", ""), + ("f", "stepsPerOctave", ""), + ("f", "octaveR", ""), + ("f", "nudge", "Nudges events into the future by the specified number of seconds. Negative numbers work up to a point as well (due to internal latency)"), + ("i", "octave", ""), + ("f", "offset", ""), + ("f", "ophatdecay", ""), + ("i", "orbit", "a pattern of numbers. An `orbit` is a global parameter context for patterns. Patterns with the same orbit will share hardware output bus offset and global effects, e.g. reverb and delay. The maximum number of orbits is specified in the superdirt startup, numbers higher than maximum will wrap around."), + ("f", "overgain", ""), + ("f", "overshape", ""), + ("f", "pan", "a pattern of numbers between 0 and 1, from left to right (assuming stereo), once round a circle (assuming multichannel)"), + ("f", "panspan", "a pattern of numbers between -inf and inf, which controls how much multichannel output is fanned out (negative is backwards ordering)"), + ("f", "pansplay", "a pattern of numbers between 0.0 and 1.0, which controls the multichannel spread range (multichannel only)"), + ("f", "panwidth", "a pattern of numbers between 0.0 and inf, which controls how much each channel is distributed over neighbours (multichannel only)"), + ("f", "panorient", "a pattern of numbers between -1.0 and 1.0, which controls the relative position of the centre pan in a pair of adjacent speakers (multichannel only)"), + ("f", "pitch1", ""), + ("f", "pitch2", ""), + ("f", "pitch3", ""), + ("f", "portamento", ""), + ("f", "rate", "used in SuperDirt softsynths as a control rate or 'speed'"), + ("f", "release", "a pattern of numbers to specify the release time (in seconds) of an envelope applied to each sample."), + ("f", "resonance", "a pattern of numbers from 0 to 1. Specifies the resonance of the low-pass filter."), + ("f", "room", "a pattern of numbers from 0 to 1. Sets the level of reverb."), + ("f", "sagogo", ""), + ("f", "sclap", ""), + ("f", "sclaves", ""), + ("f", "scrash", ""), + ("f", "semitone", ""), + ("f", "shape", "wave shaping distortion, a pattern of numbers from 0 for no distortion up to 1 for loads of distortion."), + ("f", "size", "a pattern of numbers from 0 to 1. Sets the perceptual size (reverb time) of the `room` to be used in reverb."), + ("f", "slide", ""), + ("f", "speed", "a pattern of numbers which changes the speed of sample playback, i.e. a cheap way of changing pitch. Negative values will play the sample backwards!"), + ("f", "squiz", ""), + ("f", "stutterdepth", ""), + ("f", "stuttertime", ""), + ("f", "sustain", ""), + ("f", "timescale", "time stretch amount"), + ("f", "timescalewin", "time stretch window size"), + ("f", "tomdecay", ""), + ("s", "unit", "used in conjunction with `speed`, accepts values of \"r\" (rate, default behavior), \"c\" (cycles), or \"s\" (seconds). Using `unit \"c\"` means `speed` will be interpreted in units of cycles, e.g. `speed \"1\"` means samples will be stretched to fill a cycle. Using `unit \"s\"` means the playback speed will be adjusted so that the duration is the number of seconds specified by `speed`."), + ("f", "velocity", ""), + ("f", "vcfegint", ""), + ("f", "vcoegint", ""), + ("f", "voice", ""), + ("s", "vowel", "formant filter to make things sound like vowels, a pattern of either `a`, `e`, `i`, `o` or `u`. Use a rest (`~`) for no effect."), + ("f", "waveloss", ""), + ("f", "dur", ""), + ("f", "modwheel", ""), + ("f", "expression", ""), + ("f", "sustainpedal", ""), + ("f", "tremolodepth", "Tremolo Audio DSP effect | params are 'tremolorate' and 'tremolodepth'"), + ("f", "tremolorate", "Tremolo Audio DSP effect | params are 'tremolorate' and 'tremolodepth'"), + ("f", "phaserdepth", "Phaser Audio DSP effect | params are 'phaserrate' and 'phaserdepth'"), + ("f", "phaserrate", "Phaser Audio DSP effect | params are 'phaserrate' and 'phaserdepth'"), + ("f", "fshift", "frequency shifter"), + ("f", "fshiftnote", "frequency shifter"), + ("f", "fshiftphase", "frequency shifter"), + ("f", "triode", "tube distortion"), + ("f", "krush", "shape/bass enhancer"), + ("f", "kcutoff", ""), + ("f", "octer", "octaver effect"), + ("f", "octersub", "octaver effect"), + ("f", "octersubsub", "octaver effect"), + ("f", "ring", "ring modulation"), + ("f", "ringf", "ring modulation"), + ("f", "ringdf", "ring modulation"), + ("f", "distort", "noisy fuzzy distortion"), + ("f", "freeze", "Spectral freeze"), + ("f", "xsdelay", ""), + ("f", "tsdelay", ""), + ("f", "real", "Spectral conform"), + ("f", "imag", ""), + ("f", "enhance", "Spectral enhance"), + ("f", "partials", ""), + ("f", "comb", "Spectral comb"), + ("f", "smear", "Spectral smear"), + ("f", "scram", "Spectral scramble"), + ("f", "binshift", "Spectral binshift"), + ("f", "hbrick", "High pass sort of spectral filter"), + ("f", "lbrick", "Low pass sort of spectral filter"), + -- SuperDirt MIDI Params + ("[word8]", "array", ""), + ("f", "midichan", ""), + ("f", "control", ""), + ("f", "ccn", ""), + ("f", "ccv", ""), + ("f", "polyTouch", ""), + ("f", "midibend", ""), + ("f", "miditouch", ""), + ("f", "ctlNum", ""), + ("f", "frameRate", ""), + ("f", "frames", ""), + ("f", "hours", ""), + ("s", "midicmd", ""), + ("f", "minutes", ""), + ("f", "progNum", ""), + ("f", "seconds", ""), + ("f", "songPtr", ""), + ("f", "uid", ""), + ("f", "val", ""), + ("f", "cps", "") + ] + ++ (map (\i -> ("f", "slider" ++ show i, "")) [0 .. 15]) + ++ (map (\i -> ("f", "button" ++ show i, "")) [0 .. 15]) aliasParams :: [(String, String, String)] aliasParams = - [ - ("s", "s", "sound"), - ("note", "up", "note"), - ("f", "att", "attack"), - ("f", "bpf", "bandf"), - ("f", "bpq", "bandq"), - ("f", "chdecay", "clhatdecay"), - ("f", "ctf", "cutoff"), - ("f", "ctfg", "cutoffegint"), - ("f", "delayfb", "delayfeedback"), - ("f", "dfb", "delayfeedback"), - ("f", "delayt", "delaytime"), - ("f", "dt", "delaytime"), - ("f", "det", "detune"), - ("f", "fadeOutTime", "fadeTime"), - - ("f", "gat", "gate"), - ("f", "hg", "hatgrain"), - ("f", "hpf", "hcutoff"), - ("f", "hpq", "hresonance"), - ("f", "lag", "lagogo"), - ("f", "lbd", "lkick"), - ("f", "lch", "lclhat"), - ("f", "lcl", "lclaves"), - ("f", "lcp", "lclap"), - ("f", "lcr", "lcrash"), - ("f", "lfoc", "lfocutoffint"), - ("f", "lfoi", "lfoint"), - ("f", "lfop", "lfopitchint"), - ("f", "lht", "lhitom"), - ("f", "llt", "llotom"), - ("f", "loh", "lophat"), - ("f", "lpf", "cutoff"), - ("f", "lpq", "resonance"), - ("f", "lsn", "lsnare"), - ("note", "number", "n"), - ("f", "ohdecay", "ophatdecay"), - ("f", "phasdp", "phaserdepth"), - ("f", "phasr", "phaserrate"), - ("f", "pit1", "pitch1"), - ("f", "pit2", "pitch2"), - ("f", "pit3", "pitch3"), - ("f", "por", "portamento"), - ("f", "rel", "release"), - ("f", "sag", "sagogo"), - ("f", "scl", "sclaves"), - ("f", "scp", "sclap"), - ("f", "scr", "scrash"), - ("f", "sz", "size"), - ("f", "sld", "slide"), - ("f", "std", "stutterdepth"), - ("f", "stt", "stuttertime"), - ("f", "sus", "sustain"), - ("f", "tdecay", "tomdecay"), - ("f", "tremdp", "tremolodepth"), - ("f", "tremr", "tremolorate"), - ("f", "vcf", "vcfegint"), - ("f", "vco", "vcoegint"), - ("f", "voi", "voice") + [ ("s", "s", "sound"), + ("note", "up", "note"), + ("f", "att", "attack"), + ("f", "bpf", "bandf"), + ("f", "bpq", "bandq"), + ("f", "chdecay", "clhatdecay"), + ("f", "ctf", "cutoff"), + ("f", "ctfg", "cutoffegint"), + ("f", "delayfb", "delayfeedback"), + ("f", "dfb", "delayfeedback"), + ("f", "delayt", "delaytime"), + ("f", "dt", "delaytime"), + ("f", "det", "detune"), + ("f", "fadeOutTime", "fadeTime"), + ("f", "gat", "gate"), + ("f", "hg", "hatgrain"), + ("f", "hpf", "hcutoff"), + ("f", "hpq", "hresonance"), + ("f", "lag", "lagogo"), + ("f", "lbd", "lkick"), + ("f", "lch", "lclhat"), + ("f", "lcl", "lclaves"), + ("f", "lcp", "lclap"), + ("f", "lcr", "lcrash"), + ("f", "lfoc", "lfocutoffint"), + ("f", "lfoi", "lfoint"), + ("f", "lfop", "lfopitchint"), + ("f", "lht", "lhitom"), + ("f", "llt", "llotom"), + ("f", "loh", "lophat"), + ("f", "lpf", "cutoff"), + ("f", "lpq", "resonance"), + ("f", "lsn", "lsnare"), + ("note", "number", "n"), + ("f", "ohdecay", "ophatdecay"), + ("f", "phasdp", "phaserdepth"), + ("f", "phasr", "phaserrate"), + ("f", "pit1", "pitch1"), + ("f", "pit2", "pitch2"), + ("f", "pit3", "pitch3"), + ("f", "por", "portamento"), + ("f", "rel", "release"), + ("f", "sag", "sagogo"), + ("f", "scl", "sclaves"), + ("f", "scp", "sclap"), + ("f", "scr", "scrash"), + ("f", "sz", "size"), + ("f", "sld", "slide"), + ("f", "std", "stutterdepth"), + ("f", "stt", "stuttertime"), + ("f", "sus", "sustain"), + ("f", "tdecay", "tomdecay"), + ("f", "tremdp", "tremolodepth"), + ("f", "tremr", "tremolorate"), + ("f", "vcf", "vcfegint"), + ("f", "vco", "vcoegint"), + ("f", "voi", "voice") ] diff --git a/bin/params-header.hs b/bin/params-header.hs index 0501b023..28ae1dce 100644 --- a/bin/params-header.hs +++ b/bin/params-header.hs @@ -22,36 +22,37 @@ module Sound.Tidal.Params where along with this library. If not, see . -} +import Data.Fixed (mod') import qualified Data.Map.Strict as Map - -import Sound.Tidal.Pattern -import Sound.Tidal.Core ((#)) -import Sound.Tidal.Utils import Data.Maybe (fromMaybe) import Data.Word (Word8) -import Data.Fixed (mod') +import Sound.Tidal.Core ((#)) +import Sound.Tidal.Pattern +import Sound.Tidal.Utils -- | group multiple params into one grp :: [String -> ValueMap] -> Pattern String -> ControlPattern grp [] _ = empty grp fs p = splitby <$> p - where splitby name = Map.unions $ map (\(v, f) -> f v) $ zip (split name) fs - split :: String -> [String] - split = wordsBy (==':') + where + splitby name = Map.unions $ map (\(v, f) -> f v) $ zip (split name) fs + split :: String -> [String] + split = wordsBy (== ':') mF :: String -> String -> ValueMap -mF name v = fromMaybe Map.empty $ do f <- readMaybe v - return $ Map.singleton name (VF f) +mF name v = fromMaybe Map.empty $ do + f <- readMaybe v + return $ Map.singleton name (VF f) mI :: String -> String -> ValueMap -mI name v = fromMaybe Map.empty $ do i <- readMaybe v - return $ Map.singleton name (VI i) +mI name v = fromMaybe Map.empty $ do + i <- readMaybe v + return $ Map.singleton name (VI i) mS :: String -> String -> ValueMap mS name v = Map.singleton name (VS v) -- | Param makers - pF :: String -> Pattern Double -> ControlPattern pF name = fmap (Map.singleton name . VF) @@ -60,7 +61,7 @@ pI name = fmap (Map.singleton name . VI) pB :: String -> Pattern Bool -> ControlPattern pB name = fmap (Map.singleton name . VB) - + pR :: String -> Pattern Rational -> ControlPattern pR name = fmap (Map.singleton name . VR) @@ -75,18 +76,23 @@ pX name = fmap (Map.singleton name . VX) pStateF :: String -> String -> (Maybe Double -> Double) -> ControlPattern pStateF name sName update = pure $ Map.singleton name $ VState statef - where statef :: ValueMap -> (ValueMap, Value) - statef sMap = (Map.insert sName v sMap, v) - where v = VF $ update $ (Map.lookup sName sMap) >>= getF + where + statef :: ValueMap -> (ValueMap, Value) + statef sMap = (Map.insert sName v sMap, v) + where + v = VF $ update $ (Map.lookup sName sMap) >>= getF pStateList :: String -> String -> [Value] -> ControlPattern pStateList name sName xs = pure $ Map.singleton name $ VState statef - where statef :: ValueMap -> (ValueMap, Value) - statef sMap = (Map.insert sName (VList $ tail looped) sMap, head looped) - where xs' = fromMaybe xs ((Map.lookup sName sMap) >>= getList) - -- do this instead of a cycle, so it can get updated with the a list - looped | null xs' = xs - | otherwise = xs' + where + statef :: ValueMap -> (ValueMap, Value) + statef sMap = (Map.insert sName (VList $ tail looped) sMap, head looped) + where + xs' = fromMaybe xs ((Map.lookup sName sMap) >>= getList) + -- do this instead of a cycle, so it can get updated with the a list + looped + | null xs' = xs + | otherwise = xs' pStateListF :: String -> String -> [Double] -> ControlPattern pStateListF name sName = pStateList name sName . map VF @@ -95,7 +101,6 @@ pStateListS :: String -> String -> [String] -> ControlPattern pStateListS name sName = pStateList name sName . map VS -- | Grouped params - sound :: Pattern String -> ControlPattern sound = grp [mS "s", mF "n"] @@ -123,7 +128,7 @@ midinote = note . (subtract 60 <$>) drum :: Pattern String -> ControlPattern drum = n . (subtract 60 . drumN <$>) -drumN :: Num a => String -> a +drumN :: (Num a) => String -> a drumN "hq" = 27 drumN "sl" = 28 drumN "ps" = 29 @@ -188,4 +193,3 @@ drumN "os" = 87 drumN _ = 0 -- Generated params - diff --git a/main/Main.hs b/main/Main.hs index 5981fe9b..24252fcd 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -19,59 +19,90 @@ You should have received a copy of the GNU General Public License along with this library. If not, see . -} +{-# LANGUAGE LambdaCase #-} +{- + Tidal REPL - mimicking ghci -{-# language PatternSignatures, LambdaCase #-} + Copyright (C) 2021 Johannes Waldmann and contributors + + Forked from: + https://github.com/jwaldmann/safe-tidal-cli/ + + 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 . +-} +{-# LANGUAGE PatternSignatures #-} -import qualified Language.Haskell.Interpreter as I -import qualified Sound.Tidal.Safe.Context as C -import Control.Monad (void) import Control.Exception (throw) -import Control.Monad.IO.Class ( MonadIO(liftIO) ) +import Control.Monad (void) import Control.Monad.Catch - ( SomeException, MonadCatch(catch), catches, Handler(Handler) ) + ( Handler (Handler), + MonadCatch (catch), + SomeException, + catches, + ) +import Control.Monad.IO.Class (MonadIO (liftIO)) -- import qualified Mueval.Resources as MR -import System.Timeout ( timeout ) -import System.IO ( hFlush, stderr, stdout, hPutStrLn, Handle ) + import Data.Char (isSpace) import Data.List (isPrefixOf) +import qualified Language.Haskell.Interpreter as I +import qualified Sound.Tidal.Safe.Context as C +import System.IO (Handle, hFlush, hPutStrLn, stderr, stdout) +import System.Timeout (timeout) -main :: IO() +main :: IO () main = do - -- from BootTidal.hs: - tidal <- C.startTidal - (C.superdirtTarget - { C.oLatency = 0.1, C.oAddress = "127.0.0.1" - , C.oPort = 57120}) - (C.defaultConfig {C.cFrameTimespan = 1/20}) - - void $ I.runInterpreter - $ catch (core tidal) - $ \ (e :: SomeException) -> message stderr $ show e + tidal <- + C.startTidal + ( C.superdirtTarget + { C.oLatency = 0.1, + C.oAddress = "127.0.0.1", + C.oPort = 57120 + } + ) + (C.defaultConfig {C.cFrameTimespan = 1 / 20}) + + void $ + I.runInterpreter $ + catch (core tidal) $ + \(e :: SomeException) -> message stderr $ show e core :: C.Stream -> I.InterpreterT IO () core tidal = do - message stdout "[tidal] starting..." + message stdout "[tidal] starting..." -- more settings at -- https://github.com/tidalcycles/tidali/blob/master/src/Main.hs - I.set [ I.languageExtensions - I.:= [ I.OverloadedStrings ] - , I.installedModulesInScope I.:= False - ] - I.setImports - [ "Prelude" - , "Sound.Tidal.Safe.Context" - , "Sound.Tidal.Safe.Boot" - ] - -- FIXME: replace lazy IO by some streaming mechanism? - message stdout "[tidal] modules loaded..." - input <- liftIO getContents - message stdout "[tidal] ready" - mapM_ (work tidal . unlines) $ blocks $ lines input - message stdout "safe-tidal-cli is done" + I.set + [ I.languageExtensions + I.:= [I.OverloadedStrings], + I.installedModulesInScope I.:= False + ] + I.setImports + [ "Prelude", + "Sound.Tidal.Safe.Context", + "Sound.Tidal.Safe.Boot" + ] + -- FIXME: replace lazy IO by some streaming mechanism? + message stdout "[tidal] modules loaded..." + input <- liftIO getContents + message stdout "[tidal] ready" + mapM_ (work tidal . unlines) $ blocks $ lines input + message stdout "safe-tidal-cli is done" second :: Int -second = 10^6 :: Int +second = 10 ^ 6 :: Int -- | will show at most 10 lines, at most 80 chars per line, -- and run (evaluation and print) for at most 1 second @@ -79,61 +110,64 @@ message :: Handle -> String -> I.InterpreterT IO () message h s = do let safe = unlines . safe_list 20 ["..."] . map (safe_list 120 "...") . lines liftIO $ void $ timeout (1 * second) $ do - hPutStrLn h (safe s) ; hFlush h - + hPutStrLn h (safe s); hFlush h -- | if `length xs <= c`, then `xs`, else `xs <> msg` safe_list :: Int -> [a] -> [a] -> [a] safe_list n msg xs = - let (pre,post) = splitAt n xs - in if null post then pre - else pre <> msg + let (pre, post) = splitAt n xs + in if null post + then pre + else pre <> msg work :: C.Stream -> String -> I.InterpreterT IO () -work tidal contents = - ( if take 2 contents `elem` [ ":t", ":i", ":d", ":s" ] - then do - -- https://github.com/haskell-hint/hint/issues/101 - message stderr $ "not implemented " <> contents - else - I.typeChecksWithDetails contents >>= \ case - Left errs -> throw $ I.WontCompile errs - Right s -> - if s == "Op ()" then do -- execute, print nothing - -- TODO: need timeout for evaluation of pattern: - x <- I.interpret contents (I.as :: C.Op ()) - -- have timeout for execution of pattern: - liftIO $ void $ timeout (1 * second) $ C.exec tidal x - else do -- print type and value - message stdout $ "type : " <> s - if isPrefixOf "IO" s then do - message stderr "cannot show value, will not execute action" - else do - v <- I.eval contents - message stdout $ "value: " <> v - ) - `catches` - [ Handler $ \ (e :: I.InterpreterError) -> - message stderr $ unlines $ case e of - I.UnknownError s -> [ "UnknownError", s ] - I.WontCompile gs -> "WontCompile" : map I.errMsg gs - I.NotAllowed s -> [ "NotAllowed", s ] - I.GhcException s -> [ "GhcException", s ] - , Handler $ \ (e :: SomeException) -> - message stderr $ show e - ] +work tidal contents = + ( if take 2 contents `elem` [":t", ":i", ":d", ":s"] + then do + -- https://github.com/haskell-hint/hint/issues/101 + message stderr $ "not implemented " <> contents + else + I.typeChecksWithDetails contents >>= \case + Left errs -> throw $ I.WontCompile errs + Right s -> + if s == "Op ()" + then do + -- execute, print nothing + -- TODO: need timeout for evaluation of pattern: + x <- I.interpret contents (I.as :: C.Op ()) + -- have timeout for execution of pattern: + liftIO $ void $ timeout (1 * second) $ C.exec tidal x + else do + -- print type and value + message stdout $ "type : " <> s + if isPrefixOf "IO" s + then do + message stderr "cannot show value, will not execute action" + else do + v <- I.eval contents + message stdout $ "value: " <> v + ) + `catches` [ Handler $ \(e :: I.InterpreterError) -> + message stderr $ unlines $ case e of + I.UnknownError s -> ["UnknownError", s] + I.WontCompile gs -> "WontCompile" : map I.errMsg gs + I.NotAllowed s -> ["NotAllowed", s] + I.GhcException s -> ["GhcException", s], + Handler $ \(e :: SomeException) -> + message stderr $ show e + ] -- | Mimicking ghci, where a block is wrapped in `:{` and `:}`, on otherwise empty lines. - blocks :: [String] -> [[String]] blocks [] = [] -blocks (":{":ls) = b:(blocks ls') - where (b, ls') = block ls -blocks (l:ls) = [l]:(blocks ls) +blocks (":{" : ls) = b : (blocks ls') + where + (b, ls') = block ls +blocks (l : ls) = [l] : (blocks ls) block :: [String] -> ([String], [String]) -block [] = ([],[]) -block (":}":ls) = ([],ls) -block (l:ls) = (l:b, ls') - where (b, ls') = block ls - +block [] = ([], []) +block (":}" : ls) = ([], ls) +block (l : ls) = (l : b, ls') + where + (b, ls') = block ls diff --git a/old/bin/rip.hs b/old/bin/rip.hs index 85639d1f..47fb9b1e 100644 --- a/old/bin/rip.hs +++ b/old/bin/rip.hs @@ -1,63 +1,75 @@ ---import Sound.Tidal.Context +-- import Sound.Tidal.Context + +import Control.Concurrent +import GHC.Int +import GHC.Word +import qualified Sound.ALSA.Exception as AlsaExc +import qualified Sound.ALSA.Sequencer as SndSeq import qualified Sound.ALSA.Sequencer.Address as Addr import qualified Sound.ALSA.Sequencer.Client as Client -import qualified Sound.ALSA.Sequencer.Port as Port -import qualified Sound.ALSA.Sequencer.Event as Event -import qualified Sound.ALSA.Sequencer as SndSeq -import qualified Sound.ALSA.Exception as AlsaExc import qualified Sound.ALSA.Sequencer.Connect as Connect -import GHC.Word -import GHC.Int - +import qualified Sound.ALSA.Sequencer.Event as Event +import qualified Sound.ALSA.Sequencer.Port as Port import System.Cmd -import Control.Concurrent import Text.Printf channel = Event.Channel 0 + notes = [12 .. 100] + time = 3 midiport = "24:0" main = - do h <- SndSeq.openDefault SndSeq.Block - Client.setName (h :: SndSeq.T SndSeq.OutputMode) "rip" - c <- Client.getId h - p <- Port.createSimple h "out" - (Port.caps [Port.capRead, Port.capSubsRead]) Port.typeMidiGeneric - conn <- Connect.createTo h p =<< Addr.parse h midiport - sequence_ $ map (play h conn) notes - return () + do + h <- SndSeq.openDefault SndSeq.Block + Client.setName (h :: SndSeq.T SndSeq.OutputMode) "rip" + c <- Client.getId h + p <- + Port.createSimple + h + "out" + (Port.caps [Port.capRead, Port.capSubsRead]) + Port.typeMidiGeneric + conn <- Connect.createTo h p =<< Addr.parse h midiport + sequence_ $ map (play h conn) notes + return () play h conn n = - do let tmpfn = printf "tmp-%03d.wav" n - fn = printf "note-%03d.wav" n - forkIO $ do rawSystem "ecasound" ["-t:" ++ (show time), "-i", "jack,system", "-o", tmpfn] - return () - threadDelay 500000 - Event.outputDirect h $ noteOn conn n 80 - forkIO $ do threadDelay 50000 - Event.outputDirect h $ noteOff conn n - return () - threadDelay $ 1000000 * time - forkIO $ do rawSystem "sox" [tmpfn, fn, "silence", "1", "0", "-55d", "reverse", "silence", "1", "0", "-55d", "reverse"] - rawSystem "rm" [tmpfn] - return () - return () - - + do + let tmpfn = printf "tmp-%03d.wav" n + fn = printf "note-%03d.wav" n + forkIO $ do + rawSystem "ecasound" ["-t:" ++ (show time), "-i", "jack,system", "-o", tmpfn] + return () + threadDelay 500000 + Event.outputDirect h $ noteOn conn n 80 + forkIO $ do + threadDelay 50000 + Event.outputDirect h $ noteOff conn n + return () + threadDelay $ 1000000 * time + forkIO $ do + rawSystem "sox" [tmpfn, fn, "silence", "1", "0", "-55d", "reverse", "silence", "1", "0", "-55d", "reverse"] + rawSystem "rm" [tmpfn] + return () + return () + noteOn :: Connect.T -> Word8 -> Word8 -> Event.T -noteOn conn val vel = - Event.forConnection conn - $ Event.NoteEv Event.NoteOn - $ Event.simpleNote channel - (Event.Pitch (val)) - (Event.Velocity vel) +noteOn conn val vel = + Event.forConnection conn $ + Event.NoteEv Event.NoteOn $ + Event.simpleNote + channel + (Event.Pitch (val)) + (Event.Velocity vel) noteOff :: Connect.T -> Word8 -> Event.T -noteOff conn val = - Event.forConnection conn - $ Event.NoteEv Event.NoteOff - $ Event.simpleNote channel - (Event.Pitch (val)) - (Event.normalVelocity) +noteOff conn val = + Event.forConnection conn $ + Event.NoteEv Event.NoteOff $ + Event.simpleNote + channel + (Event.Pitch (val)) + (Event.normalVelocity) diff --git a/old/sync/list-ports.hs b/old/sync/list-ports.hs index 2f7912a7..9f202572 100644 --- a/old/sync/list-ports.hs +++ b/old/sync/list-ports.hs @@ -1,11 +1,11 @@ -import qualified Sound.ALSA.Sequencer.Client.Info as ClientInfo -import qualified Sound.ALSA.Sequencer.Port.Info as PortInfo +import Control.Monad (join, liftM5) +import qualified Data.EnumSet as EnumSet +import qualified Sound.ALSA.Sequencer as SndSeq import qualified Sound.ALSA.Sequencer.Client as Client +import qualified Sound.ALSA.Sequencer.Client.Info as ClientInfo import qualified Sound.ALSA.Sequencer.Port as Port -import qualified Sound.ALSA.Sequencer as SndSeq -import qualified Data.EnumSet as EnumSet -import Text.Printf (printf, ) -import Control.Monad (liftM5, join, ) +import qualified Sound.ALSA.Sequencer.Port.Info as PortInfo +import Text.Printf (printf) main :: IO () main = do @@ -14,18 +14,22 @@ main = do ClientInfo.queryLoop_ (h :: SndSeq.T SndSeq.OutputMode) $ \cinfo -> do client <- ClientInfo.getClient cinfo PortInfo.queryLoop_ h client $ \pinfo -> do - join $ liftM5 (printf "%3d:%-3d %-32.32s %-24.24s %s\n") - (fmap (\(Client.Cons p) -> p) $ PortInfo.getClient pinfo) - (fmap (\(Port.Cons p) -> p) $ PortInfo.getPort pinfo) - (ClientInfo.getName cinfo) - (PortInfo.getName pinfo) - (do - caps <- PortInfo.getCapability pinfo - let disp (cap, char) = - if EnumSet.disjoint caps cap then ' ' else char - return $ map disp $ - (Port.capRead, 'r') : - (Port.capSubsRead, 'R') : - (Port.capWrite, 'w') : - (Port.capSubsWrite, 'W') : - []) + join $ + liftM5 + (printf "%3d:%-3d %-32.32s %-24.24s %s\n") + (fmap (\(Client.Cons p) -> p) $ PortInfo.getClient pinfo) + (fmap (\(Port.Cons p) -> p) $ PortInfo.getPort pinfo) + (ClientInfo.getName cinfo) + (PortInfo.getName pinfo) + ( do + caps <- PortInfo.getCapability pinfo + let disp (cap, char) = + if EnumSet.disjoint caps cap then ' ' else char + return $ + map disp $ + (Port.capRead, 'r') + : (Port.capSubsRead, 'R') + : (Port.capWrite, 'w') + : (Port.capSubsWrite, 'W') + : [] + ) diff --git a/old/tests/test.hs b/old/tests/test.hs index 7b8357f8..6e7ad2b6 100644 --- a/old/tests/test.hs +++ b/old/tests/test.hs @@ -1,47 +1,50 @@ {-# LANGUAGE OverloadedStrings #-} -import Test.Tasty -- import Test.Tasty.SmallCheck as SC -- import Test.Tasty.QuickCheck as QC -import Test.Tasty.HUnit import Data.List import Data.Ord - import Sound.Tidal.Context +import Test.Tasty +import Test.Tasty.HUnit main = defaultMain tests tests :: TestTree -tests = testGroup "Tests" [basic1, - parser1 - -- patternsOfPatterns - ] - -basic1 = testGroup "fast / slow" - [ - testCase "silence" $ same16 (fast 1.1 silence) (silence :: Pattern Double), - testCase "fast" $ same16 silence (silence :: Pattern Double), - testCase "fast2" $ same16 "bd*128" (rep 128 "bd") - ] - -parser1 = testGroup "subpatterns" - [ - testCase "square" $ same16 ("bd sn" :: Pattern String) ("[bd sn]" :: Pattern String) - ] +tests = + testGroup + "Tests" + [ basic1, + parser1 + -- patternsOfPatterns + ] + +basic1 = + testGroup + "fast / slow" + [ testCase "silence" $ same16 (fast 1.1 silence) (silence :: Pattern Double), + testCase "fast" $ same16 silence (silence :: Pattern Double), + testCase "fast2" $ same16 "bd*128" (rep 128 "bd") + ] + +parser1 = + testGroup + "subpatterns" + [ testCase "square" $ same16 ("bd sn" :: Pattern String) ("[bd sn]" :: Pattern String) + ] patternsOfPatterns = - testGroup "patterns of patterns" - [ - testCase "decimal density" $ same16 (_discretise 0.25 saw) (discretise 0.25 saw) - ] + testGroup + "patterns of patterns" + [ testCase "decimal density" $ same16 (_discretise 0.25 saw) (discretise 0.25 saw) + ] rep :: Int -> String -> Pattern String rep n v = p $ intercalate " " $ take n $ repeat v sameN :: (Eq a, Show a) => String -> Time -> Pattern a -> Pattern a -> Assertion -sameN s n a b = assertEqual s (arc a (0,n)) (arc b (0,n)) +sameN s n a b = assertEqual s (arc a (0, n)) (arc b (0, n)) same16 :: (Eq a, Show a) => Pattern a -> Pattern a -> Assertion same16 = sameN "for 16 cycles," 16 - diff --git a/src/Sound/Tidal/Boot.hs b/src/Sound/Tidal/Boot.hs index 84a29812..41913250 100644 --- a/src/Sound/Tidal/Boot.hs +++ b/src/Sound/Tidal/Boot.hs @@ -136,106 +136,106 @@ mkTidalWith config oscmap = do startStream config oscmap -- | 'hush' then execute the given action. -only :: Tidally => IO () -> IO () +only :: (Tidally) => IO () -> IO () only = (hush >>) -- | See 'Sound.Tidal.Stream.streamReplace'. -p :: Tidally => ID -> ControlPattern -> IO () +p :: (Tidally) => ID -> ControlPattern -> IO () p = streamReplace tidal -- | Silences a specific stream, regardless of ControlPattern input. Useful for rapid muting of streams -_p :: Tidally => ID -> ControlPattern -> IO () +_p :: (Tidally) => ID -> ControlPattern -> IO () _p k _ = streamReplace tidal k silence -- | Silences a specific stream, regardless of ControlPattern input. Useful for rapid muting of streams -p_ :: Tidally => ID -> ControlPattern -> IO () +p_ :: (Tidally) => ID -> ControlPattern -> IO () p_ = _p -- | See 'Sound.Tidal.Stream.streamHush'. -hush :: Tidally => IO () +hush :: (Tidally) => IO () hush = streamHush tidal -panic :: Tidally => IO () +panic :: (Tidally) => IO () panic = hush >> once (sound "superpanic") -- | See 'Sound.Tidal.Stream.streamList'. -list :: Tidally => IO () +list :: (Tidally) => IO () list = streamList tidal -- | See 'Sound.Tidal.Stream.streamMute'. -mute :: Tidally => ID -> IO () +mute :: (Tidally) => ID -> IO () mute = streamMute tidal -- | See 'Sound.Tidal.Stream.streamUnmute'. -unmute :: Tidally => ID -> IO () +unmute :: (Tidally) => ID -> IO () unmute = streamUnmute tidal -- | See 'Sound.Tidal.Stream.streamUnmuteAll'. -unmuteAll :: Tidally => IO () +unmuteAll :: (Tidally) => IO () unmuteAll = streamUnmuteAll tidal -- | See 'Sound.Tidal.Stream.streamUnsoloAll'. -unsoloAll :: Tidally => IO () +unsoloAll :: (Tidally) => IO () unsoloAll = streamUnsoloAll tidal -- | See 'Sound.Tidal.Stream.streamSolo'. -solo :: Tidally => ID -> IO () +solo :: (Tidally) => ID -> IO () solo = streamSolo tidal -- | See 'Sound.Tidal.Stream.streamUnsolo'. -unsolo :: Tidally => ID -> IO () +unsolo :: (Tidally) => ID -> IO () unsolo = streamUnsolo tidal -- | See 'Sound.Tidal.Stream.streamOnce'. -once :: Tidally => ControlPattern -> IO () +once :: (Tidally) => ControlPattern -> IO () once = streamOnce tidal -- | An alias for 'once'. -asap :: Tidally => ControlPattern -> IO () +asap :: (Tidally) => ControlPattern -> IO () asap = once -- | See 'Sound.Tidal.Stream.first'. -first :: Tidally => ControlPattern -> IO () +first :: (Tidally) => ControlPattern -> IO () first = streamFirst tidal -- | See 'Sound.Tidal.Stream.nudgeAll'. -nudgeAll :: Tidally => Double -> IO () +nudgeAll :: (Tidally) => Double -> IO () nudgeAll = streamNudgeAll tidal -- | See 'Sound.Tidal.Stream.streamAll'. -all :: Tidally => (ControlPattern -> ControlPattern) -> IO () +all :: (Tidally) => (ControlPattern -> ControlPattern) -> IO () all = streamAll tidal -- | See 'Sound.Tidal.Stream.resetCycles'. -resetCycles :: Tidally => IO () +resetCycles :: (Tidally) => IO () resetCycles = streamResetCycles tidal -- | See 'Sound.Tidal.Stream.streamSetCycle'. -setCycle :: Tidally => Time -> IO () +setCycle :: (Tidally) => Time -> IO () setCycle = streamSetCycle tidal -- | See 'Sound.Tidal.Params.cps'. -setcps :: Tidally => Pattern Double -> IO () +setcps :: (Tidally) => Pattern Double -> IO () setcps = once . cps -- | See 'Sound.Tidal.Stream.streamGetCPS'. -getcps :: Tidally => IO Time +getcps :: (Tidally) => IO Time getcps = streamGetCPS tidal -- | See 'Sound.Tidal.Stream.streamGetBPM'. -setbpm :: Tidally => Time -> IO () +setbpm :: (Tidally) => Time -> IO () setbpm = streamSetBPM tidal -- | See 'Sound.Tidal.Stream.streamGetBPM'. -getbpm :: Tidally => IO Time +getbpm :: (Tidally) => IO Time getbpm = streamGetBPM tidal -- | See 'Sound.Tidal.Stream.streamGetnow'. -getnow :: Tidally => IO Time +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, 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) @@ -254,7 +254,7 @@ d15 = p 15 d16 = p 16 -- | Rapidly silence 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, _d2, _d3, _d4, _d5, _d6, _d7, _d8, _d9, _d10, _d11, _d12, _d13, _d14, _d15, _d16 :: (Tidally) => ControlPattern -> IO () _d1 = _p 1 _d2 = _p 2 _d3 = _p 3 @@ -273,7 +273,7 @@ _d15 = _p 15 _d16 = _p 16 -- | Rapidly silence 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_, d2_, d3_, d4_, d5_, d6_, d7_, d8_, d9_, d10_, d11_, d12_, d13_, d14_, d15_, d16_ :: (Tidally) => ControlPattern -> IO () d1_ = _d1 d2_ = _d2 d3_ = _d3 @@ -292,25 +292,25 @@ d15_ = _d15 d16_ = _d16 -- | See 'Sound.Tidal.Stream.streamGet'. -getState :: Tidally => String -> IO (Maybe Value) +getState :: (Tidally) => String -> IO (Maybe Value) getState = streamGet tidal -- | See 'Sound.Tidal.Stream.streamSetI'. -setI :: Tidally => String -> Pattern Int -> IO () +setI :: (Tidally) => String -> Pattern Int -> IO () setI = streamSetI tidal -- | See 'Sound.Tidal.Stream.streamSetF'. -setF :: Tidally => String -> Pattern Double -> IO () +setF :: (Tidally) => String -> Pattern Double -> IO () setF = streamSetF tidal -- | See 'Sound.Tidal.Stream.streamSetS'. -setS :: Tidally => String -> Pattern String -> IO () +setS :: (Tidally) => String -> Pattern String -> IO () setS = streamSetS tidal -- | See 'Sound.Tidal.Stream.streamSetR'. -setR :: Tidally => String -> Pattern Rational -> IO () +setR :: (Tidally) => String -> Pattern Rational -> IO () setR = streamSetR tidal -- | See 'Sound.Tidal.Stream.streamSetB'. -setB :: Tidally => String -> Pattern Bool -> IO () +setB :: (Tidally) => String -> Pattern Bool -> IO () setB = streamSetB tidal diff --git a/src/Sound/Tidal/Chords.hs b/src/Sound/Tidal/Chords.hs index 3d4d371f..061d6246 100644 --- a/src/Sound/Tidal/Chords.hs +++ b/src/Sound/Tidal/Chords.hs @@ -25,162 +25,162 @@ import Sound.Tidal.Pattern -- ** Major chords -major :: Num a => [a] +major :: (Num a) => [a] major = [0, 4, 7] -aug :: Num a => [a] +aug :: (Num a) => [a] aug = [0, 4, 8] -six :: Num a => [a] +six :: (Num a) => [a] six = [0, 4, 7, 9] -sixNine :: Num a => [a] +sixNine :: (Num a) => [a] sixNine = [0, 4, 7, 9, 14] -major7 :: Num a => [a] +major7 :: (Num a) => [a] major7 = [0, 4, 7, 11] -major9 :: Num a => [a] +major9 :: (Num a) => [a] major9 = [0, 4, 7, 11, 14] -add9 :: Num a => [a] +add9 :: (Num a) => [a] add9 = [0, 4, 7, 14] -major11 :: Num a => [a] +major11 :: (Num a) => [a] major11 = [0, 4, 7, 11, 14, 17] -add11 :: Num a => [a] +add11 :: (Num a) => [a] add11 = [0, 4, 7, 17] -major13 :: Num a => [a] +major13 :: (Num a) => [a] major13 = [0, 4, 7, 11, 14, 21] -add13 :: Num a => [a] +add13 :: (Num a) => [a] add13 = [0, 4, 7, 21] -- ** Dominant chords -dom7 :: Num a => [a] +dom7 :: (Num a) => [a] dom7 = [0, 4, 7, 10] -dom9 :: Num a => [a] +dom9 :: (Num a) => [a] dom9 = [0, 4, 7, 14] -dom11 :: Num a => [a] +dom11 :: (Num a) => [a] dom11 = [0, 4, 7, 17] -dom13 :: Num a => [a] +dom13 :: (Num a) => [a] dom13 = [0, 4, 7, 21] -sevenFlat5 :: Num a => [a] +sevenFlat5 :: (Num a) => [a] sevenFlat5 = [0, 4, 6, 10] -sevenSharp5 :: Num a => [a] +sevenSharp5 :: (Num a) => [a] sevenSharp5 = [0, 4, 8, 10] -sevenFlat9 :: Num a => [a] +sevenFlat9 :: (Num a) => [a] sevenFlat9 = [0, 4, 7, 10, 13] -nine :: Num a => [a] +nine :: (Num a) => [a] nine = [0, 4, 7, 10, 14] -eleven :: Num a => [a] +eleven :: (Num a) => [a] eleven = [0, 4, 7, 10, 14, 17] -thirteen :: Num a => [a] +thirteen :: (Num a) => [a] thirteen = [0, 4, 7, 10, 14, 17, 21] -- ** Minor chords -minor :: Num a => [a] +minor :: (Num a) => [a] minor = [0, 3, 7] -diminished :: Num a => [a] +diminished :: (Num a) => [a] diminished = [0, 3, 6] -minorSharp5 :: Num a => [a] +minorSharp5 :: (Num a) => [a] minorSharp5 = [0, 3, 8] -minor6 :: Num a => [a] +minor6 :: (Num a) => [a] minor6 = [0, 3, 7, 9] -minorSixNine :: Num a => [a] +minorSixNine :: (Num a) => [a] minorSixNine = [0, 3, 9, 7, 14] -minor7flat5 :: Num a => [a] +minor7flat5 :: (Num a) => [a] minor7flat5 = [0, 3, 6, 10] -minor7 :: Num a => [a] +minor7 :: (Num a) => [a] minor7 = [0, 3, 7, 10] -minor7sharp5 :: Num a => [a] +minor7sharp5 :: (Num a) => [a] minor7sharp5 = [0, 3, 8, 10] -minor7flat9 :: Num a => [a] +minor7flat9 :: (Num a) => [a] minor7flat9 = [0, 3, 7, 10, 13] -minor7sharp9 :: Num a => [a] +minor7sharp9 :: (Num a) => [a] minor7sharp9 = [0, 3, 7, 10, 15] -diminished7 :: Num a => [a] +diminished7 :: (Num a) => [a] diminished7 = [0, 3, 6, 9] -minor9 :: Num a => [a] +minor9 :: (Num a) => [a] minor9 = [0, 3, 7, 10, 14] -minor11 :: Num a => [a] +minor11 :: (Num a) => [a] minor11 = [0, 3, 7, 10, 14, 17] -minor13 :: Num a => [a] +minor13 :: (Num a) => [a] minor13 = [0, 3, 7, 10, 14, 17, 21] -minorMajor7 :: Num a => [a] +minorMajor7 :: (Num a) => [a] minorMajor7 = [0, 3, 7, 11] -- ** Other chords -one :: Num a => [a] +one :: (Num a) => [a] one = [0] -five :: Num a => [a] +five :: (Num a) => [a] five = [0, 7] -sus2 :: Num a => [a] +sus2 :: (Num a) => [a] sus2 = [0, 2, 7] -sus4 :: Num a => [a] +sus4 :: (Num a) => [a] sus4 = [0, 5, 7] -sevenSus2 :: Num a => [a] +sevenSus2 :: (Num a) => [a] sevenSus2 = [0, 2, 7, 10] -sevenSus4 :: Num a => [a] +sevenSus4 :: (Num a) => [a] sevenSus4 = [0, 5, 7, 10] -nineSus4 :: Num a => [a] +nineSus4 :: (Num a) => [a] nineSus4 = [0, 5, 7, 10, 14] -- ** Questionable chords -sevenFlat10 :: Num a => [a] +sevenFlat10 :: (Num a) => [a] sevenFlat10 = [0, 4, 7, 10, 15] -nineSharp5 :: Num a => [a] +nineSharp5 :: (Num a) => [a] nineSharp5 = [0, 1, 13] -minor9sharp5 :: Num a => [a] +minor9sharp5 :: (Num a) => [a] minor9sharp5 = [0, 1, 14] -sevenSharp5flat9 :: Num a => [a] +sevenSharp5flat9 :: (Num a) => [a] sevenSharp5flat9 = [0, 4, 8, 10, 13] -minor7sharp5flat9 :: Num a => [a] +minor7sharp5flat9 :: (Num a) => [a] minor7sharp5flat9 = [0, 3, 8, 10, 13] -elevenSharp :: Num a => [a] +elevenSharp :: (Num a) => [a] elevenSharp = [0, 4, 7, 10, 14, 18] -minor11sharp :: Num a => [a] +minor11sharp :: (Num a) => [a] minor11sharp = [0, 3, 7, 10, 14, 18] -- * Chord functions @@ -212,7 +212,7 @@ minor11sharp = [0, 3, 7, 10, 14, 18] -- This will output @[("dom7",[0,4,7,10])]@ -- -- (You’ll need to run @import Sound.Tidal.Chords@ before using this function.) -chordTable :: Num a => [(String, [a])] +chordTable :: (Num a) => [(String, [a])] chordTable = [ ("major", major), ("maj", major), @@ -351,7 +351,7 @@ chordTable = ] -- | Look up a specific chord: @chordL "minor7"@ returns @(0>1)|[0,3,7,10]@. -chordL :: Num a => Pattern String -> Pattern [a] +chordL :: (Num a) => Pattern String -> Pattern [a] chordL p = (\name -> fromMaybe [] $ lookup name chordTable) <$> p -- | diff --git a/src/Sound/Tidal/Control.hs b/src/Sound/Tidal/Control.hs index 6521e0ae..51fb03e7 100644 --- a/src/Sound/Tidal/Control.hs +++ b/src/Sound/Tidal/Control.hs @@ -53,7 +53,8 @@ _spin copies p = map ( \i -> let offset = toInteger i % toInteger copies - in offset `rotL` p + in offset + `rotL` p # P.pan (pure $ fromRational offset) ) [0 .. (copies - 1)] @@ -461,12 +462,12 @@ stut' :: Pattern Int -> Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> stut' = stutWith -- | Turns a pattern of seconds into a pattern of (rational) cycle durations -sec :: Fractional a => Pattern a -> Pattern a +sec :: (Fractional a) => Pattern a -> Pattern a sec p = (realToFrac <$> cF 1 "_cps") *| p -- | Turns a pattern of milliseconds into a pattern of (rational) -- cycle durations, according to the current cps. -msec :: Fractional a => Pattern a -> Pattern a +msec :: (Fractional a) => Pattern a -> Pattern a msec p = (realToFrac . (/ 1000) <$> cF 1 "_cps") *| p -- | Align the start of a pattern with the time a pattern is evaluated, diff --git a/src/Sound/Tidal/Core.hs b/src/Sound/Tidal/Core.hs index 6bbe234b..9f1c3ad6 100644 --- a/src/Sound/Tidal/Core.hs +++ b/src/Sound/Tidal/Core.hs @@ -43,14 +43,14 @@ sig f = pattern q -- | @sine@ - unipolar sinewave. A pattern of continuous values following a -- sinewave with frequency of one cycle, and amplitude from 0 to 1. -sine :: Fractional a => Pattern a +sine :: (Fractional a) => Pattern a sine = sig $ \t -> (sin_rat ((pi :: Double) * 2 * fromRational t) + 1) / 2 where sin_rat = fromRational . toRational . sin -- | @sine2@ - bipolar sinewave. A pattern of continuous values following a -- sinewave with frequency of one cycle, and amplitude from -1 to 1. -sine2 :: Fractional a => Pattern a +sine2 :: (Fractional a) => Pattern a sine2 = sig $ \t -> sin_rat ((pi :: Double) * 2 * fromRational t) where sin_rat = fromRational . toRational . sin @@ -58,13 +58,13 @@ sine2 = sig $ \t -> sin_rat ((pi :: Double) * 2 * fromRational t) -- | @cosine@ - unipolar cosine wave. A pattern of continuous values -- following a cosine with frequency of one cycle, and amplitude from -- 0 to 1. Equivalent to @0.25 ~> sine@. -cosine :: Fractional a => Pattern a +cosine :: (Fractional a) => Pattern a cosine = 0.25 `rotR` sine -- | @cosine2@ - bipolar cosine wave. A pattern of continuous values -- following a cosine with frequency of one cycle, and amplitude from -- -1 to 1. Equivalent to @0.25 ~> sine2@. -cosine2 :: Fractional a => Pattern a +cosine2 :: (Fractional a) => Pattern a cosine2 = 0.25 `rotR` sine2 -- | @saw@ - unipolar ascending sawtooth wave. A pattern of continuous values @@ -150,16 +150,16 @@ instance {-# OVERLAPPING #-} Unionable ValueMap where (|+|) :: (Applicative a, Num b) => a b -> a b -> a b a |+| b = (+) <$> a <*> b -(|+) :: Num a => Pattern a -> Pattern a -> Pattern a +(|+) :: (Num a) => Pattern a -> Pattern a -> Pattern a a |+ b = (+) <$> a <* b -(+|) :: Num a => Pattern a -> Pattern a -> Pattern a +(+|) :: (Num a) => Pattern a -> Pattern a -> Pattern a a +| b = (+) <$> a *> b -(||+) :: Num a => Pattern a -> Pattern a -> Pattern a +(||+) :: (Num a) => Pattern a -> Pattern a -> Pattern a a ||+ b = (+) <$> a <<* b -(|++|) :: Applicative a => a String -> a String -> a String +(|++|) :: (Applicative a) => a String -> a String -> a String a |++| b = (++) <$> a <*> b (|++) :: Pattern String -> Pattern String -> Pattern String @@ -174,89 +174,89 @@ a ||++ b = (++) <$> a <<* b (|/|) :: (Applicative a, Fractional b) => a b -> a b -> a b a |/| b = (/) <$> a <*> b -(|/) :: Fractional a => Pattern a -> Pattern a -> Pattern a +(|/) :: (Fractional a) => Pattern a -> Pattern a -> Pattern a a |/ b = (/) <$> a <* b -(/|) :: Fractional a => Pattern a -> Pattern a -> Pattern a +(/|) :: (Fractional a) => Pattern a -> Pattern a -> Pattern a a /| b = (/) <$> a *> b -(||/) :: Fractional a => Pattern a -> Pattern a -> Pattern a +(||/) :: (Fractional a) => Pattern a -> Pattern a -> Pattern a a ||/ b = (/) <$> a <<* b (|*|) :: (Applicative a, Num b) => a b -> a b -> a b a |*| b = (*) <$> a <*> b -(|*) :: Num a => Pattern a -> Pattern a -> Pattern a +(|*) :: (Num a) => Pattern a -> Pattern a -> Pattern a a |* b = (*) <$> a <* b -(*|) :: Num a => Pattern a -> Pattern a -> Pattern a +(*|) :: (Num a) => Pattern a -> Pattern a -> Pattern a a *| b = (*) <$> a *> b -(||*) :: Num a => Pattern a -> Pattern a -> Pattern a +(||*) :: (Num a) => Pattern a -> Pattern a -> Pattern a a ||* b = (*) <$> a <<* b (|-|) :: (Applicative a, Num b) => a b -> a b -> a b a |-| b = (-) <$> a <*> b -(|-) :: Num a => Pattern a -> Pattern a -> Pattern a +(|-) :: (Num a) => Pattern a -> Pattern a -> Pattern a a |- b = (-) <$> a <* b -(-|) :: Num a => Pattern a -> Pattern a -> Pattern a +(-|) :: (Num a) => Pattern a -> Pattern a -> Pattern a a -| b = (-) <$> a *> b -(||-) :: Num a => Pattern a -> Pattern a -> Pattern a +(||-) :: (Num a) => Pattern a -> Pattern a -> Pattern a a ||- b = (-) <$> a <<* b (|%|) :: (Applicative a, Moddable b) => a b -> a b -> a b a |%| b = gmod <$> a <*> b -(|%) :: Moddable a => Pattern a -> Pattern a -> Pattern a +(|%) :: (Moddable a) => Pattern a -> Pattern a -> Pattern a a |% b = gmod <$> a <* b -(%|) :: Moddable a => Pattern a -> Pattern a -> Pattern a +(%|) :: (Moddable a) => Pattern a -> Pattern a -> Pattern a a %| b = gmod <$> a *> b -(||%) :: Moddable a => Pattern a -> Pattern a -> Pattern a +(||%) :: (Moddable a) => Pattern a -> Pattern a -> Pattern a a ||% b = gmod <$> a <<* b (|**|) :: (Applicative a, Floating b) => a b -> a b -> a b a |**| b = (**) <$> a <*> b -(|**) :: Floating a => Pattern a -> Pattern a -> Pattern a +(|**) :: (Floating a) => Pattern a -> Pattern a -> Pattern a a |** b = (**) <$> a <* b -(**|) :: Floating a => Pattern a -> Pattern a -> Pattern a +(**|) :: (Floating a) => Pattern a -> Pattern a -> Pattern a a **| b = (**) <$> a *> b -(||**) :: Floating a => Pattern a -> Pattern a -> Pattern a +(||**) :: (Floating a) => Pattern a -> Pattern a -> Pattern a a ||** b = (**) <$> a <<* b (|>|) :: (Applicative a, Unionable b) => a b -> a b -> a b a |>| b = flip union <$> a <*> b -(|>) :: Unionable a => Pattern a -> Pattern a -> Pattern a +(|>) :: (Unionable a) => Pattern a -> Pattern a -> Pattern a a |> b = flip union <$> a <* b -(>|) :: Unionable a => Pattern a -> Pattern a -> Pattern a +(>|) :: (Unionable a) => Pattern a -> Pattern a -> Pattern a a >| b = flip union <$> a *> b -(||>) :: Unionable a => Pattern a -> Pattern a -> Pattern a +(||>) :: (Unionable a) => Pattern a -> Pattern a -> Pattern a a ||> b = flip union <$> a <<* b (|<|) :: (Applicative a, Unionable b) => a b -> a b -> a b a |<| b = union <$> a <*> b -(|<) :: Unionable a => Pattern a -> Pattern a -> Pattern a +(|<) :: (Unionable a) => Pattern a -> Pattern a -> Pattern a a |< b = union <$> a <* b -(<|) :: Unionable a => Pattern a -> Pattern a -> Pattern a +(<|) :: (Unionable a) => Pattern a -> Pattern a -> Pattern a a <| b = union <$> a *> b -(||<) :: Unionable a => Pattern a -> Pattern a -> Pattern a +(||<) :: (Unionable a) => Pattern a -> Pattern a -> Pattern a a ||< b = union <$> a <<* b -- Backward compatibility - structure from left, values from right. -(#) :: Unionable b => Pattern b -> Pattern b -> Pattern b +(#) :: (Unionable b) => Pattern b -> Pattern b -> Pattern b (#) = (|>) -- ** Constructing patterns @@ -510,9 +510,10 @@ zoomArc :: Arc -> Pattern a -> Pattern a zoomArc (Arc s e) p | s >= e = nothing | otherwise = - withTactus (* d) $ - splitQueries $ - withResultArc (mapCycle ((/ d) . subtract s)) $ withQueryArc (mapCycle ((+ s) . (* d))) p + withTactus (* d) $ + splitQueries $ + withResultArc (mapCycle ((/ d) . subtract s)) $ + withQueryArc (mapCycle ((+ s) . (* d))) p where d = e - s diff --git a/src/Sound/Tidal/Params.hs b/src/Sound/Tidal/Params.hs index e820c91b..6d43d318 100644 --- a/src/Sound/Tidal/Params.hs +++ b/src/Sound/Tidal/Params.hs @@ -172,7 +172,7 @@ midinote = note . (subtract 60 <$>) drum :: Pattern String -> ControlPattern drum = n . (subtract 60 . drumN <$>) -drumN :: Num a => String -> a +drumN :: (Num a) => String -> a drumN "hq" = 27 drumN "sl" = 28 drumN "ps" = 29 @@ -286,7 +286,6 @@ ampbus busid pat = (pF "amp" pat) # (pI "^amp" busid) amprecv :: Pattern Int -> ControlPattern amprecv busid = pI "^amp" busid --- | array :: Pattern [Word8] -> ControlPattern array = pX "array" @@ -396,7 +395,6 @@ binshiftbus busid pat = (pF "binshift" pat) # (pI "^binshift" busid) binshiftrecv :: Pattern Int -> ControlPattern binshiftrecv busid = pI "^binshift" busid --- | button0 :: Pattern Double -> ControlPattern button0 = pF "button0" @@ -415,7 +413,6 @@ button0bus busid pat = (pF "button0" pat) # (pI "^button0" busid) button0recv :: Pattern Int -> ControlPattern button0recv busid = pI "^button0" busid --- | button1 :: Pattern Double -> ControlPattern button1 = pF "button1" @@ -434,7 +431,6 @@ button1bus busid pat = (pF "button1" pat) # (pI "^button1" busid) button1recv :: Pattern Int -> ControlPattern button1recv busid = pI "^button1" busid --- | button10 :: Pattern Double -> ControlPattern button10 = pF "button10" @@ -453,7 +449,6 @@ button10bus busid pat = (pF "button10" pat) # (pI "^button10" busid) button10recv :: Pattern Int -> ControlPattern button10recv busid = pI "^button10" busid --- | button11 :: Pattern Double -> ControlPattern button11 = pF "button11" @@ -472,7 +467,6 @@ button11bus busid pat = (pF "button11" pat) # (pI "^button11" busid) button11recv :: Pattern Int -> ControlPattern button11recv busid = pI "^button11" busid --- | button12 :: Pattern Double -> ControlPattern button12 = pF "button12" @@ -491,7 +485,6 @@ button12bus busid pat = (pF "button12" pat) # (pI "^button12" busid) button12recv :: Pattern Int -> ControlPattern button12recv busid = pI "^button12" busid --- | button13 :: Pattern Double -> ControlPattern button13 = pF "button13" @@ -510,7 +503,6 @@ button13bus busid pat = (pF "button13" pat) # (pI "^button13" busid) button13recv :: Pattern Int -> ControlPattern button13recv busid = pI "^button13" busid --- | button14 :: Pattern Double -> ControlPattern button14 = pF "button14" @@ -529,7 +521,6 @@ button14bus busid pat = (pF "button14" pat) # (pI "^button14" busid) button14recv :: Pattern Int -> ControlPattern button14recv busid = pI "^button14" busid --- | button15 :: Pattern Double -> ControlPattern button15 = pF "button15" @@ -548,7 +539,6 @@ button15bus busid pat = (pF "button15" pat) # (pI "^button15" busid) button15recv :: Pattern Int -> ControlPattern button15recv busid = pI "^button15" busid --- | button2 :: Pattern Double -> ControlPattern button2 = pF "button2" @@ -567,7 +557,6 @@ button2bus busid pat = (pF "button2" pat) # (pI "^button2" busid) button2recv :: Pattern Int -> ControlPattern button2recv busid = pI "^button2" busid --- | button3 :: Pattern Double -> ControlPattern button3 = pF "button3" @@ -586,7 +575,6 @@ button3bus busid pat = (pF "button3" pat) # (pI "^button3" busid) button3recv :: Pattern Int -> ControlPattern button3recv busid = pI "^button3" busid --- | button4 :: Pattern Double -> ControlPattern button4 = pF "button4" @@ -605,7 +593,6 @@ button4bus busid pat = (pF "button4" pat) # (pI "^button4" busid) button4recv :: Pattern Int -> ControlPattern button4recv busid = pI "^button4" busid --- | button5 :: Pattern Double -> ControlPattern button5 = pF "button5" @@ -624,7 +611,6 @@ button5bus busid pat = (pF "button5" pat) # (pI "^button5" busid) button5recv :: Pattern Int -> ControlPattern button5recv busid = pI "^button5" busid --- | button6 :: Pattern Double -> ControlPattern button6 = pF "button6" @@ -643,7 +629,6 @@ button6bus busid pat = (pF "button6" pat) # (pI "^button6" busid) button6recv :: Pattern Int -> ControlPattern button6recv busid = pI "^button6" busid --- | button7 :: Pattern Double -> ControlPattern button7 = pF "button7" @@ -662,7 +647,6 @@ button7bus busid pat = (pF "button7" pat) # (pI "^button7" busid) button7recv :: Pattern Int -> ControlPattern button7recv busid = pI "^button7" busid --- | button8 :: Pattern Double -> ControlPattern button8 = pF "button8" @@ -681,7 +665,6 @@ button8bus busid pat = (pF "button8" pat) # (pI "^button8" busid) button8recv :: Pattern Int -> ControlPattern button8recv busid = pI "^button8" busid --- | button9 :: Pattern Double -> ControlPattern button9 = pF "button9" @@ -700,7 +683,6 @@ button9bus busid pat = (pF "button9" pat) # (pI "^button9" busid) button9recv :: Pattern Int -> ControlPattern button9recv busid = pI "^button9" busid --- | ccn :: Pattern Double -> ControlPattern ccn = pF "ccn" @@ -716,7 +698,6 @@ ccnCountTo name ipat = innerJoin $ (\i -> pStateF "ccn" name (maybe 0 ((`mod'` i ccnbus :: Pattern Int -> Pattern Double -> ControlPattern ccnbus _ _ = error $ "Control parameter 'ccn' can't be sent to a bus." --- | ccv :: Pattern Double -> ControlPattern ccv = pF "ccv" @@ -748,7 +729,6 @@ channelCountTo name ipat = innerJoin $ (\i -> pStateF "channel" name (maybe 0 (( channelbus :: Pattern Int -> Pattern Int -> ControlPattern channelbus _ _ = error $ "Control parameter 'channel' can't be sent to a bus." --- | clhatdecay :: Pattern Double -> ControlPattern clhatdecay = pF "clhatdecay" @@ -805,7 +785,6 @@ combbus busid pat = (pF "comb" pat) # (pI "^comb" busid) combrecv :: Pattern Int -> ControlPattern combrecv busid = pI "^comb" busid --- | control :: Pattern Double -> ControlPattern control = pF "control" @@ -864,7 +843,6 @@ crushbus busid pat = (pF "crush" pat) # (pI "^crush" busid) crushrecv :: Pattern Int -> ControlPattern crushrecv busid = pI "^crush" busid --- | ctlNum :: Pattern Double -> ControlPattern ctlNum = pF "ctlNum" @@ -880,7 +858,6 @@ ctlNumCountTo name ipat = innerJoin $ (\i -> pStateF "ctlNum" name (maybe 0 ((`m ctlNumbus :: Pattern Int -> Pattern Double -> ControlPattern ctlNumbus _ _ = error $ "Control parameter 'ctlNum' can't be sent to a bus." --- | ctranspose :: Pattern Double -> ControlPattern ctranspose = pF "ctranspose" @@ -937,7 +914,6 @@ cutoffbus busid pat = (pF "cutoff" pat) # (pI "^cutoff" busid) cutoffrecv :: Pattern Int -> ControlPattern cutoffrecv busid = pI "^cutoff" busid --- | cutoffegint :: Pattern Double -> ControlPattern cutoffegint = pF "cutoffegint" @@ -956,7 +932,6 @@ cutoffegintbus busid pat = (pF "cutoffegint" pat) # (pI "^cutoffegint" busid) cutoffegintrecv :: Pattern Int -> ControlPattern cutoffegintrecv busid = pI "^cutoffegint" busid --- | decay :: Pattern Double -> ControlPattern decay = pF "decay" @@ -975,7 +950,6 @@ decaybus busid pat = (pF "decay" pat) # (pI "^decay" busid) decayrecv :: Pattern Int -> ControlPattern decayrecv busid = pI "^decay" busid --- | degree :: Pattern Double -> ControlPattern degree = pF "degree" @@ -1051,7 +1025,6 @@ delaytimebus busid pat = (pF "delaytime" pat) # (pI "^delaytime" busid) delaytimerecv :: Pattern Int -> ControlPattern delaytimerecv busid = pI "^delaytime" busid --- | detune :: Pattern Double -> ControlPattern detune = pF "detune" @@ -1127,7 +1100,6 @@ drybus busid pat = (pF "dry" pat) # (pI "^dry" busid) dryrecv :: Pattern Int -> ControlPattern dryrecv busid = pI "^dry" busid --- | dur :: Pattern Double -> ControlPattern dur = pF "dur" @@ -1187,7 +1159,6 @@ enhancebus busid pat = (pF "enhance" pat) # (pI "^enhance" busid) enhancerecv :: Pattern Int -> ControlPattern enhancerecv busid = pI "^enhance" busid --- | expression :: Pattern Double -> ControlPattern expression = pF "expression" @@ -1238,7 +1209,6 @@ fadeTimeCountTo name ipat = innerJoin $ (\i -> pStateF "fadeTime" name (maybe 0 fadeTimebus :: Pattern Int -> Pattern Double -> ControlPattern fadeTimebus _ _ = error $ "Control parameter 'fadeTime' can't be sent to a bus." --- | frameRate :: Pattern Double -> ControlPattern frameRate = pF "frameRate" @@ -1254,7 +1224,6 @@ frameRateCountTo name ipat = innerJoin $ (\i -> pStateF "frameRate" name (maybe frameRatebus :: Pattern Int -> Pattern Double -> ControlPattern frameRatebus _ _ = error $ "Control parameter 'frameRate' can't be sent to a bus." --- | frames :: Pattern Double -> ControlPattern frames = pF "frames" @@ -1289,7 +1258,6 @@ freezebus busid pat = (pF "freeze" pat) # (pI "^freeze" busid) freezerecv :: Pattern Int -> ControlPattern freezerecv busid = pI "^freeze" busid --- | freq :: Pattern Double -> ControlPattern freq = pF "freq" @@ -1416,7 +1384,6 @@ gainCountTo name ipat = innerJoin $ (\i -> pStateF "gain" name (maybe 0 ((`mod'` gainbus :: Pattern Int -> Pattern Double -> ControlPattern gainbus _ _ = error $ "Control parameter 'gain' can't be sent to a bus." --- | gate :: Pattern Double -> ControlPattern gate = pF "gate" @@ -1435,7 +1402,6 @@ gatebus busid pat = (pF "gate" pat) # (pI "^gate" busid) gaterecv :: Pattern Int -> ControlPattern gaterecv busid = pI "^gate" busid --- | harmonic :: Pattern Double -> ControlPattern harmonic = pF "harmonic" @@ -1454,7 +1420,6 @@ harmonicbus busid pat = (pF "harmonic" pat) # (pI "^harmonic" busid) harmonicrecv :: Pattern Int -> ControlPattern harmonicrecv busid = pI "^harmonic" busid --- | hatgrain :: Pattern Double -> ControlPattern hatgrain = pF "hatgrain" @@ -1530,7 +1495,6 @@ holdbus busid pat = (pF "hold" pat) # (pI "^hold" busid) holdrecv :: Pattern Int -> ControlPattern holdrecv busid = pI "^hold" busid --- | hours :: Pattern Double -> ControlPattern hours = pF "hours" @@ -1565,7 +1529,6 @@ hresonancebus busid pat = (pF "hresonance" pat) # (pI "^hresonance" busid) hresonancerecv :: Pattern Int -> ControlPattern hresonancerecv busid = pI "^hresonance" busid --- | imag :: Pattern Double -> ControlPattern imag = pF "imag" @@ -1584,7 +1547,6 @@ imagbus busid pat = (pF "imag" pat) # (pI "^imag" busid) imagrecv :: Pattern Int -> ControlPattern imagrecv busid = pI "^imag" busid --- | kcutoff :: Pattern Double -> ControlPattern kcutoff = pF "kcutoff" @@ -1622,7 +1584,6 @@ krushbus busid pat = (pF "krush" pat) # (pI "^krush" busid) krushrecv :: Pattern Int -> ControlPattern krushrecv busid = pI "^krush" busid --- | lagogo :: Pattern Double -> ControlPattern lagogo = pF "lagogo" @@ -1660,7 +1621,6 @@ lbrickbus busid pat = (pF "lbrick" pat) # (pI "^lbrick" busid) lbrickrecv :: Pattern Int -> ControlPattern lbrickrecv busid = pI "^lbrick" busid --- | lclap :: Pattern Double -> ControlPattern lclap = pF "lclap" @@ -1679,7 +1639,6 @@ lclapbus busid pat = (pF "lclap" pat) # (pI "^lclap" busid) lclaprecv :: Pattern Int -> ControlPattern lclaprecv busid = pI "^lclap" busid --- | lclaves :: Pattern Double -> ControlPattern lclaves = pF "lclaves" @@ -1698,7 +1657,6 @@ lclavesbus busid pat = (pF "lclaves" pat) # (pI "^lclaves" busid) lclavesrecv :: Pattern Int -> ControlPattern lclavesrecv busid = pI "^lclaves" busid --- | lclhat :: Pattern Double -> ControlPattern lclhat = pF "lclhat" @@ -1717,7 +1675,6 @@ lclhatbus busid pat = (pF "lclhat" pat) # (pI "^lclhat" busid) lclhatrecv :: Pattern Int -> ControlPattern lclhatrecv busid = pI "^lclhat" busid --- | lcrash :: Pattern Double -> ControlPattern lcrash = pF "lcrash" @@ -1752,7 +1709,6 @@ legatoCountTo name ipat = innerJoin $ (\i -> pStateF "legato" name (maybe 0 ((`m legatobus :: Pattern Int -> Pattern Double -> ControlPattern legatobus _ _ = error $ "Control parameter 'legato' can't be sent to a bus." --- | leslie :: Pattern Double -> ControlPattern leslie = pF "leslie" @@ -1771,7 +1727,6 @@ lesliebus busid pat = (pF "leslie" pat) # (pI "^leslie" busid) leslierecv :: Pattern Int -> ControlPattern leslierecv busid = pI "^leslie" busid --- | lfo :: Pattern Double -> ControlPattern lfo = pF "lfo" @@ -1790,7 +1745,6 @@ lfobus busid pat = (pF "lfo" pat) # (pI "^lfo" busid) lforecv :: Pattern Int -> ControlPattern lforecv busid = pI "^lfo" busid --- | lfocutoffint :: Pattern Double -> ControlPattern lfocutoffint = pF "lfocutoffint" @@ -1809,7 +1763,6 @@ lfocutoffintbus busid pat = (pF "lfocutoffint" pat) # (pI "^lfocutoffint" busid) lfocutoffintrecv :: Pattern Int -> ControlPattern lfocutoffintrecv busid = pI "^lfocutoffint" busid --- | lfodelay :: Pattern Double -> ControlPattern lfodelay = pF "lfodelay" @@ -1828,7 +1781,6 @@ lfodelaybus busid pat = (pF "lfodelay" pat) # (pI "^lfodelay" busid) lfodelayrecv :: Pattern Int -> ControlPattern lfodelayrecv busid = pI "^lfodelay" busid --- | lfoint :: Pattern Double -> ControlPattern lfoint = pF "lfoint" @@ -1847,7 +1799,6 @@ lfointbus busid pat = (pF "lfoint" pat) # (pI "^lfoint" busid) lfointrecv :: Pattern Int -> ControlPattern lfointrecv busid = pI "^lfoint" busid --- | lfopitchint :: Pattern Double -> ControlPattern lfopitchint = pF "lfopitchint" @@ -1866,7 +1817,6 @@ lfopitchintbus busid pat = (pF "lfopitchint" pat) # (pI "^lfopitchint" busid) lfopitchintrecv :: Pattern Int -> ControlPattern lfopitchintrecv busid = pI "^lfopitchint" busid --- | lfoshape :: Pattern Double -> ControlPattern lfoshape = pF "lfoshape" @@ -1885,7 +1835,6 @@ lfoshapebus busid pat = (pF "lfoshape" pat) # (pI "^lfoshape" busid) lfoshaperecv :: Pattern Int -> ControlPattern lfoshaperecv busid = pI "^lfoshape" busid --- | lfosync :: Pattern Double -> ControlPattern lfosync = pF "lfosync" @@ -1904,7 +1853,6 @@ lfosyncbus busid pat = (pF "lfosync" pat) # (pI "^lfosync" busid) lfosyncrecv :: Pattern Int -> ControlPattern lfosyncrecv busid = pI "^lfosync" busid --- | lhitom :: Pattern Double -> ControlPattern lhitom = pF "lhitom" @@ -1923,7 +1871,6 @@ lhitombus busid pat = (pF "lhitom" pat) # (pI "^lhitom" busid) lhitomrecv :: Pattern Int -> ControlPattern lhitomrecv busid = pI "^lhitom" busid --- | lkick :: Pattern Double -> ControlPattern lkick = pF "lkick" @@ -1942,7 +1889,6 @@ lkickbus busid pat = (pF "lkick" pat) # (pI "^lkick" busid) lkickrecv :: Pattern Int -> ControlPattern lkickrecv busid = pI "^lkick" busid --- | llotom :: Pattern Double -> ControlPattern llotom = pF "llotom" @@ -1996,7 +1942,6 @@ loopCountTo name ipat = innerJoin $ (\i -> pStateF "loop" name (maybe 0 ((`mod'` loopbus :: Pattern Int -> Pattern Double -> ControlPattern loopbus _ _ = error $ "Control parameter 'loop' can't be sent to a bus." --- | lophat :: Pattern Double -> ControlPattern lophat = pF "lophat" @@ -2015,7 +1960,6 @@ lophatbus busid pat = (pF "lophat" pat) # (pI "^lophat" busid) lophatrecv :: Pattern Int -> ControlPattern lophatrecv busid = pI "^lophat" busid --- | lrate :: Pattern Double -> ControlPattern lrate = pF "lrate" @@ -2034,7 +1978,6 @@ lratebus busid pat = (pF "lrate" pat) # (pI "^lrate" busid) lraterecv :: Pattern Int -> ControlPattern lraterecv busid = pI "^lrate" busid --- | lsize :: Pattern Double -> ControlPattern lsize = pF "lsize" @@ -2053,7 +1996,6 @@ lsizebus busid pat = (pF "lsize" pat) # (pI "^lsize" busid) lsizerecv :: Pattern Int -> ControlPattern lsizerecv busid = pI "^lsize" busid --- | lsnare :: Pattern Double -> ControlPattern lsnare = pF "lsnare" @@ -2091,7 +2033,6 @@ metatunebus busid pat = (pF "metatune" pat) # (pI "^metatune" busid) metatunerecv :: Pattern Int -> ControlPattern metatunerecv busid = pI "^metatune" busid --- | midibend :: Pattern Double -> ControlPattern midibend = pF "midibend" @@ -2107,7 +2048,6 @@ midibendCountTo name ipat = innerJoin $ (\i -> pStateF "midibend" name (maybe 0 midibendbus :: Pattern Int -> Pattern Double -> ControlPattern midibendbus _ _ = error $ "Control parameter 'midibend' can't be sent to a bus." --- | midichan :: Pattern Double -> ControlPattern midichan = pF "midichan" @@ -2123,7 +2063,6 @@ midichanCountTo name ipat = innerJoin $ (\i -> pStateF "midichan" name (maybe 0 midichanbus :: Pattern Int -> Pattern Double -> ControlPattern midichanbus _ _ = error $ "Control parameter 'midichan' can't be sent to a bus." --- | midicmd :: Pattern String -> ControlPattern midicmd = pS "midicmd" @@ -2133,7 +2072,6 @@ midicmdTake name xs = pStateListF "midicmd" name xs midicmdbus :: Pattern Int -> Pattern String -> ControlPattern midicmdbus _ _ = error $ "Control parameter 'midicmd' can't be sent to a bus." --- | miditouch :: Pattern Double -> ControlPattern miditouch = pF "miditouch" @@ -2149,7 +2087,6 @@ miditouchCountTo name ipat = innerJoin $ (\i -> pStateF "miditouch" name (maybe miditouchbus :: Pattern Int -> Pattern Double -> ControlPattern miditouchbus _ _ = error $ "Control parameter 'miditouch' can't be sent to a bus." --- | minutes :: Pattern Double -> ControlPattern minutes = pF "minutes" @@ -2165,7 +2102,6 @@ minutesCountTo name ipat = innerJoin $ (\i -> pStateF "minutes" name (maybe 0 (( minutesbus :: Pattern Int -> Pattern Double -> ControlPattern minutesbus _ _ = error $ "Control parameter 'minutes' can't be sent to a bus." --- | modwheel :: Pattern Double -> ControlPattern modwheel = pF "modwheel" @@ -2184,7 +2120,6 @@ modwheelbus busid pat = (pF "modwheel" pat) # (pI "^modwheel" busid) modwheelrecv :: Pattern Int -> ControlPattern modwheelrecv busid = pI "^modwheel" busid --- | mtranspose :: Pattern Double -> ControlPattern mtranspose = pF "mtranspose" @@ -2254,7 +2189,6 @@ nudgebus busid pat = (pF "nudge" pat) # (pI "^nudge" busid) nudgerecv :: Pattern Int -> ControlPattern nudgerecv busid = pI "^nudge" busid --- | octave :: Pattern Int -> ControlPattern octave = pI "octave" @@ -2270,7 +2204,6 @@ octaveCountTo name ipat = innerJoin $ (\i -> pStateF "octave" name (maybe 0 ((`m octavebus :: Pattern Int -> Pattern Int -> ControlPattern octavebus _ _ = error $ "Control parameter 'octave' can't be sent to a bus." --- | octaveR :: Pattern Double -> ControlPattern octaveR = pF "octaveR" @@ -2346,7 +2279,6 @@ octersubsubbus busid pat = (pF "octersubsub" pat) # (pI "^octersubsub" busid) octersubsubrecv :: Pattern Int -> ControlPattern octersubsubrecv busid = pI "^octersubsub" busid --- | offset :: Pattern Double -> ControlPattern offset = pF "offset" @@ -2362,7 +2294,6 @@ offsetCountTo name ipat = innerJoin $ (\i -> pStateF "offset" name (maybe 0 ((`m offsetbus :: Pattern Int -> Pattern Double -> ControlPattern offsetbus _ _ = error $ "Control parameter 'offset' can't be sent to a bus." --- | ophatdecay :: Pattern Double -> ControlPattern ophatdecay = pF "ophatdecay" @@ -2400,7 +2331,6 @@ orbitbus busid pat = (pI "orbit" pat) # (pI "^orbit" busid) orbitrecv :: Pattern Int -> ControlPattern orbitrecv busid = pI "^orbit" busid --- | overgain :: Pattern Double -> ControlPattern overgain = pF "overgain" @@ -2416,7 +2346,6 @@ overgainCountTo name ipat = innerJoin $ (\i -> pStateF "overgain" name (maybe 0 overgainbus :: Pattern Int -> Pattern Double -> ControlPattern overgainbus _ _ = error $ "Control parameter 'overgain' can't be sent to a bus." --- | overshape :: Pattern Double -> ControlPattern overshape = pF "overshape" @@ -2530,7 +2459,6 @@ panwidthbus busid pat = (pF "panwidth" pat) # (pI "^panwidth" busid) panwidthrecv :: Pattern Int -> ControlPattern panwidthrecv busid = pI "^panwidth" busid --- | partials :: Pattern Double -> ControlPattern partials = pF "partials" @@ -2587,7 +2515,6 @@ phaserratebus busid pat = (pF "phaserrate" pat) # (pI "^phaserrate" busid) phaserraterecv :: Pattern Int -> ControlPattern phaserraterecv busid = pI "^phaserrate" busid --- | pitch1 :: Pattern Double -> ControlPattern pitch1 = pF "pitch1" @@ -2606,7 +2533,6 @@ pitch1bus busid pat = (pF "pitch1" pat) # (pI "^pitch1" busid) pitch1recv :: Pattern Int -> ControlPattern pitch1recv busid = pI "^pitch1" busid --- | pitch2 :: Pattern Double -> ControlPattern pitch2 = pF "pitch2" @@ -2625,7 +2551,6 @@ pitch2bus busid pat = (pF "pitch2" pat) # (pI "^pitch2" busid) pitch2recv :: Pattern Int -> ControlPattern pitch2recv busid = pI "^pitch2" busid --- | pitch3 :: Pattern Double -> ControlPattern pitch3 = pF "pitch3" @@ -2644,7 +2569,6 @@ pitch3bus busid pat = (pF "pitch3" pat) # (pI "^pitch3" busid) pitch3recv :: Pattern Int -> ControlPattern pitch3recv busid = pI "^pitch3" busid --- | polyTouch :: Pattern Double -> ControlPattern polyTouch = pF "polyTouch" @@ -2660,7 +2584,6 @@ polyTouchCountTo name ipat = innerJoin $ (\i -> pStateF "polyTouch" name (maybe polyTouchbus :: Pattern Int -> Pattern Double -> ControlPattern polyTouchbus _ _ = error $ "Control parameter 'polyTouch' can't be sent to a bus." --- | portamento :: Pattern Double -> ControlPattern portamento = pF "portamento" @@ -2679,7 +2602,6 @@ portamentobus busid pat = (pF "portamento" pat) # (pI "^portamento" busid) portamentorecv :: Pattern Int -> ControlPattern portamentorecv busid = pI "^portamento" busid --- | progNum :: Pattern Double -> ControlPattern progNum = pF "progNum" @@ -2847,7 +2769,6 @@ roombus busid pat = (pF "room" pat) # (pI "^room" busid) roomrecv :: Pattern Int -> ControlPattern roomrecv busid = pI "^room" busid --- | sagogo :: Pattern Double -> ControlPattern sagogo = pF "sagogo" @@ -2866,7 +2787,6 @@ sagogobus busid pat = (pF "sagogo" pat) # (pI "^sagogo" busid) sagogorecv :: Pattern Int -> ControlPattern sagogorecv busid = pI "^sagogo" busid --- | sclap :: Pattern Double -> ControlPattern sclap = pF "sclap" @@ -2885,7 +2805,6 @@ sclapbus busid pat = (pF "sclap" pat) # (pI "^sclap" busid) sclaprecv :: Pattern Int -> ControlPattern sclaprecv busid = pI "^sclap" busid --- | sclaves :: Pattern Double -> ControlPattern sclaves = pF "sclaves" @@ -2923,7 +2842,6 @@ scrambus busid pat = (pF "scram" pat) # (pI "^scram" busid) scramrecv :: Pattern Int -> ControlPattern scramrecv busid = pI "^scram" busid --- | scrash :: Pattern Double -> ControlPattern scrash = pF "scrash" @@ -2942,7 +2860,6 @@ scrashbus busid pat = (pF "scrash" pat) # (pI "^scrash" busid) scrashrecv :: Pattern Int -> ControlPattern scrashrecv busid = pI "^scrash" busid --- | seconds :: Pattern Double -> ControlPattern seconds = pF "seconds" @@ -2958,7 +2875,6 @@ secondsCountTo name ipat = innerJoin $ (\i -> pStateF "seconds" name (maybe 0 (( secondsbus :: Pattern Int -> Pattern Double -> ControlPattern secondsbus _ _ = error $ "Control parameter 'seconds' can't be sent to a bus." --- | semitone :: Pattern Double -> ControlPattern semitone = pF "semitone" @@ -3015,7 +2931,6 @@ sizebus busid pat = (pF "size" pat) # (pI "^size" busid) sizerecv :: Pattern Int -> ControlPattern sizerecv busid = pI "^size" busid --- | slide :: Pattern Double -> ControlPattern slide = pF "slide" @@ -3034,7 +2949,6 @@ slidebus busid pat = (pF "slide" pat) # (pI "^slide" busid) sliderecv :: Pattern Int -> ControlPattern sliderecv busid = pI "^slide" busid --- | slider0 :: Pattern Double -> ControlPattern slider0 = pF "slider0" @@ -3053,7 +2967,6 @@ slider0bus busid pat = (pF "slider0" pat) # (pI "^slider0" busid) slider0recv :: Pattern Int -> ControlPattern slider0recv busid = pI "^slider0" busid --- | slider1 :: Pattern Double -> ControlPattern slider1 = pF "slider1" @@ -3072,7 +2985,6 @@ slider1bus busid pat = (pF "slider1" pat) # (pI "^slider1" busid) slider1recv :: Pattern Int -> ControlPattern slider1recv busid = pI "^slider1" busid --- | slider10 :: Pattern Double -> ControlPattern slider10 = pF "slider10" @@ -3091,7 +3003,6 @@ slider10bus busid pat = (pF "slider10" pat) # (pI "^slider10" busid) slider10recv :: Pattern Int -> ControlPattern slider10recv busid = pI "^slider10" busid --- | slider11 :: Pattern Double -> ControlPattern slider11 = pF "slider11" @@ -3110,7 +3021,6 @@ slider11bus busid pat = (pF "slider11" pat) # (pI "^slider11" busid) slider11recv :: Pattern Int -> ControlPattern slider11recv busid = pI "^slider11" busid --- | slider12 :: Pattern Double -> ControlPattern slider12 = pF "slider12" @@ -3129,7 +3039,6 @@ slider12bus busid pat = (pF "slider12" pat) # (pI "^slider12" busid) slider12recv :: Pattern Int -> ControlPattern slider12recv busid = pI "^slider12" busid --- | slider13 :: Pattern Double -> ControlPattern slider13 = pF "slider13" @@ -3148,7 +3057,6 @@ slider13bus busid pat = (pF "slider13" pat) # (pI "^slider13" busid) slider13recv :: Pattern Int -> ControlPattern slider13recv busid = pI "^slider13" busid --- | slider14 :: Pattern Double -> ControlPattern slider14 = pF "slider14" @@ -3167,7 +3075,6 @@ slider14bus busid pat = (pF "slider14" pat) # (pI "^slider14" busid) slider14recv :: Pattern Int -> ControlPattern slider14recv busid = pI "^slider14" busid --- | slider15 :: Pattern Double -> ControlPattern slider15 = pF "slider15" @@ -3186,7 +3093,6 @@ slider15bus busid pat = (pF "slider15" pat) # (pI "^slider15" busid) slider15recv :: Pattern Int -> ControlPattern slider15recv busid = pI "^slider15" busid --- | slider2 :: Pattern Double -> ControlPattern slider2 = pF "slider2" @@ -3205,7 +3111,6 @@ slider2bus busid pat = (pF "slider2" pat) # (pI "^slider2" busid) slider2recv :: Pattern Int -> ControlPattern slider2recv busid = pI "^slider2" busid --- | slider3 :: Pattern Double -> ControlPattern slider3 = pF "slider3" @@ -3224,7 +3129,6 @@ slider3bus busid pat = (pF "slider3" pat) # (pI "^slider3" busid) slider3recv :: Pattern Int -> ControlPattern slider3recv busid = pI "^slider3" busid --- | slider4 :: Pattern Double -> ControlPattern slider4 = pF "slider4" @@ -3243,7 +3147,6 @@ slider4bus busid pat = (pF "slider4" pat) # (pI "^slider4" busid) slider4recv :: Pattern Int -> ControlPattern slider4recv busid = pI "^slider4" busid --- | slider5 :: Pattern Double -> ControlPattern slider5 = pF "slider5" @@ -3262,7 +3165,6 @@ slider5bus busid pat = (pF "slider5" pat) # (pI "^slider5" busid) slider5recv :: Pattern Int -> ControlPattern slider5recv busid = pI "^slider5" busid --- | slider6 :: Pattern Double -> ControlPattern slider6 = pF "slider6" @@ -3281,7 +3183,6 @@ slider6bus busid pat = (pF "slider6" pat) # (pI "^slider6" busid) slider6recv :: Pattern Int -> ControlPattern slider6recv busid = pI "^slider6" busid --- | slider7 :: Pattern Double -> ControlPattern slider7 = pF "slider7" @@ -3300,7 +3201,6 @@ slider7bus busid pat = (pF "slider7" pat) # (pI "^slider7" busid) slider7recv :: Pattern Int -> ControlPattern slider7recv busid = pI "^slider7" busid --- | slider8 :: Pattern Double -> ControlPattern slider8 = pF "slider8" @@ -3319,7 +3219,6 @@ slider8bus busid pat = (pF "slider8" pat) # (pI "^slider8" busid) slider8recv :: Pattern Int -> ControlPattern slider8recv busid = pI "^slider8" busid --- | slider9 :: Pattern Double -> ControlPattern slider9 = pF "slider9" @@ -3357,7 +3256,6 @@ smearbus busid pat = (pF "smear" pat) # (pI "^smear" busid) smearrecv :: Pattern Int -> ControlPattern smearrecv busid = pI "^smear" busid --- | songPtr :: Pattern Double -> ControlPattern songPtr = pF "songPtr" @@ -3401,7 +3299,6 @@ speedCountTo name ipat = innerJoin $ (\i -> pStateF "speed" name (maybe 0 ((`mod speedbus :: Pattern Int -> Pattern Double -> ControlPattern speedbus _ _ = error $ "Control parameter 'speed' can't be sent to a bus." --- | squiz :: Pattern Double -> ControlPattern squiz = pF "squiz" @@ -3420,7 +3317,6 @@ squizbus busid pat = (pF "squiz" pat) # (pI "^squiz" busid) squizrecv :: Pattern Int -> ControlPattern squizrecv busid = pI "^squiz" busid --- | stepsPerOctave :: Pattern Double -> ControlPattern stepsPerOctave = pF "stepsPerOctave" @@ -3439,7 +3335,6 @@ stepsPerOctavebus busid pat = (pF "stepsPerOctave" pat) # (pI "^stepsPerOctave" stepsPerOctaverecv :: Pattern Int -> ControlPattern stepsPerOctaverecv busid = pI "^stepsPerOctave" busid --- | stutterdepth :: Pattern Double -> ControlPattern stutterdepth = pF "stutterdepth" @@ -3458,7 +3353,6 @@ stutterdepthbus busid pat = (pF "stutterdepth" pat) # (pI "^stutterdepth" busid) stutterdepthrecv :: Pattern Int -> ControlPattern stutterdepthrecv busid = pI "^stutterdepth" busid --- | stuttertime :: Pattern Double -> ControlPattern stuttertime = pF "stuttertime" @@ -3507,7 +3401,6 @@ sustainCountTo name ipat = innerJoin $ (\i -> pStateF "sustain" name (maybe 0 (( sustainbus :: Pattern Int -> Pattern Double -> ControlPattern sustainbus _ _ = error $ "Control parameter 'sustain' can't be sent to a bus." --- | sustainpedal :: Pattern Double -> ControlPattern sustainpedal = pF "sustainpedal" @@ -3631,7 +3524,6 @@ toArgbus busid pat = (pS "toArg" pat) # (pI "^toArg" busid) toArgrecv :: Pattern Int -> ControlPattern toArgrecv busid = pI "^toArg" busid --- | tomdecay :: Pattern Double -> ControlPattern tomdecay = pF "tomdecay" @@ -3707,7 +3599,6 @@ triodebus busid pat = (pF "triode" pat) # (pI "^triode" busid) trioderecv :: Pattern Int -> ControlPattern trioderecv busid = pI "^triode" busid --- | tsdelay :: Pattern Double -> ControlPattern tsdelay = pF "tsdelay" @@ -3726,7 +3617,6 @@ tsdelaybus busid pat = (pF "tsdelay" pat) # (pI "^tsdelay" busid) tsdelayrecv :: Pattern Int -> ControlPattern tsdelayrecv busid = pI "^tsdelay" busid --- | uid :: Pattern Double -> ControlPattern uid = pF "uid" @@ -3765,7 +3655,6 @@ unitTake name xs = pStateListF "unit" name xs unitbus :: Pattern Int -> Pattern String -> ControlPattern unitbus _ _ = error $ "Control parameter 'unit' can't be sent to a bus." --- | val :: Pattern Double -> ControlPattern val = pF "val" @@ -3781,7 +3670,6 @@ valCountTo name ipat = innerJoin $ (\i -> pStateF "val" name (maybe 0 ((`mod'` i valbus :: Pattern Int -> Pattern Double -> ControlPattern valbus _ _ = error $ "Control parameter 'val' can't be sent to a bus." --- | vcfegint :: Pattern Double -> ControlPattern vcfegint = pF "vcfegint" @@ -3800,7 +3688,6 @@ vcfegintbus busid pat = (pF "vcfegint" pat) # (pI "^vcfegint" busid) vcfegintrecv :: Pattern Int -> ControlPattern vcfegintrecv busid = pI "^vcfegint" busid --- | vcoegint :: Pattern Double -> ControlPattern vcoegint = pF "vcoegint" @@ -3819,7 +3706,6 @@ vcoegintbus busid pat = (pF "vcoegint" pat) # (pI "^vcoegint" busid) vcoegintrecv :: Pattern Int -> ControlPattern vcoegintrecv busid = pI "^vcoegint" busid --- | velocity :: Pattern Double -> ControlPattern velocity = pF "velocity" @@ -3838,7 +3724,6 @@ velocitybus busid pat = (pF "velocity" pat) # (pI "^velocity" busid) velocityrecv :: Pattern Int -> ControlPattern velocityrecv busid = pI "^velocity" busid --- | voice :: Pattern Double -> ControlPattern voice = pF "voice" @@ -3870,7 +3755,6 @@ vowelbus busid pat = (pS "vowel" pat) # (pI "^vowel" busid) vowelrecv :: Pattern Int -> ControlPattern vowelrecv busid = pI "^vowel" busid --- | waveloss :: Pattern Double -> ControlPattern waveloss = pF "waveloss" @@ -3889,7 +3773,6 @@ wavelossbus busid pat = (pF "waveloss" pat) # (pI "^waveloss" busid) wavelossrecv :: Pattern Int -> ControlPattern wavelossrecv busid = pI "^waveloss" busid --- | xsdelay :: Pattern Double -> ControlPattern xsdelay = pF "xsdelay" diff --git a/src/Sound/Tidal/ParseBP.hs b/src/Sound/Tidal/ParseBP.hs index c7256718..9041c714 100644 --- a/src/Sound/Tidal/ParseBP.hs +++ b/src/Sound/Tidal/ParseBP.hs @@ -86,7 +86,7 @@ data TPat a where TPat_Var :: String -> TPat a TPat_Chord :: (Num b, Enum b, Parseable b, Enumerable b) => (b -> a) -> (TPat b) -> (TPat String) -> [TPat [Modifier]] -> TPat a -instance Show a => Show (TPat a) where +instance (Show a) => Show (TPat a) where show (TPat_Atom c v) = "TPat_Atom (" ++ show c ++ ") (" ++ show v ++ ")" show (TPat_Fast t v) = "TPat_Fast (" ++ show t ++ ") (" ++ show v ++ ")" show (TPat_Slow t v) = "TPat_Slow (" ++ show t ++ ") (" ++ show v ++ ")" @@ -204,7 +204,7 @@ steps_seq xs = (total_size, "timeCat [" ++ intercalate "," (map (\(r, s) -> "(" sized_pats = steps_size xs total_size = sum $ map fst sized_pats -steps_size :: Show a => [TPat a] -> [(Rational, String)] +steps_size :: (Show a) => [TPat a] -> [(Rational, String)] 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 @@ -221,12 +221,12 @@ parseBP_E s = toE parsed toE (Left e) = E.throw $ TidalParseError {parsecError = e, code = s} toE (Right tp) = toPat tp -parseTPat :: Parseable a => String -> Either ParseError (TPat a) +parseTPat :: (Parseable a) => String -> Either ParseError (TPat a) parseTPat = runParser (pSequence parseRest Prelude.<* eof) (0 :: Int) "" -- | a '-' is a negative sign if followed anything but another dash -- otherwise, it's treated as rest -parseRest :: Parseable a => MyParser (TPat a) +parseRest :: (Parseable a) => MyParser (TPat a) parseRest = try ( do @@ -236,9 +236,11 @@ parseRest = noneOf "-" tPatParser ) - <|> char '-' Prelude.*> pure TPat_Silence - <|> tPatParser - <|> char '~' Prelude.*> pure TPat_Silence + <|> char '-' + Prelude.*> pure TPat_Silence + <|> tPatParser + <|> char '~' + Prelude.*> pure TPat_Silence cP :: (Enumerable a, Parseable a) => String -> Pattern a cP s = innerJoin $ parseBP_E <$> _cX_ getS s @@ -372,7 +374,7 @@ naturalOrFloat = P.naturalOrFloat lexer data Sign = Positive | Negative -applySign :: Num a => Sign -> a -> a +applySign :: (Num a) => Sign -> a -> a applySign Positive = id applySign Negative = negate @@ -389,7 +391,7 @@ sign = intOrFloat :: MyParser Double intOrFloat = try pFloat <|> pInteger -pSequence :: Parseable a => MyParser (TPat a) -> MyParser (TPat a) +pSequence :: (Parseable a) => MyParser (TPat a) -> MyParser (TPat a) pSequence f = do spaces s <- @@ -450,7 +452,7 @@ pVar = wrapPos $ do name <- many (letter <|> oneOf "0123456789:.-_") "string" return $ TPat_Var name -pPart :: Parseable a => MyParser (TPat a) -> MyParser (TPat a) +pPart :: (Parseable a) => MyParser (TPat a) -> MyParser (TPat a) pPart f = (pSingle f <|> pPolyIn f <|> pPolyOut f <|> pVar) >>= pE >>= pRand newSeed :: MyParser Int @@ -459,7 +461,7 @@ newSeed = do Text.Parsec.Prim.modifyState (+ 1) return seed -pPolyIn :: Parseable a => MyParser (TPat a) -> MyParser (TPat a) +pPolyIn :: (Parseable a) => MyParser (TPat a) -> MyParser (TPat a) pPolyIn f = do x <- brackets $ do s <- pSequence f "sequence" @@ -476,7 +478,7 @@ pPolyIn f = do seed <- newSeed return $ TPat_CycleChoose seed (s : ss) -pPolyOut :: Parseable a => MyParser (TPat a) -> MyParser (TPat a) +pPolyOut :: (Parseable a) => MyParser (TPat a) -> MyParser (TPat a) pPolyOut f = do ss <- braces (pSequence f `sepBy` symbol ",") @@ -559,7 +561,7 @@ pBool = oneOf "f0" return $ TPat_Atom Nothing False -parseIntNote :: Integral i => MyParser i +parseIntNote :: (Integral i) => MyParser i parseIntNote = do s <- sign d <- choice [intOrFloat, parseNote] @@ -600,7 +602,7 @@ parseChord = do return chordo' <|> return foundChord -parseNote :: Num a => MyParser a +parseNote :: (Num a) => MyParser a parseNote = do n <- notenum modifiers <- many noteModifier @@ -627,7 +629,7 @@ parseNote = do char 'n' >> return 0 ] -fromNote :: Num a => Pattern String -> Pattern a +fromNote :: (Num a) => Pattern String -> Pattern a fromNote pat = fromRight 0 . runParser parseNote 0 "" <$> pat pColour :: MyParser (TPat ColourD) @@ -714,7 +716,7 @@ pFloat = do ) return $ read (i ++ "." ++ d ++ "e" ++ e) -pFraction :: RealFrac a => a -> MyParser Rational +pFraction :: (RealFrac a) => a -> MyParser Rational pFraction n = do char '%' d <- pInteger @@ -722,7 +724,7 @@ pFraction n = do then return ((round n) % (round d)) else fail "fractions need int numerator and denominator" -pRatioChar :: Fractional a => MyParser a +pRatioChar :: (Fractional a) => MyParser a pRatioChar = pRatioSingleChar 'w' 1 <|> pRatioSingleChar 'h' 0.5 @@ -733,13 +735,13 @@ pRatioChar = <|> pRatioSingleChar 'f' 0.2 <|> pRatioSingleChar 'x' (1 / 6) -pRatioSingleChar :: Fractional a => Char -> a -> MyParser a +pRatioSingleChar :: (Fractional a) => Char -> a -> MyParser a pRatioSingleChar c v = try $ do char c notFollowedBy (letter) return v -isInt :: RealFrac a => a -> Bool +isInt :: (RealFrac a) => a -> Bool isInt x = x == fromInteger (round x) --- diff --git a/src/Sound/Tidal/Pattern.hs b/src/Sound/Tidal/Pattern.hs index cf63bb2c..e0697429 100644 --- a/src/Sound/Tidal/Pattern.hs +++ b/src/Sound/Tidal/Pattern.hs @@ -58,7 +58,7 @@ data State = State data Pattern a = Pattern {query :: State -> [Event a], tactus :: Maybe Rational, pureValue :: Maybe a} deriving (Generic, Functor) -instance NFData a => NFData (Pattern a) +instance (NFData a) => NFData (Pattern a) pattern :: (State -> [Event a]) -> Pattern a pattern f = Pattern f Nothing Nothing @@ -247,8 +247,7 @@ innerJoin pp = pp {query = q, pureValue = Nothing} where q st = concatMap - ( \(Event oc _ op v) -> mapMaybe (munge oc) $ query v st {arc = op} - ) + (\(Event oc _ op v) -> mapMaybe (munge oc) $ query v st {arc = op}) (query pp st) where munge oc (Event ic iw ip v) = @@ -335,13 +334,13 @@ noOv meth = error $ meth ++ ": not supported for patterns" instance Eq (Pattern a) where (==) = noOv "(==)" -instance Ord a => Ord (Pattern a) where +instance (Ord a) => Ord (Pattern a) where min = liftA2 min max = liftA2 max compare = noOv "compare" (<=) = noOv "(<=)" -instance Num a => Num (Pattern a) where +instance (Num a) => Num (Pattern a) where negate = fmap negate (+) = liftA2 (+) (*) = liftA2 (*) @@ -349,7 +348,7 @@ instance Num a => Num (Pattern a) where abs = fmap abs signum = fmap signum -instance Enum a => Enum (Pattern a) where +instance (Enum a) => Enum (Pattern a) where succ = fmap succ pred = fmap pred toEnum = pure . toEnum @@ -657,14 +656,14 @@ _slow r p = _fast (1 / r) p _fastGap :: Time -> Pattern a -> Pattern a _fastGap 0 _ = empty _fastGap r p = - splitQueries $ - withResultArc + splitQueries + $ withResultArc ( \(Arc s e) -> Arc (sam s + ((s - sam s) / r')) (sam s + ((e - sam s) / r')) ) - $ p {query = f} + $ p {query = f} where r' = max r 1 -- zero width queries of the next sam should return zero in this case.. @@ -909,7 +908,7 @@ onsetIn :: Arc -> Event a -> Bool onsetIn a e = isIn a (wholeStart e) -- | Returns a list of events, with any adjacent parts of the same whole combined -defragParts :: Eq a => [Event a] -> [Event a] +defragParts :: (Eq a) => [Event a] -> [Event a] defragParts [] = [] defragParts [e] = [e] defragParts (e : es) @@ -922,7 +921,7 @@ defragParts (e : es) u = hull (part e) (part e') -- | Returns 'True' if the two given events are adjacent parts of the same whole -isAdjacent :: Eq a => Event a -> Event a -> Bool +isAdjacent :: (Eq a) => Event a -> Event a -> Bool isAdjacent e e' = (whole e == whole e') && (value e == value e') @@ -1170,7 +1169,7 @@ valueToPattern v = pure v sameDur :: Event a -> Event a -> Bool sameDur e1 e2 = (whole e1 == whole e2) && (part e1 == part e2) -groupEventsBy :: Eq a => (Event a -> Event a -> Bool) -> [Event a] -> [[Event a]] +groupEventsBy :: (Eq a) => (Event a -> Event a -> Bool) -> [Event a] -> [[Event a]] groupEventsBy _ [] = [] groupEventsBy f (e : es) = eqs : (groupEventsBy f (es \\ eqs)) where @@ -1188,7 +1187,7 @@ collectEvent l@(e : _) = Just $ e {context = con, value = vs} where Context iss = unionC cs -collectEventsBy :: Eq a => (Event a -> Event a -> Bool) -> [Event a] -> [Event [a]] +collectEventsBy :: (Eq a) => (Event a -> Event a -> Bool) -> [Event a] -> [Event [a]] collectEventsBy f es = remNo $ map collectEvent (groupEventsBy f es) where remNo [] = [] @@ -1196,11 +1195,11 @@ collectEventsBy f es = remNo $ map collectEvent (groupEventsBy f es) remNo ((Just c) : cs) = c : (remNo cs) -- | collects all events satisfying the same constraint into a list -collectBy :: Eq a => (Event a -> Event a -> Bool) -> Pattern a -> Pattern [a] +collectBy :: (Eq a) => (Event a -> Event a -> Bool) -> Pattern a -> Pattern [a] collectBy f = withEvents (collectEventsBy f) -- | collects all events occuring at the exact same time into a list -collect :: Eq a => Pattern a -> Pattern [a] +collect :: (Eq a) => Pattern a -> Pattern [a] collect = collectBy sameDur uncollectEvent :: Event [a] -> [Event a] diff --git a/src/Sound/Tidal/Scales.hs b/src/Sound/Tidal/Scales.hs index 4e818392..20894d73 100644 --- a/src/Sound/Tidal/Scales.hs +++ b/src/Sound/Tidal/Scales.hs @@ -28,251 +28,251 @@ import Prelude hiding ((*>), (<*)) -- ** Five notes scales -minPent :: Fractional a => [a] +minPent :: (Fractional a) => [a] minPent = [0, 3, 5, 7, 10] -majPent :: Fractional a => [a] +majPent :: (Fractional a) => [a] majPent = [0, 2, 4, 7, 9] -- | Another mode of major pentatonic -ritusen :: Fractional a => [a] +ritusen :: (Fractional a) => [a] ritusen = [0, 2, 5, 7, 9] -- | Another mode of major pentatonic -egyptian :: Fractional a => [a] +egyptian :: (Fractional a) => [a] egyptian = [0, 2, 5, 7, 10] -- *** Other scales -kumai :: Fractional a => [a] +kumai :: (Fractional a) => [a] kumai = [0, 2, 3, 7, 9] -hirajoshi :: Fractional a => [a] +hirajoshi :: (Fractional a) => [a] hirajoshi = [0, 2, 3, 7, 8] -iwato :: Fractional a => [a] +iwato :: (Fractional a) => [a] iwato = [0, 1, 5, 6, 10] -chinese :: Fractional a => [a] +chinese :: (Fractional a) => [a] chinese = [0, 4, 6, 7, 11] -indian :: Fractional a => [a] +indian :: (Fractional a) => [a] indian = [0, 4, 5, 7, 10] -pelog :: Fractional a => [a] +pelog :: (Fractional a) => [a] pelog = [0, 1, 3, 7, 8] -- *** More scales -prometheus :: Fractional a => [a] +prometheus :: (Fractional a) => [a] prometheus = [0, 2, 4, 6, 11] -scriabin :: Fractional a => [a] +scriabin :: (Fractional a) => [a] scriabin = [0, 1, 4, 7, 9] -- *** Han Chinese pentatonic scales -gong :: Fractional a => [a] +gong :: (Fractional a) => [a] gong = [0, 2, 4, 7, 9] -shang :: Fractional a => [a] +shang :: (Fractional a) => [a] shang = [0, 2, 5, 7, 10] -jiao :: Fractional a => [a] +jiao :: (Fractional a) => [a] jiao = [0, 3, 5, 8, 10] -zhi :: Fractional a => [a] +zhi :: (Fractional a) => [a] zhi = [0, 2, 5, 7, 9] -yu :: Fractional a => [a] +yu :: (Fractional a) => [a] yu = [0, 3, 5, 7, 10] -- ** 6 note scales -whole' :: Fractional a => [a] +whole' :: (Fractional a) => [a] whole' = [0, 2, 4, 6, 8, 10] -augmented :: Fractional a => [a] +augmented :: (Fractional a) => [a] augmented = [0, 3, 4, 7, 8, 11] -augmented2 :: Fractional a => [a] +augmented2 :: (Fractional a) => [a] augmented2 = [0, 1, 4, 5, 8, 9] -- *** Hexatonic modes with no tritone -hexMajor7 :: Fractional a => [a] +hexMajor7 :: (Fractional a) => [a] hexMajor7 = [0, 2, 4, 7, 9, 11] -hexDorian :: Fractional a => [a] +hexDorian :: (Fractional a) => [a] hexDorian = [0, 2, 3, 5, 7, 10] -hexPhrygian :: Fractional a => [a] +hexPhrygian :: (Fractional a) => [a] hexPhrygian = [0, 1, 3, 5, 8, 10] -hexSus :: Fractional a => [a] +hexSus :: (Fractional a) => [a] hexSus = [0, 2, 5, 7, 9, 10] -hexMajor6 :: Fractional a => [a] +hexMajor6 :: (Fractional a) => [a] hexMajor6 = [0, 2, 4, 5, 7, 9] -hexAeolian :: Fractional a => [a] +hexAeolian :: (Fractional a) => [a] hexAeolian = [0, 3, 5, 7, 8, 10] -- ** 7 note scales -major :: Fractional a => [a] +major :: (Fractional a) => [a] major = [0, 2, 4, 5, 7, 9, 11] -ionian :: Fractional a => [a] +ionian :: (Fractional a) => [a] ionian = [0, 2, 4, 5, 7, 9, 11] -dorian :: Fractional a => [a] +dorian :: (Fractional a) => [a] dorian = [0, 2, 3, 5, 7, 9, 10] -phrygian :: Fractional a => [a] +phrygian :: (Fractional a) => [a] phrygian = [0, 1, 3, 5, 7, 8, 10] -lydian :: Fractional a => [a] +lydian :: (Fractional a) => [a] lydian = [0, 2, 4, 6, 7, 9, 11] -mixolydian :: Fractional a => [a] +mixolydian :: (Fractional a) => [a] mixolydian = [0, 2, 4, 5, 7, 9, 10] -aeolian :: Fractional a => [a] +aeolian :: (Fractional a) => [a] aeolian = [0, 2, 3, 5, 7, 8, 10] -minor :: Fractional a => [a] +minor :: (Fractional a) => [a] minor = [0, 2, 3, 5, 7, 8, 10] -locrian :: Fractional a => [a] +locrian :: (Fractional a) => [a] locrian = [0, 1, 3, 5, 6, 8, 10] -harmonicMinor :: Fractional a => [a] +harmonicMinor :: (Fractional a) => [a] harmonicMinor = [0, 2, 3, 5, 7, 8, 11] -harmonicMajor :: Fractional a => [a] +harmonicMajor :: (Fractional a) => [a] harmonicMajor = [0, 2, 4, 5, 7, 8, 11] -melodicMinor :: Fractional a => [a] +melodicMinor :: (Fractional a) => [a] melodicMinor = [0, 2, 3, 5, 7, 9, 11] -melodicMinorDesc :: Fractional a => [a] +melodicMinorDesc :: (Fractional a) => [a] melodicMinorDesc = [0, 2, 3, 5, 7, 8, 10] -melodicMajor :: Fractional a => [a] +melodicMajor :: (Fractional a) => [a] melodicMajor = [0, 2, 4, 5, 7, 8, 10] -bartok :: Fractional a => [a] +bartok :: (Fractional a) => [a] bartok = melodicMajor -hindu :: Fractional a => [a] +hindu :: (Fractional a) => [a] hindu = melodicMajor -- *** Raga modes -todi :: Fractional a => [a] +todi :: (Fractional a) => [a] todi = [0, 1, 3, 6, 7, 8, 11] -purvi :: Fractional a => [a] +purvi :: (Fractional a) => [a] purvi = [0, 1, 4, 6, 7, 8, 11] -marva :: Fractional a => [a] +marva :: (Fractional a) => [a] marva = [0, 1, 4, 6, 7, 9, 11] -bhairav :: Fractional a => [a] +bhairav :: (Fractional a) => [a] bhairav = [0, 1, 4, 5, 7, 8, 11] -ahirbhairav :: Fractional a => [a] +ahirbhairav :: (Fractional a) => [a] ahirbhairav = [0, 1, 4, 5, 7, 9, 10] -- *** More modes -superLocrian :: Fractional a => [a] +superLocrian :: (Fractional a) => [a] superLocrian = [0, 1, 3, 4, 6, 8, 10] -romanianMinor :: Fractional a => [a] +romanianMinor :: (Fractional a) => [a] romanianMinor = [0, 2, 3, 6, 7, 9, 10] -hungarianMinor :: Fractional a => [a] +hungarianMinor :: (Fractional a) => [a] hungarianMinor = [0, 2, 3, 6, 7, 8, 11] -neapolitanMinor :: Fractional a => [a] +neapolitanMinor :: (Fractional a) => [a] neapolitanMinor = [0, 1, 3, 5, 7, 8, 11] -enigmatic :: Fractional a => [a] +enigmatic :: (Fractional a) => [a] enigmatic = [0, 1, 4, 6, 8, 10, 11] -spanish :: Fractional a => [a] +spanish :: (Fractional a) => [a] spanish = [0, 1, 4, 5, 7, 8, 10] -- *** Modes of whole tones with added note -> -leadingWhole :: Fractional a => [a] +leadingWhole :: (Fractional a) => [a] leadingWhole = [0, 2, 4, 6, 8, 10, 11] -lydianMinor :: Fractional a => [a] +lydianMinor :: (Fractional a) => [a] lydianMinor = [0, 2, 4, 6, 7, 8, 10] -neapolitanMajor :: Fractional a => [a] +neapolitanMajor :: (Fractional a) => [a] neapolitanMajor = [0, 1, 3, 5, 7, 9, 11] -locrianMajor :: Fractional a => [a] +locrianMajor :: (Fractional a) => [a] locrianMajor = [0, 2, 4, 5, 6, 8, 10] -- ** 8 note scales -diminished :: Fractional a => [a] +diminished :: (Fractional a) => [a] diminished = [0, 1, 3, 4, 6, 7, 9, 10] -diminished2 :: Fractional a => [a] +diminished2 :: (Fractional a) => [a] diminished2 = [0, 2, 3, 5, 6, 8, 9, 11] -- ** Modes of limited transposition -messiaen1 :: Fractional a => [a] +messiaen1 :: (Fractional a) => [a] messiaen1 = whole' -messiaen2 :: Fractional a => [a] +messiaen2 :: (Fractional a) => [a] messiaen2 = diminished -messiaen3 :: Fractional a => [a] +messiaen3 :: (Fractional a) => [a] messiaen3 = [0, 2, 3, 4, 6, 7, 8, 10, 11] -messiaen4 :: Fractional a => [a] +messiaen4 :: (Fractional a) => [a] messiaen4 = [0, 1, 2, 5, 6, 7, 8, 11] -messiaen5 :: Fractional a => [a] +messiaen5 :: (Fractional a) => [a] messiaen5 = [0, 1, 5, 6, 7, 11] -messiaen6 :: Fractional a => [a] +messiaen6 :: (Fractional a) => [a] messiaen6 = [0, 2, 4, 5, 6, 8, 10, 11] -messiaen7 :: Fractional a => [a] +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 :: (Fractional a) => [a] bayati = [0, 1.5, 3, 5, 7, 8, 10] -hijaz :: Fractional a => [a] +hijaz :: (Fractional a) => [a] hijaz = [0, 1, 4, 5, 7, 8.5, 10] -sikah :: Fractional a => [a] +sikah :: (Fractional a) => [a] sikah = [0, 1.5, 3.5, 5.5, 7, 8.5, 10.5] -rast :: Fractional a => [a] +rast :: (Fractional a) => [a] rast = [0, 2, 3.5, 5, 7, 9, 10.5] -iraq :: Fractional a => [a] +iraq :: (Fractional a) => [a] iraq = [0, 1.5, 3.5, 5, 6.5, 8.5, 10.5] -saba :: Fractional a => [a] +saba :: (Fractional a) => [a] saba = [0, 1.5, 3, 4, 6, 8, 10] -- ** 12 note scales -chromatic :: Fractional a => [a] +chromatic :: (Fractional a) => [a] chromatic = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11] -- | @@ -285,7 +285,7 @@ chromatic = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11] -- > $ struct (iter 4 "t(5,8)") -- > $ n (scale "ritusen" "0 .. 7") -- > # sound "superpiano" -scale :: Fractional a => Pattern String -> Pattern Int -> Pattern a +scale :: (Fractional a) => Pattern String -> Pattern Int -> Pattern a scale = getScale scaleTable -- | @@ -302,7 +302,7 @@ scale = getScale scaleTable -- The above takes the standard 'scaleTable' as a starting point and adds two custom scales to it. You’ll be able to use the new function in place of the normal one: -- -- > d1 $ n (myscale "techno" "0 1 2 3 4 5 6 7") # sound "superpiano" -getScale :: Fractional a => [(String, [a])] -> Pattern String -> Pattern Int -> Pattern a +getScale :: (Fractional a) => [(String, [a])] -> Pattern String -> Pattern Int -> Pattern a getScale table sp p = ( \n scaleName -> noteInScale (fromMaybe [0] $ lookup scaleName table) n @@ -351,7 +351,7 @@ uniq l = l {- Raises a specified degree of a scale, provided as a numbers list. Meant to be passed as an argument to @scaleWith@ -} -raiseDegree :: Fractional a => Int -> [a] -> [a] +raiseDegree :: (Fractional a) => Int -> [a] -> [a] raiseDegree n (hd : []) = (hd + 1) : [] raiseDegree 0 (hd : tl) = (hd + 1) : tl raiseDegree n (hd : tl) = hd : (raiseDegree (n - 1) tl) @@ -360,7 +360,7 @@ raiseDegree _ [] = error "Degree is not present in the scale" {- Lowers a specified degree of a scale, provided as a numbers list. Meant to be passed as an argument to @scaleWith@ -} -lowerDegree :: Fractional a => Int -> [a] -> [a] +lowerDegree :: (Fractional a) => Int -> [a] -> [a] lowerDegree n (hd : []) = (hd - 1) : [] lowerDegree 0 (hd : tl) = (hd - 1) : tl lowerDegree n (hd : tl) = hd : (lowerDegree (n - 1) tl) @@ -368,7 +368,7 @@ lowerDegree _ [] = error "Degree is not present in the scale" {- Like @raiseDegree@, but raises a range of degrees instead of a single one -} -raiseDegrees :: Fractional a => Int -> Int -> [a] -> [a] +raiseDegrees :: (Fractional a) => Int -> Int -> [a] -> [a] raiseDegrees n m (hd : []) = (hd + 1) : [] raiseDegrees 0 0 (hd : tl) = (hd + 1) : tl raiseDegrees 0 m (hd : tl) = (hd + 1) : (raiseDegrees 0 (m - 1) tl) @@ -377,7 +377,7 @@ raiseDegrees _ _ [] = error "Degrees are out of the scale" {- Like @lowerDegree@, but lowers a range of degrees instead of a single one -} -lowerDegrees :: Fractional a => Int -> Int -> [a] -> [a] +lowerDegrees :: (Fractional a) => Int -> Int -> [a] -> [a] lowerDegrees n m (hd : []) = (hd - 1) : [] lowerDegrees 0 0 (hd : tl) = (hd - 1) : tl lowerDegrees 0 m (hd : tl) = (hd - 1) : (lowerDegrees 0 (m - 1) tl) @@ -418,7 +418,7 @@ scaleList = unwords $ map fst (scaleTable :: [(String, [Rational])]) -- The above example will output all scales of which the first three notes are -- the root, the major second (2 semitones above the fundamental), and the major -- third (4 semitones above the root). -scaleTable :: Fractional a => [(String, [a])] +scaleTable :: (Fractional a) => [(String, [a])] scaleTable = [ ("minPent", minPent), ("majPent", majPent), diff --git a/src/Sound/Tidal/Show.hs b/src/Sound/Tidal/Show.hs index cb5b417e..c91809aa 100644 --- a/src/Sound/Tidal/Show.hs +++ b/src/Sound/Tidal/Show.hs @@ -46,7 +46,7 @@ showStateful p = intercalate "\n" evStrings ) evStrings = map evString evs' -showPattern :: Show a => Arc -> Pattern a -> String +showPattern :: (Show a) => Arc -> Pattern a -> String showPattern _ (Pattern _ _ (Just v)) = "(pure " ++ show v ++ ")" showPattern a p = intercalate "\n" evStrings where @@ -59,7 +59,7 @@ showPattern a p = intercalate "\n" evStrings ++ uncurry (++) ev evStrings = map evString evs -showEvent :: Show a => Event a -> (String, String) +showEvent :: (Show a) => Event a -> (String, String) showEvent (Event _ (Just (Arc ws we)) a@(Arc ps pe) e) = (h ++ "(" ++ show a ++ ")" ++ t ++ "|", show e) where @@ -73,11 +73,11 @@ showEvent (Event _ Nothing a e) = ("~" ++ show a ++ "~|", show e) -- Show everything, including event context -showAll :: Show a => Arc -> Pattern a -> String +showAll :: (Show a) => Arc -> Pattern a -> String showAll a p = intercalate "\n" $ map showEventAll $ sortOn part $ queryArc p a -- Show context of an event -showEventAll :: Show a => Event a -> String +showEventAll :: (Show a) => Event a -> String showEventAll e = show (context e) ++ uncurry (++) (showEvent e) instance Show Context where @@ -101,7 +101,7 @@ instance {-# OVERLAPPING #-} Show ValueMap where instance {-# OVERLAPPING #-} Show Arc where show (Arc s e) = prettyRat s ++ ">" ++ prettyRat e -instance {-# OVERLAPPING #-} Show a => Show (Event a) where +instance {-# OVERLAPPING #-} (Show a) => Show (Event a) where show e = uncurry (++) (showEvent e) prettyRat :: Rational -> String @@ -250,6 +250,6 @@ addEvent e (level : ls) arrangeEvents :: [Event b] -> [[Event b]] arrangeEvents = foldr addEvent [] -levels :: Eq a => Pattern a -> [[Event a]] +levels :: (Eq a) => Pattern a -> [[Event a]] -- levels pat = arrangeEvents $ sortOn' ((\Arc{..} -> stop - start) . part) (defragParts $ queryArc pat (Arc 0 1)) levels pat = arrangeEvents $ reverse $ defragParts $ queryArc pat (Arc 0 1) diff --git a/src/Sound/Tidal/Stream/Listen.hs b/src/Sound/Tidal/Stream/Listen.hs index 76d25bb6..2c8b8b73 100644 --- a/src/Sound/Tidal/Stream/Listen.hs +++ b/src/Sound/Tidal/Stream/Listen.hs @@ -37,12 +37,12 @@ import System.IO (hPutStrLn, stderr) openListener :: Config -> IO (Maybe O.Udp) openListener c | cCtrlListen c = - catchAny - run - ( \_ -> do - verbose c "That port isn't available, perhaps another Tidal instance is already listening on that port?" - return Nothing - ) + catchAny + run + ( \_ -> do + verbose c "That port isn't available, perhaps another Tidal instance is already listening on that port?" + return Nothing + ) | otherwise = return Nothing where run = do diff --git a/src/Sound/Tidal/Stream/Process.hs b/src/Sound/Tidal/Stream/Process.hs index bb1cc913..10f03039 100644 --- a/src/Sound/Tidal/Stream/Process.hs +++ b/src/Sound/Tidal/Stream/Process.hs @@ -155,8 +155,8 @@ processCps cconf cref (ss, temposs) = mapM processEvent onPartOsc <- Clock.linkToOscTime cref onPart let cps = ((Clock.beatToCycles cconf) $ fromRational bpm) / 60 let delta = off - on - return - $! ProcessedEvent + return $! + ProcessedEvent { peHasOnset = eventHasOnset e, peEvent = e, peCps = cps, @@ -192,22 +192,22 @@ toOSC busses pe osc@(OSC _ _) = -- Only events that start within the current nowArc are included playmsg | peHasOnset pe = do - -- If there is already cps in the event, the union will preserve that. - let extra = - Map.fromList - [ ("cps", (VF (peCps pe))), - ("delta", VF (Clock.addMicrosToOsc (peDelta pe) 0)), - ("cycle", VF (fromRational (peCycle pe))) - ] - addExtra = Map.union playmap' extra - ts = (peOnWholeOrPartOsc pe) + nudge -- + latency - vs <- toData osc ((peEvent pe) {value = addExtra}) - mungedPath <- substitutePath (path osc) playmap' - return - ( ts, - False, -- bus message ? - O.Message mungedPath vs - ) + -- If there is already cps in the event, the union will preserve that. + let extra = + Map.fromList + [ ("cps", (VF (peCps pe))), + ("delta", VF (Clock.addMicrosToOsc (peDelta pe) 0)), + ("cycle", VF (fromRational (peCycle pe))) + ] + addExtra = Map.union playmap' extra + ts = (peOnWholeOrPartOsc pe) + nudge -- + latency + vs <- toData osc ((peEvent pe) {value = addExtra}) + mungedPath <- substitutePath (path osc) playmap' + return + ( ts, + False, -- bus message ? + O.Message mungedPath vs + ) | otherwise = Nothing toBus n | null busses = n @@ -276,9 +276,9 @@ substitutePath str cm = parse str parseWord xs | b == [] = getString cm a | otherwise = do - v <- getString cm a - xs' <- parse (tail b) - return $ v ++ xs' + v <- getString cm a + xs' <- parse (tail b) + return $ v ++ xs' where (a, b) = break (== '}') xs diff --git a/src/Sound/Tidal/Stream/Target.hs b/src/Sound/Tidal/Stream/Target.hs index 8a81127b..c403d485 100644 --- a/src/Sound/Tidal/Stream/Target.hs +++ b/src/Sound/Tidal/Stream/Target.hs @@ -65,11 +65,11 @@ send listen cx latency extraLatency (time, isBusMsg, m) | oSchedule target == Pre BundleStamp = sendBndl isBusMsg listen cx $ O.Bundle timeWithLatency [m] | oSchedule target == Pre MessageStamp = sendO isBusMsg listen cx $ addtime m | otherwise = do - _ <- forkOS $ do - now <- O.time - threadDelay $ floor $ (timeWithLatency - now) * 1000000 - sendO isBusMsg listen cx m - return () + _ <- forkOS $ do + now <- O.time + threadDelay $ floor $ (timeWithLatency - now) * 1000000 + sendO isBusMsg listen cx m + return () where addtime (O.Message mpath params) = O.Message mpath ((O.int32 sec) : ((O.int32 usec) : params)) ut = O.ntpr_to_posix timeWithLatency diff --git a/src/Sound/Tidal/Stream/UI.hs b/src/Sound/Tidal/Stream/UI.hs index 0cb3c224..35de17bc 100644 --- a/src/Sound/Tidal/Stream/UI.hs +++ b/src/Sound/Tidal/Stream/UI.hs @@ -127,7 +127,7 @@ streamAll s f = do streamGet :: Stream -> String -> IO (Maybe Value) streamGet s k = Map.lookup k <$> readMVar (sStateMV s) -streamSet :: Valuable a => Stream -> String -> Pattern a -> IO () +streamSet :: (Valuable a) => Stream -> String -> Pattern a -> IO () streamSet s k pat = do sMap <- takeMVar $ sStateMV s let pat' = toValue <$> pat diff --git a/src/Sound/Tidal/Time.hs b/src/Sound/Tidal/Time.hs index 0d09ca01..616680c6 100644 --- a/src/Sound/Tidal/Time.hs +++ b/src/Sound/Tidal/Time.hs @@ -24,9 +24,9 @@ instance Applicative ArcF where pure t = Arc t t (<*>) (Arc sf ef) (Arc sx ex) = Arc (sf sx) (ef ex) -instance NFData a => NFData (ArcF a) +instance (NFData a) => NFData (ArcF a) -instance Num a => Num (ArcF a) where +instance (Num a) => Num (ArcF a) where negate = fmap negate (+) = liftA2 (+) (*) = liftA2 (*) @@ -46,11 +46,11 @@ sam :: Time -> Time sam = fromIntegral . (floor :: Time -> Int) -- | Turns a number into a (rational) time value. An alias for @toRational@. -toTime :: Real a => a -> Rational +toTime :: (Real a) => a -> Rational toTime = toRational -- | Turns a (rational) time value into another number. An alias for @fromRational@. -fromTime :: Fractional a => Time -> a +fromTime :: (Fractional a) => Time -> a fromTime = fromRational -- | The end point of the current cycle (and starting point of the next cycle) @@ -122,7 +122,7 @@ cycleArc (Arc s e) = Arc (cyclePos s) (cyclePos s + (e - s)) -- are not necessarily completely contained in the input @Arc@, -- but they definitely overlap it, -- and they include every cycle that overlaps it. -cyclesInArc :: Integral a => Arc -> [a] +cyclesInArc :: (Integral a) => Arc -> [a] cyclesInArc (Arc s e) | s > e = [] | s == e = [floor s] diff --git a/src/Sound/Tidal/UI.hs b/src/Sound/Tidal/UI.hs index 70900fa7..10670277 100644 --- a/src/Sound/Tidal/UI.hs +++ b/src/Sound/Tidal/UI.hs @@ -84,10 +84,10 @@ xorwise x = in xor (shiftL b 5) b -- stretch 300 cycles over the range of [0,2**29 == 536870912) then apply the xorshift algorithm -timeToIntSeed :: RealFrac a => a -> Int -timeToIntSeed = xorwise . truncate . (* 536870912) . snd . (properFraction :: (RealFrac a => a -> (Int, a))) . (/ 300) +timeToIntSeed :: (RealFrac a) => a -> Int +timeToIntSeed = xorwise . truncate . (* 536870912) . snd . (properFraction :: ((RealFrac a) => a -> (Int, a))) . (/ 300) -intSeedToRand :: Fractional a => Int -> a +intSeedToRand :: (Fractional a) => Int -> a intSeedToRand = (/ 536870912) . realToFrac . (`mod` 536870912) timeToRand :: (RealFrac a, Fractional b) => a -> b @@ -96,7 +96,7 @@ timeToRand = intSeedToRand . timeToIntSeed timeToRands :: (RealFrac a, Fractional b) => a -> Int -> [b] timeToRands t n = timeToRands' (timeToIntSeed t) n -timeToRands' :: Fractional a => Int -> Int -> [a] +timeToRands' :: (Fractional a) => Int -> Int -> [a] timeToRands' seed n | n <= 0 = [] | otherwise = (intSeedToRand seed) : (timeToRands' (xorwise seed) (n - 1)) @@ -131,7 +131,7 @@ timeToRands' seed n -- 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 :: (Fractional a) => Pattern a 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. @@ -151,10 +151,10 @@ _brandBy prob = fmap (< prob) rand -- @ -- d1 $ segment 4 $ n (irand 5) # sound "drum" -- @ -irand :: Num a => Pattern Int -> Pattern a +irand :: (Num a) => Pattern Int -> Pattern a irand = (>>= _irand) -_irand :: Num a => Int -> Pattern a +_irand :: (Num a) => Int -> Pattern a _irand i = fromIntegral . (floor :: Double -> Int) . (* fromIntegral i) <$> rand -- | 1D Perlin (smooth) noise, works like 'rand' but smoothly moves between random @@ -167,7 +167,7 @@ _irand i = fromIntegral . (floor :: Double -> Int) . (* fromIntegral i) <$> rand -- repeat every cycle (because the saw does). -- -- The `perlin` function uses the cycle count as input and can be used much like @rand@. -perlinWith :: Fractional a => Pattern Double -> Pattern a +perlinWith :: (Fractional a) => Pattern Double -> Pattern a perlinWith p = fmap realToFrac $ (interp) <$> (p - pa) <*> (timeToRand <$> pa) <*> (timeToRand <$> pb) where pa = (fromIntegral :: Int -> Double) . floor <$> p @@ -183,7 +183,7 @@ perlinWith p = fmap realToFrac $ (interp) <$> (p - pa) <*> (timeToRand <$> pa) < -- -- > d1 $ sound "bd*32" # speed (fast 4 $ perlin + 0.5) -- > d1 $ sound "bd*32" # speed (slow 4 $ perlin + 0.5) -perlin :: Fractional a => Pattern a +perlin :: (Fractional a) => Pattern a perlin = perlinWith (sig fromRational) -- | @perlin2With@ is Perlin noise with a 2-dimensional input. This can be @@ -216,7 +216,8 @@ perlin2With x y = (/ 2) . (+ 1) $ interp2 <$> xfrac <*> yfrac <*> dota <*> dotb dotc = pcos (fl x) (ce y) * xfrac + psin (fl x) (ce y) * (yfrac - 1) dotd = pcos (ce x) (ce y) * (xfrac - 1) + psin (ce x) (ce y) * (yfrac - 1) interp2 x' y' a b c d = - (1.0 - s x') * (1.0 - s y') * a + s x' * (1.0 - s y') * b + (1.0 - s x') * (1.0 - s y') * a + + s x' * (1.0 - s y') * b + (1.0 - s x') * s y' * c + s x' * s y' * d s x' = 6.0 * x' ** 5 - 15.0 * x' ** 4 + 10.0 * x' ** 3 @@ -646,7 +647,7 @@ fastspread f xs p = fastcat $ map (`f` p) xs -- using `spread'` though is that you can provide polyphonic parameters, e.g.: -- -- > d1 $ spread' slow "[2 4%3, 3]" $ sound "ho ho:2 ho:3 hc" -spread' :: Monad m => (a -> b -> m c) -> m a -> b -> m c +spread' :: (Monad m) => (a -> b -> m c) -> m a -> b -> m c spread' f vpat pat = vpat >>= \v -> f v pat -- | @spreadChoose f xs p@ is similar to `slowspread` but picks values from @@ -1007,7 +1008,7 @@ euclidInv = patternify2 _euclidInv _euclidInv :: Int -> Int -> Pattern a -> Pattern a _euclidInv n k a = _euclid (-n) k a -index :: Real b => b -> Pattern b -> Pattern c -> Pattern c +index :: (Real b) => b -> Pattern b -> Pattern c -> Pattern c index sz indexpat pat = spread' (zoom' $ toRational sz) (toRational . (* (1 - sz)) <$> indexpat) pat where @@ -1035,8 +1036,8 @@ prr = prrw $ flip const {-| @preplace (blen, plen) beats values@ combines the timing of @beats@ with the values of @values@. Other ways of saying this are: -* sequential convolution -* @values@ quantized to @beats@. +\* sequential convolution +\* @values@ quantized to @beats@. Examples: @@ -1135,11 +1136,11 @@ pequal cycles p1 p2 = (sort $ arc p1 (0, cycles)) == (sort $ arc p2 (0, cycles)) -- Additional example: -- -- > d1 $ every 4 (rot 2) $ slow 2 $ sound "bd hh hh hh" -rot :: Ord a => Pattern Int -> Pattern a -> Pattern a +rot :: (Ord a) => Pattern Int -> Pattern a -> Pattern a 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 +_rot :: (Ord a) => Int -> Pattern a -> Pattern a _rot i pat = splitQueries $ pat {query = \st -> f st (query pat (st {arc = wholeCycle (arc st)}))} where -- TODO maybe events with the same arc (part+whole) should be @@ -1147,15 +1148,15 @@ _rot i pat = splitQueries $ pat {query = \st -> f st (query pat (st {arc = whole f st es = constrainEvents (arc st) $ shiftValues $ sort $ defragParts es shiftValues es | i >= 0 = - zipWith - (\e s -> e {value = s}) - es - (drop i $ cycle $ map value es) + zipWith + (\e s -> e {value = s}) + es + (drop i $ cycle $ map value es) | otherwise = - zipWith - (\e s -> e {value = s}) - es - (drop (length es - abs i) $ cycle $ map value es) + zipWith + (\e s -> e {value = s}) + es + (drop (length es - abs i) $ cycle $ map value es) wholeCycle (Arc s _) = Arc (sam s) (nextSam s) constrainEvents :: Arc -> [Event a] -> [Event a] constrainEvents a es = mapMaybe (constrainEvent a) es @@ -1238,7 +1239,7 @@ _fit perCycle xs p = (xs !!!) <$> (p {query = map (\e -> fmap (+ pos e) e) . que where pos e = perCycle * floor (start $ part e) -permstep :: RealFrac b => Int -> [a] -> Pattern b -> Pattern a +permstep :: (RealFrac b) => Int -> [a] -> Pattern b -> Pattern a permstep nSteps things p = unwrap $ (\n -> fastFromList $ concatMap (\x -> replicate (fst x) (snd x)) $ zip (ps !! floor (n * fromIntegral (length ps - 1))) things) <$> _segment 1 p where ps = permsort (length things) nSteps @@ -1318,10 +1319,10 @@ randStruct n = splitQueries $ Pattern f Nothing Nothing i ) ) - $ enumerate $ - value $ - head $ - queryArc (randArcs n) (Arc (sam s) (nextSam s)) + $ enumerate + $ value + $ head + $ queryArc (randArcs n) (Arc (sam s) (nextSam s)) (Arc s e) = arc st -- TODO - what does this do? @@ -1406,7 +1407,7 @@ lindenmayer n r s = iterate (lindenmayer 1 r) s !! n -- | @lindenmayerI@ converts the resulting string into a a list of integers -- with @fromIntegral@ applied (so they can be used seamlessly where floats or -- rationals are required) -lindenmayerI :: Num b => Int -> String -> String -> [b] +lindenmayerI :: (Num b) => Int -> String -> String -> [b] lindenmayerI n r s = fmap (fromIntegral . digitToInt) $ lindenmayer n r s -- | @runMarkov n tmat xi seed@ generates a Markov chain (as a list) of length @n@ @@ -1553,7 +1554,7 @@ fit' cyc n from to p = squeezeJoin $ _fit n mapMasks to where mapMasks = [ stretch $ mask (const True <$> filterValues (== i) from') p' - | i <- [0 .. n - 1] + | i <- [0 .. n - 1] ] p' = density cyc p from' = density cyc from @@ -1579,19 +1580,19 @@ fit' cyc n from to p = squeezeJoin $ _fit n mapMasks to chunk :: Pattern Int -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b chunk npat f p = innerJoin $ (\n -> _chunk n f p) <$> npat -_chunk :: Integral a => a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b +_chunk :: (Integral a) => a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b _chunk n f p | n >= 0 = cat [withinArc (Arc (i % fromIntegral n) ((i + 1) % fromIntegral n)) f p | i <- [0 .. fromIntegral n - 1]] | otherwise = do - i <- _slow (toRational (-n)) $ rev $ run (fromIntegral (-n)) - withinArc (Arc (i % fromIntegral (-n)) ((i + 1) % fromIntegral (-n))) f p + i <- _slow (toRational (-n)) $ rev $ run (fromIntegral (-n)) + withinArc (Arc (i % fromIntegral (-n)) ((i + 1) % fromIntegral (-n))) f p -- | DEPRECATED, use 'chunk' with negative numbers instead -chunk' :: Integral a1 => Pattern a1 -> (Pattern a2 -> Pattern a2) -> Pattern a2 -> Pattern a2 +chunk' :: (Integral a1) => Pattern a1 -> (Pattern a2 -> Pattern a2) -> Pattern a2 -> Pattern a2 chunk' npat f p = innerJoin $ (\n -> _chunk' n f p) <$> npat -- | DEPRECATED, use '_chunk' with negative numbers instead -_chunk' :: Integral a => a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b +_chunk' :: (Integral a) => a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b _chunk' n f p = _chunk (-n) f p -- | @@ -1705,13 +1706,13 @@ seqPLoop ps = timeLoop (pure $ maxT - minT) $ minT `rotL` seqP ps -- use 'toScale''. -- -- @toScale = toScale' 12@ -toScale :: Num a => [a] -> Pattern Int -> Pattern a +toScale :: (Num a) => [a] -> Pattern Int -> Pattern a toScale = toScale' 12 -- | As 'toScale', though allowing scales of arbitrary size. -- -- An example: @toScale' 24 [0,4,7,10,14,17] (run 8)@ turns into @"0 4 7 10 14 17 24 28"@. -toScale' :: Num a => Int -> [a] -> Pattern Int -> Pattern a +toScale' :: (Num a) => Int -> [a] -> Pattern Int -> Pattern a toScale' _ [] = const silence toScale' o s = fmap noteInScale where @@ -1893,8 +1894,7 @@ ur t outer_p ps fs = _slow t $ unwrap $ adjust <$> timedValues (getPat . split < timedValues = filterJust . withEvent - ( \(Event c ma a' v) -> Event c ma a' (ma >>= \a -> Just (a, v)) - ) + (\(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 @@ -2254,7 +2254,7 @@ while b f pat = keepTactus pat $ sew b (f pat) pat -- is functionally equivalent to -- -- > d1 $ stut 4 1 (1/16) $ s "bd cp" -stutter :: Integral i => i -> Time -> Pattern a -> Pattern a +stutter :: (Integral i) => i -> Time -> Pattern a -> Pattern a stutter n t p = stack $ map (\i -> (t * fromIntegral i) `rotR` p) [0 .. (n - 1)] -- | The @jux@ function creates strange stereo effects by applying a @@ -2366,14 +2366,14 @@ pick name n = name ++ ":" ++ show n -- to be a function of type @Pattern String -> Pattern Int -> Pattern String@. -- -- @samples = liftA2 pick@ -samples :: Applicative f => f String -> f Int -> f String +samples :: (Applicative f) => f String -> f Int -> f String samples p p' = pick <$> p <*> p' -- | -- Equivalent to 'samples', though the sample specifier pattern -- (the @f Int@) will be evaluated first. Not a large difference -- in the majority of cases. -samples' :: Applicative f => f String -> f Int -> f String +samples' :: (Applicative f) => f String -> f Int -> f String samples' p p' = flip pick <$> p' <*> p {- @@ -2396,7 +2396,7 @@ scrumple o p p' = p'' -- overlay p (o `rotR` p'') spreadf :: [a -> Pattern b] -> a -> Pattern b spreadf = spread ($) -stackwith :: Unionable a => Pattern a -> [Pattern a] -> Pattern a +stackwith :: (Unionable a) => Pattern a -> [Pattern a] -> Pattern a stackwith p ps | null ps = silence | otherwise = stack $ map (\(i, p') -> p' # ((fromIntegral i % l) `rotL` p)) (zip [0 :: Int ..] ps) @@ -2419,7 +2419,7 @@ cross f p p' = pattern $ \t -> concat [filter flt $ arc p t, -- -- > d1 $ jux (iter 4) $ sound "arpy arpy:2*2" -- > |+ speed (slow 4 $ sine1 * 0.5 + 1) -range :: Num a => Pattern a -> Pattern a -> Pattern a -> Pattern a +range :: (Num a) => Pattern a -> Pattern a -> Pattern a -> Pattern a range fromP toP p = (\from to v -> ((v * (to - from)) + from)) <$> fromP *> toP *> p _range :: (Functor f, Num b) => b -> b -> f b -> f b @@ -2459,7 +2459,7 @@ off tp f p = innerJoin $ (\tv -> _off tv f p) <$> tp _off :: Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a _off t f p = superimpose (f . (t `rotR`)) p -offadd :: Num a => Pattern Time -> Pattern a -> Pattern a -> Pattern a +offadd :: (Num a) => Pattern Time -> Pattern a -> Pattern a -> Pattern a offadd tp pn p = off tp (+ pn) p -- | @@ -2725,22 +2725,22 @@ unfixRange = contrastRange id -- @quantise@ with fractional inputs does the consistent thing: @quantise 0.5@ -- rounds values to the nearest @2@, @quantise 0.25@ rounds the nearest @4@, etc. quantise :: (Functor f, RealFrac b) => b -> f b -> f b -quantise n = fmap ((/ n) . (fromIntegral :: RealFrac b => Int -> b) . round . (* n)) +quantise n = fmap ((/ n) . (fromIntegral :: (RealFrac b) => Int -> b) . round . (* n)) -- | As 'quantise', but uses 'Prelude.floor' to calculate divisions. qfloor :: (Functor f, RealFrac b) => b -> f b -> f b -qfloor n = fmap ((/ n) . (fromIntegral :: RealFrac b => Int -> b) . floor . (* n)) +qfloor n = fmap ((/ n) . (fromIntegral :: (RealFrac b) => Int -> b) . floor . (* n)) -- | As 'quantise', but uses 'Prelude.ceiling' to calculate divisions. qceiling :: (Functor f, RealFrac b) => b -> f b -> f b -qceiling n = fmap ((/ n) . (fromIntegral :: RealFrac b => Int -> b) . ceiling . (* n)) +qceiling n = fmap ((/ n) . (fromIntegral :: (RealFrac b) => Int -> b) . ceiling . (* n)) -- | An alias for 'quantise'. qround :: (Functor f, RealFrac b) => b -> f b -> f b qround = quantise -- | Inverts all the values in a boolean pattern -inv :: Functor f => f Bool -> f Bool +inv :: (Functor f) => f Bool -> f Bool inv = (not <$>) -- | Serialises a pattern so there's only one event playing at any one @@ -2778,7 +2778,7 @@ mono p = pattern $ \(State a cm) -> flatten $ query p (State a cm) -- smooth :: Pattern Double -> Pattern Double -- TODO - test this with analog events -smooth :: Fractional a => Pattern a -> Pattern a +smooth :: (Fractional a) => Pattern a -> Pattern a 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)) @@ -2805,7 +2805,7 @@ smooth p = pattern $ \st@(State a cm) -> tween st a $ query monoP (State (midArc monoP = mono p -- | Looks up values from a list of tuples, in order to swap values in the given pattern -swap :: Eq a => [(a, b)] -> Pattern a -> Pattern b +swap :: (Eq a) => [(a, b)] -> Pattern a -> Pattern b swap things p = filterJust $ (`lookup` things) <$> p -- | @@ -2917,10 +2917,10 @@ _chew n ipat pat = (squeezeJoinUp $ zoompat <$> ipat) |/ P.speed (pure $ fromInt chew :: Pattern Int -> Pattern Int -> ControlPattern -> ControlPattern chew npat ipat pat = innerJoin $ (\n -> _chew n ipat pat) <$> npat -__binary :: Data.Bits.Bits b => Int -> b -> [Bool] +__binary :: (Data.Bits.Bits b) => Int -> b -> [Bool] __binary n num = map (testBit num) $ reverse [0 .. n - 1] -_binary :: Data.Bits.Bits b => Int -> b -> Pattern Bool +_binary :: (Data.Bits.Bits b) => Int -> b -> Pattern Bool _binary n num = listToPat $ __binary n num _binaryN :: Int -> Pattern Int -> Pattern Bool diff --git a/src/Sound/Tidal/Utils.hs b/src/Sound/Tidal/Utils.hs index b754d6bf..95e822b4 100644 --- a/src/Sound/Tidal/Utils.hs +++ b/src/Sound/Tidal/Utils.hs @@ -47,14 +47,14 @@ mapFst f (x, y) = (f x, y) mapSnd :: (a -> b) -> (c, a) -> (c, b) mapSnd f (x, y) = (x, f y) -delta :: Num a => (a, a) -> a +delta :: (Num a) => (a, a) -> a delta (a, b) = b - a -- | The midpoint of two values -mid :: Fractional a => (a, a) -> a +mid :: (Fractional a) => (a, a) -> a mid (a, b) = a + ((b - a) / 2) -removeCommon :: Eq a => [a] -> [a] -> ([a], [a]) +removeCommon :: (Eq a) => [a] -> [a] -> ([a], [a]) removeCommon [] bs = ([], bs) removeCommon as [] = (as, []) removeCommon (a : as) bs @@ -81,7 +81,7 @@ nth _ [] = Nothing nth 0 (x : _) = Just x nth n (_ : xs) = nth (n - 1) xs -accumulate :: Num t => [t] -> [t] +accumulate :: (Num t) => [t] -> [t] accumulate [] = [] accumulate (x : xs) = scanl (+) x xs @@ -125,15 +125,15 @@ pairs rs = zip rs (tail rs) -- Used under a BSD 3-clause license -- https://hackage.haskell.org/package/containers -nubOrd :: Ord a => [a] -> [a] +nubOrd :: (Ord a) => [a] -> [a] nubOrd = nubOrdOn id {-# INLINE nubOrd #-} -nubOrdOn :: Ord b => (a -> b) -> [a] -> [a] +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 :: (Ord b) => (a -> b) -> Set b -> [a] -> [a] nubOrdOnExcluding f = go where go _ [] = [] diff --git a/test/Sound/Tidal/PatternTest.hs b/test/Sound/Tidal/PatternTest.hs index 3b7929db..b71299c3 100644 --- a/test/Sound/Tidal/PatternTest.hs +++ b/test/Sound/Tidal/PatternTest.hs @@ -247,11 +247,14 @@ run = describe "rotR" $ do it "works over two cycles" $ - property $ comparePD (Arc 0 2) (0.25 ~> pure "a") (0.25 `rotR` pure ("a" :: String)) + property $ + comparePD (Arc 0 2) (0.25 ~> pure "a") (0.25 `rotR` pure ("a" :: String)) it "works over one cycle" $ - property $ compareP (Arc 0 1) (0.25 ~> pure "a") (0.25 `rotR` pure ("a" :: String)) + property $ + compareP (Arc 0 1) (0.25 ~> pure "a") (0.25 `rotR` pure ("a" :: String)) it "works with zero width queries" $ - property $ compareP (Arc 0 0) (0.25 ~> pure "a") (0.25 `rotR` pure ("a" :: String)) + property $ + compareP (Arc 0 0) (0.25 ~> pure "a") (0.25 `rotR` pure ("a" :: String)) describe "comparePD" $ do it "allows split events to be compared" $ diff --git a/test/Sound/Tidal/UITest.hs b/test/Sound/Tidal/UITest.hs index f2aec0f9..453550be 100644 --- a/test/Sound/Tidal/UITest.hs +++ b/test/Sound/Tidal/UITest.hs @@ -29,7 +29,8 @@ run = (slow 2 $ _chop 2 $ s (pure "a")) (begin (pure 0) # end (pure 0.5) # (s (pure "a"))) it "can chop a chop" $ - property $ compareTol (Arc 0 1) (_chop 6 $ s $ pure "a") (_chop 2 $ _chop 3 $ s $ pure "a") + property $ + compareTol (Arc 0 1) (_chop 6 $ s $ pure "a") (_chop 2 $ _chop 3 $ s $ pure "a") describe "segment" $ do it "can turn a single event into multiple events" $ do diff --git a/test/Test.hs b/test/Test.hs index cd495914..785296c9 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -1,18 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} -import Test.Microspec - +import Sound.Tidal.ChordsTest +import Sound.Tidal.ControlTest import Sound.Tidal.CoreTest +import Sound.Tidal.ExceptionsTest import Sound.Tidal.ParamsTest import Sound.Tidal.ParseTest import Sound.Tidal.PatternTest -import Sound.Tidal.ControlTest import Sound.Tidal.ScalesTest -import Sound.Tidal.ChordsTest import Sound.Tidal.StreamTest import Sound.Tidal.UITest import Sound.Tidal.UtilsTest -import Sound.Tidal.ExceptionsTest +import Test.Microspec main :: IO () main = microspec $ do diff --git a/test/TestUtils.hs b/test/TestUtils.hs index eb9928af..5da8a15e 100644 --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -1,31 +1,29 @@ -{-# LANGUAGE OverloadedStrings, FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} module TestUtils where -import Test.Microspec - -import Prelude hiding ((<*), (*>)) - import Data.List (sort) - -import Sound.Tidal.Context - import qualified Data.Map.Strict as Map +import Sound.Tidal.Context +import Test.Microspec +import Prelude hiding ((*>), (<*)) class TolerantEq a where - (~==) :: a -> a -> Bool + (~==) :: a -> a -> Bool instance TolerantEq Double where a ~== b = abs (a - b) < 0.000001 instance TolerantEq Value where - (VS a) ~== (VS b) = a == b - (VI a) ~== (VI b) = a == b - (VR a) ~== (VR b) = a == b - (VF a) ~== (VF b) = abs (a - b) < 0.000001 - _ ~== _ = False + (VS a) ~== (VS b) = a == b + (VI a) ~== (VI b) = a == b + (VR a) ~== (VR b) = a == b + (VF a) ~== (VF b) = abs (a - b) < 0.000001 + _ ~== _ = False -instance TolerantEq a => TolerantEq [a] where +instance (TolerantEq a) => TolerantEq [a] where as ~== bs = (length as == length bs) && all (uncurry (~==)) (zip as bs) instance TolerantEq ValueMap where @@ -38,15 +36,13 @@ instance TolerantEq (Event ValueMap) where compareP :: (Ord a, Show a) => Arc -> Pattern a -> Pattern a -> Property compareP a p p' = (sort $ queryArc (stripContext p) a) - `shouldBe` - (sort $ queryArc (stripContext p') a) + `shouldBe` (sort $ queryArc (stripContext p') a) -- | Like @compareP@, but tries to 'defragment' the events comparePD :: (Ord a, Show a) => Arc -> Pattern a -> Pattern a -> Property comparePD a p p' = (sort $ defragParts $ queryArc (stripContext p) a) - `shouldBe` - (sort $ defragParts $ queryArc (stripContext p') a) + `shouldBe` (sort $ defragParts $ queryArc (stripContext p') a) -- | Like @compareP@, but for control patterns, with some tolerance for floating point error compareTol :: Arc -> ControlPattern -> ControlPattern -> Bool diff --git a/test/dontcrash.hs b/test/dontcrash.hs index e6194110..4e4799f8 100644 --- a/test/dontcrash.hs +++ b/test/dontcrash.hs @@ -1,13 +1,10 @@ --- | test cases collected from some "Crash bugs" - -{-# language OverloadedStrings #-} +-- \| test cases collected from some "Crash bugs" +{-# LANGUAGE OverloadedStrings #-} import Control.Concurrent (threadDelay) import Control.Monad (forM_) - import Sound.Tidal.Context - main = do tidal <- startTidal (superdirtTarget {oLatency = 0.1, oAddress = "127.0.0.1", oPort = 57120}) (defaultConfig) let p = streamReplace tidal @@ -17,30 +14,31 @@ main = do -- interspersed with a simple pattern. -- The test is whether we hear that simple pattern each time, -- indicating that the Tidal main loop is still usable. - let go ps = forM_ (zip [0::Int ..] ps) $ \ (k,p) -> do - let wait s = threadDelay $ s * 10^6 + let go ps = forM_ (zip [0 :: Int ..] ps) $ \(k, p) -> do + let wait s = threadDelay $ s * 10 ^ 6 simple = s "[bd*4, 808cy*8]" putStrLn $ "--- playing test pattern " ++ show k ++ " -----" - d1 $ p ; wait 2 + d1 $ p + wait 2 putStrLn $ "---------------- playing simple pattern" - d1 $ simple ; wait 2 - - go [ "cr" - - -- https://github.com/tidalcycles/Tidal/issues/606#issue-563234396 - , gain (unwrap $ fmap (["1", "0."]!!) $ "{0 0@7 0 1@7}%16") # s "harmor" # midichan 11 - - -- https://github.com/tidalcycles/Tidal/issues/606#issuecomment-598776256 - , superimpose (hurry "<0.5 2?") $ sound "bd" - - -- https://github.com/tidalcycles/Tidal/issues/477#issue-411754641 - , let mkpat name pattern = (name,pattern) - mkfx name fx = (name,fx) - structure = cat [ - "kicks@8 [kicks,snares]@7 kicks:backrush" - , "[kicks@3 [kicks@3 kicks(3,8,1):r]]@4 [kicks]@4 [kicks]@7 kicks:r" - ] - pats = [ mkpat "kicks" $ sometimes ghost $ s "bd(<4 5 3 6>,16,<0 1 0 3>)" ] - fx = [ mkfx "r" (# speed "-1") ] + d1 $ simple + wait 2 + + go + [ "cr", + -- https://github.com/tidalcycles/Tidal/issues/606#issue-563234396 + gain (unwrap $ fmap (["1", "0."] !!) $ "{0 0@7 0 1@7}%16") # s "harmor" # midichan 11, + -- https://github.com/tidalcycles/Tidal/issues/606#issuecomment-598776256 + superimpose (hurry "<0.5 2?") $ sound "bd", + -- https://github.com/tidalcycles/Tidal/issues/477#issue-411754641 + let mkpat name pattern = (name, pattern) + mkfx name fx = (name, fx) + structure = + cat + [ "kicks@8 [kicks,snares]@7 kicks:backrush", + "[kicks@3 [kicks@3 kicks(3,8,1):r]]@4 [kicks]@4 [kicks]@7 kicks:r" + ] + pats = [mkpat "kicks" $ sometimes ghost $ s "bd(<4 5 3 6>,16,<0 1 0 3>)"] + fx = [mkfx "r" (# speed "-1")] in ur 16 structure pats fx - ] + ] diff --git a/tidal-listener/Setup.hs b/tidal-listener/Setup.hs index 9a994af6..e8ef27db 100644 --- a/tidal-listener/Setup.hs +++ b/tidal-listener/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/tidal-listener/app/Main.hs b/tidal-listener/app/Main.hs index 0a307fee..ce65772b 100644 --- a/tidal-listener/app/Main.hs +++ b/tidal-listener/app/Main.hs @@ -1,6 +1,6 @@ +import Options.Applicative (execParser) import Sound.Tidal.Listener import Sound.Tidal.Listener.Command -import Options.Applicative (execParser) main :: IO () main = do diff --git a/tidal-listener/src/Sound/Tidal/Hint.hs b/tidal-listener/src/Sound/Tidal/Hint.hs index 5e963db6..85ac9fe3 100644 --- a/tidal-listener/src/Sound/Tidal/Hint.hs +++ b/tidal-listener/src/Sound/Tidal/Hint.hs @@ -1,25 +1,20 @@ module Sound.Tidal.Hint where -import Control.Exception (SomeException) -import Control.Monad.Catch (catch) +import Control.Concurrent.MVar (MVar, putMVar, takeMVar) import Control.DeepSeq (deepseq) -import Control.Concurrent.MVar (MVar, putMVar, takeMVar) - -import System.FilePath (dropFileName) -import System.Environment (getExecutablePath) - -import Sound.Tidal.Context (Stream) - +import Control.Exception (SomeException) +import Control.Monad.Catch (catch) +import Data.IORef +import Data.List (intercalate) import Language.Haskell.Interpreter as Hint import Language.Haskell.Interpreter.Unsafe as Hint - -import Data.List (intercalate) -import Data.IORef - +import Sound.Tidal.Context (Stream) import Sound.Tidal.Listener.Config import Sound.Tidal.Listener.Parse +import System.Environment (getExecutablePath) +import System.FilePath (dropFileName) -ghcArgs:: String -> [String] +ghcArgs :: String -> [String] ghcArgs lib = ["-clear-package-db", "-package-db", lib ++ "haskell-libs/package.conf.d", "-package-db", lib ++ "haskell-libs/package.db", "-v"] unsafeInterpreter :: Interpreter a -> IO (Either InterpreterError a) @@ -27,84 +22,87 @@ unsafeInterpreter interpreter = do execPath <- dropFileName <$> getExecutablePath Hint.unsafeRunInterpreterWithArgsLibdir (ghcArgs execPath) (execPath ++ "haskell-libs") interpreter -data InterpreterMessage = MStat String - | MType String - | MLoad String - deriving Show +data InterpreterMessage + = MStat String + | MType String + | MLoad String + deriving (Show) -data InterpreterResponse = RStat (Maybe String) - | RType String - | RError String - deriving Show +data InterpreterResponse + = RStat (Maybe String) + | RType String + | RError String + deriving (Show) startHintJob :: Bool -> Stream -> MVar InterpreterMessage -> MVar InterpreterResponse -> IO () -startHintJob safe str mMV rMV | safe = hintJob Hint.runInterpreter str mMV rMV - | otherwise = hintJob unsafeInterpreter str mMV rMV +startHintJob safe str mMV rMV + | safe = hintJob Hint.runInterpreter str mMV rMV + | otherwise = hintJob unsafeInterpreter str mMV rMV -hintJob :: (Interpreter () -> IO (Either InterpreterError ())) -> Stream -> MVar InterpreterMessage -> MVar InterpreterResponse -> IO () +hintJob :: (Interpreter () -> IO (Either InterpreterError ())) -> Stream -> MVar InterpreterMessage -> MVar InterpreterResponse -> IO () hintJob interpreter str mMV rMV = do - result <- catch (interpreter $ (staticInterpreter str) >> (interpreterLoop mMV rMV)) - (\e -> return (Left e)) - -- can this happen? If it happens all definitions made interactively are lost... - let response = case result of - Left err -> RError (parseError err) - Right p -> RError (show p) - putMVar rMV response - hintJob interpreter str mMV rMV + result <- + catch + (interpreter $ (staticInterpreter str) >> (interpreterLoop mMV rMV)) + (\e -> return (Left e)) + -- can this happen? If it happens all definitions made interactively are lost... + let response = case result of + Left err -> RError (parseError err) + Right p -> RError (show p) + putMVar rMV response + hintJob interpreter str mMV rMV -- this is the basic interpreter that will be only loaded once staticInterpreter :: Stream -> Interpreter () staticInterpreter str = do - Hint.set [languageExtensions := exts] - Hint.setImportsF libs - bind "tidal" str - Hint.runStmt bootTidal - return () + Hint.set [languageExtensions := exts] + Hint.setImportsF libs + bind "tidal" str + Hint.runStmt bootTidal + return () -- this is the intrepreter receiving and interpreteing messages and sending the results back interpreterLoop :: MVar InterpreterMessage -> MVar InterpreterResponse -> Interpreter () interpreterLoop mMV rMV = do - message <- liftIO $ takeMVar mMV - case message of - MStat cont -> catch (interpretStatement cont rMV) (\e -> liftIO $ putMVar rMV $ RError $ show (e :: SomeException)) - MType cont -> catch (interpretType cont rMV) (\e -> liftIO $ putMVar rMV $ RError $ show (e :: SomeException)) - MLoad path -> catch (interpretFile path rMV) (\e -> liftIO $ putMVar rMV $ RError $ show (e :: SomeException)) - interpreterLoop mMV rMV - + message <- liftIO $ takeMVar mMV + case message of + MStat cont -> catch (interpretStatement cont rMV) (\e -> liftIO $ putMVar rMV $ RError $ show (e :: SomeException)) + MType cont -> catch (interpretType cont rMV) (\e -> liftIO $ putMVar rMV $ RError $ show (e :: SomeException)) + MLoad path -> catch (interpretFile path rMV) (\e -> liftIO $ putMVar rMV $ RError $ show (e :: SomeException)) + interpreterLoop mMV rMV interpretStatement :: String -> MVar InterpreterResponse -> Interpreter () interpretStatement cont rMV = do - t <- Hint.typeChecksWithDetails cont - case t of - -- if the expression doesn't type check try to just evaluate it (it could be a definition or binding) - Left _ -> catch (Hint.runStmt cont >> (liftIO $ putMVar rMV $ RStat Nothing)) - (\e -> liftIO $ putMVar rMV $ RError $ parseError e) - Right _ -> do - Hint.runStmt ("(tmpMsg, !temp) <- hCapture [stderr] $ " ++ cont) - out <- Hint.eval "temp" - -- force complete evaluation of 'out', so that any possible error is thrown here - msg <- deepseq out (Hint.interpret "tmpMsg" (Hint.as :: String)) - case msg of - "" -> liftIO $ putMVar rMV $ RStat (Just out) - _ -> liftIO $ putMVar rMV $ RError msg + t <- Hint.typeChecksWithDetails cont + case t of + -- if the expression doesn't type check try to just evaluate it (it could be a definition or binding) + Left _ -> + catch + (Hint.runStmt cont >> (liftIO $ putMVar rMV $ RStat Nothing)) + (\e -> liftIO $ putMVar rMV $ RError $ parseError e) + Right _ -> do + Hint.runStmt ("(tmpMsg, !temp) <- hCapture [stderr] $ " ++ cont) + out <- Hint.eval "temp" + -- force complete evaluation of 'out', so that any possible error is thrown here + msg <- deepseq out (Hint.interpret "tmpMsg" (Hint.as :: String)) + case msg of + "" -> liftIO $ putMVar rMV $ RStat (Just out) + _ -> liftIO $ putMVar rMV $ RError msg interpretType :: String -> MVar InterpreterResponse -> Interpreter () interpretType cont rMV = do - t <- Hint.typeChecksWithDetails cont - case t of - Left errors -> liftIO $ putMVar rMV $ RError $ intercalate "\n" $ map errMsg errors - Right out -> liftIO $ putMVar rMV $ RType out - + t <- Hint.typeChecksWithDetails cont + case t of + Left errors -> liftIO $ putMVar rMV $ RError $ intercalate "\n" $ map errMsg errors + Right out -> liftIO $ putMVar rMV $ RType out interpretFile :: String -> MVar InterpreterResponse -> Interpreter () interpretFile path rMV = do - cont <- liftIO $ readFile path - let bs = blocks cont - catch ((sequence $ map Hint.runStmt bs) >> (liftIO $ putMVar rMV $ RStat Nothing) >> return ()) (\e -> liftIO $ putMVar rMV $ RError $ parseError e) - - + cont <- liftIO $ readFile path + let bs = blocks cont + catch ((sequence $ map Hint.runStmt bs) >> (liftIO $ putMVar rMV $ RStat Nothing) >> return ()) (\e -> liftIO $ putMVar rMV $ RError $ parseError e) -parseError:: InterpreterError -> String +parseError :: InterpreterError -> String parseError (UnknownError s) = "Unknown error: " ++ s parseError (WontCompile es) = "Compile error: " ++ (intercalate "\n" (Prelude.map errMsg es)) parseError (NotAllowed s) = "NotAllowed error: " ++ s @@ -119,6 +117,6 @@ bind var value = do runManyStmt :: [String] -> Interpreter () runManyStmt [] = return () -runManyStmt (x:xs) = do - runStmt x - runManyStmt xs +runManyStmt (x : xs) = do + runStmt x + runManyStmt xs diff --git a/tidal-listener/src/Sound/Tidal/Listener.hs b/tidal-listener/src/Sound/Tidal/Listener.hs index b5dce522..775abb27 100644 --- a/tidal-listener/src/Sound/Tidal/Listener.hs +++ b/tidal-listener/src/Sound/Tidal/Listener.hs @@ -1,34 +1,33 @@ {-# LANGUAGE RecordWildCards #-} + module Sound.Tidal.Listener where -import Sound.Tidal.Stream (streamGetCPS) +import Control.Concurrent +import qualified Network.Socket as N +import Sound.Osc.Fd as O +import Sound.Osc.Transport.Fd.Udp as UDP import qualified Sound.Tidal.Context as T import Sound.Tidal.Hint import Sound.Tidal.Listener.Config -import Sound.Osc.Fd as O -import Sound.Osc.Transport.Fd.Udp as UDP -import Control.Concurrent -import qualified Network.Socket as N - +import Sound.Tidal.Stream (streamGetCPS) -data State = State - { sIn :: MVar InterpreterMessage - , sOut :: MVar InterpreterResponse - , sLocal :: Udp - , sRemote :: N.SockAddr - , sStream :: T.Stream +data State = State + { sIn :: MVar InterpreterMessage, + sOut :: MVar InterpreterResponse, + sLocal :: Udp, + sRemote :: N.SockAddr, + sStream :: T.Stream } - -- | Start Haskell interpreter, with input and output mutable variables to -- communicate with it listenWithConfig :: Config -> IO () -listenWithConfig Config{..} = do +listenWithConfig Config {..} = do putStrLn $ "Starting Tidal Listener " ++ if noGHC then "without installed GHC" else "with installed GHC" putStrLn $ "Listening for OSC commands on port " ++ show listenPort putStrLn $ "Sending replies to port " ++ show replyPort - --start the stream + -- start the stream stream <- startListenerStream replyPort dirtPort mIn <- newEmptyMVar @@ -37,69 +36,71 @@ listenWithConfig Config{..} = do putStrLn "Starting tidal interpreter.. " _ <- forkIO $ startHintJob True stream mIn mOut - (remote_addr:_) <- N.getAddrInfo Nothing (Just "127.0.0.1") Nothing + (remote_addr : _) <- N.getAddrInfo Nothing (Just "127.0.0.1") Nothing let iOlocal = udpServer "127.0.0.1" listenPort local <- iOlocal - let (N.SockAddrInet _ a) = N.addrAddress remote_addr - remote = N.SockAddrInet (fromIntegral replyPort) a - st = State mIn mOut local remote stream + remote = N.SockAddrInet (fromIntegral replyPort) a + st = State mIn mOut local remote stream loop st - where - loop st = do - m <- O.recvMessage (sLocal st) - st' <- act st m - loop st' - + where + loop st = do + m <- O.recvMessage (sLocal st) + st' <- act st m + loop st' act :: State -> Maybe O.Message -> IO State - -- ask the interpreter to execute a statment: statments are expressions of type IO a or bindings/definitions, -- in case of execution of an action of type IO a, the interpreter will try to show a and send it back -- if a doesn't have a Show instance, an error is thrown act st (Just (Message "/eval" [AsciiString statement])) = - do putMVar (sIn st) (MStat $ ascii_to_string statement) - r <- takeMVar (sOut st) - case r of - RStat (Just x) -> UDP.sendTo (sLocal st) (O.p_message "/eval/value" [string x]) (sRemote st) - RStat Nothing -> UDP.sendTo (sLocal st) (O.p_message "/eval/ok" []) (sRemote st) - RError e -> UDP.sendTo (sLocal st) (O.p_message "/eval/error" [string e]) (sRemote st) - _ -> return () - return st + do + putMVar (sIn st) (MStat $ ascii_to_string statement) + r <- takeMVar (sOut st) + case r of + RStat (Just x) -> UDP.sendTo (sLocal st) (O.p_message "/eval/value" [string x]) (sRemote st) + RStat Nothing -> UDP.sendTo (sLocal st) (O.p_message "/eval/ok" []) (sRemote st) + RError e -> UDP.sendTo (sLocal st) (O.p_message "/eval/error" [string e]) (sRemote st) + _ -> return () + return st -- ask the interpreter for the type of an expression act st (Just (Message "/type" [AsciiString expression])) = - do putMVar (sIn st) (MType $ ascii_to_string expression) - r <- takeMVar (sOut st) - case r of - RType t -> UDP.sendTo (sLocal st) (O.p_message "/type/ok" [string t]) (sRemote st) - RError e -> UDP.sendTo (sLocal st) (O.p_message "/type/error" [string e]) (sRemote st) - _ -> return () - return st - + do + putMVar (sIn st) (MType $ ascii_to_string expression) + r <- takeMVar (sOut st) + case r of + RType t -> UDP.sendTo (sLocal st) (O.p_message "/type/ok" [string t]) (sRemote st) + RError e -> UDP.sendTo (sLocal st) (O.p_message "/type/error" [string e]) (sRemote st) + _ -> return () + return st act st (Just (Message "/load" [AsciiString path])) = - do putMVar (sIn st) (MLoad $ ascii_to_string path) - r <- takeMVar (sOut st) - case r of - RStat (Just x) -> UDP.sendTo (sLocal st) (O.p_message "/load/value" [string x]) (sRemote st) --cannot happen - RStat Nothing -> UDP.sendTo (sLocal st) (O.p_message "/load/ok" []) (sRemote st) - RError e -> UDP.sendTo (sLocal st) (O.p_message "/load/error" [string e]) (sRemote st) - _ -> return () - return st + do + putMVar (sIn st) (MLoad $ ascii_to_string path) + r <- takeMVar (sOut st) + case r of + RStat (Just x) -> UDP.sendTo (sLocal st) (O.p_message "/load/value" [string x]) (sRemote st) -- cannot happen + RStat Nothing -> UDP.sendTo (sLocal st) (O.p_message "/load/ok" []) (sRemote st) + RError e -> UDP.sendTo (sLocal st) (O.p_message "/load/error" [string e]) (sRemote st) + _ -> return () + return st -- test if the listener is responsive act st (Just (Message "/ping" [])) = - do UDP.sendTo (sLocal st) (O.p_message "/pong" []) (sRemote st) - return st + do + UDP.sendTo (sLocal st) (O.p_message "/pong" []) (sRemote st) + return st -- get the current cps of the running stream act st (Just (Message "/cps" [])) = - do cps <- streamGetCPS (sStream st) - UDP.sendTo (sLocal st) (O.p_message "/cps" [float cps]) (sRemote st) - return st - -act st Nothing = do putStrLn "Not a message?" - return st -act st (Just m) = do putStrLn $ "Unhandled message: " ++ show m - return st + do + cps <- streamGetCPS (sStream st) + UDP.sendTo (sLocal st) (O.p_message "/cps" [float cps]) (sRemote st) + return st +act st Nothing = do + putStrLn "Not a message?" + return st +act st (Just m) = do + putStrLn $ "Unhandled message: " ++ show m + return st diff --git a/tidal-listener/src/Sound/Tidal/Listener/Command.hs b/tidal-listener/src/Sound/Tidal/Listener/Command.hs index 77ea6b1f..34577ce9 100644 --- a/tidal-listener/src/Sound/Tidal/Listener/Command.hs +++ b/tidal-listener/src/Sound/Tidal/Listener/Command.hs @@ -4,45 +4,61 @@ import Options.Applicative import Sound.Tidal.Listener.Config conf :: ParserInfo Config -conf = info (configParser <**> helper) - ( fullDesc - <> progDesc "An OSC interpreter for TidalCycles" - <> header "tidal-listener" ) +conf = + info + (configParser <**> helper) + ( fullDesc + <> progDesc "An OSC interpreter for TidalCycles" + <> header "tidal-listener" + ) configParser :: Parser Config -configParser = Config <$> listenPortParser - <*> replyPortParser - <*> dirtPortParser - <*> noGhcParser +configParser = + Config + <$> listenPortParser + <*> replyPortParser + <*> dirtPortParser + <*> noGhcParser listenPortParser :: Parser Int -listenPortParser = option auto - ( long "listenport" - <> short 'l' - <> help "Specify the listening port" - <> showDefault - <> value 6011 - <> metavar "INT" ) +listenPortParser = + option + auto + ( long "listenport" + <> short 'l' + <> help "Specify the listening port" + <> showDefault + <> value 6011 + <> metavar "INT" + ) replyPortParser :: Parser Int -replyPortParser = option auto - ( long "replyport" - <> short 'r' - <> help "Specify the reply port" - <> showDefault - <> value 6012 - <> metavar "INT") +replyPortParser = + option + auto + ( long "replyport" + <> short 'r' + <> help "Specify the reply port" + <> showDefault + <> value 6012 + <> metavar "INT" + ) dirtPortParser :: Parser Int -dirtPortParser = option auto - ( long "dirtport" - <> short 'd' - <> help "Specify the dirt port" - <> showDefault - <> value 5720 - <> metavar "INT") +dirtPortParser = + option + auto + ( long "dirtport" + <> short 'd' + <> help "Specify the dirt port" + <> showDefault + <> value 5720 + <> metavar "INT" + ) noGhcParser :: Parser Bool -noGhcParser = switch - ( long "no-ghc" - <> help "If this flag is active, the interpreter will assume that GHC not installed on the system" ) +noGhcParser = + switch + ( long "no-ghc" + <> help "If this flag is active, the interpreter will assume that GHC not installed on the system" + ) diff --git a/tidal-listener/src/Sound/Tidal/Listener/Config.hs b/tidal-listener/src/Sound/Tidal/Listener/Config.hs index 8bcf888b..375c9c30 100644 --- a/tidal-listener/src/Sound/Tidal/Listener/Config.hs +++ b/tidal-listener/src/Sound/Tidal/Listener/Config.hs @@ -1,133 +1,140 @@ - module Sound.Tidal.Listener.Config where import Data.List (intercalate) import Language.Haskell.Interpreter -import Sound.Tidal.Stream (Target(..), Stream) import qualified Sound.Tidal.Context as T +import Sound.Tidal.Stream (Stream, Target (..)) -data Config = Config {listenPort :: Int - ,replyPort :: Int - ,dirtPort :: Int - ,noGHC :: Bool - } deriving (Eq,Show) +data Config = Config + { listenPort :: Int, + replyPort :: Int, + dirtPort :: Int, + noGHC :: Bool + } + deriving (Eq, Show) editorTarget :: Int -> Target -editorTarget rPort = Target {oName = "editor" - ,oAddress = "127.0.0.1" - ,oPort = rPort - ,oBusPort = Nothing - ,oLatency = 0.1 - ,oWindow = Nothing - ,oSchedule = T.Live - ,oHandshake = False - } +editorTarget rPort = + Target + { oName = "editor", + oAddress = "127.0.0.1", + oPort = rPort, + oBusPort = Nothing, + oLatency = 0.1, + oWindow = Nothing, + oSchedule = T.Live, + oHandshake = False + } startListenerStream :: Int -> Int -> IO Stream -startListenerStream rPort dPort = T.startStream T.defaultConfig - [(T.superdirtTarget {oPort = dPort, oLatency = 0.1},[T.superdirtShape]) - ,(editorTarget rPort,[T.OSCContext "/code/highlight"]) - ] +startListenerStream rPort dPort = + T.startStream + T.defaultConfig + [ (T.superdirtTarget {oPort = dPort, oLatency = 0.1}, [T.superdirtShape]), + (editorTarget rPort, [T.OSCContext "/code/highlight"]) + ] libsU :: [String] -libsU = [ - "Sound.Tidal.Transition" - , "Sound.Tidal.Context" - , "Sound.Tidal.ID" - , "Sound.Tidal.Simple" - , "Control.Applicative" - , "Data.Bifunctor" - , "Data.Bits" - , "Data.Bool" - , "Data.Char" - , "Data.Either" - , "Data.Foldable" - , "Data.Function" - , "Data.Functor" - , "Data.Int" - , "Data.List" - , "Data.Maybe" - , "Data.Monoid" - , "Data.Ord" - , "Data.Ratio" - , "Data.Semigroup" - , "Data.String" - , "Data.Traversable" - , "Data.Tuple" - , "Data.Typeable" - , "Data.IORef" - , "GHC.Float" - , "GHC.Real" - , "System.IO" - , "System.Directory" +libsU = + [ "Sound.Tidal.Transition", + "Sound.Tidal.Context", + "Sound.Tidal.ID", + "Sound.Tidal.Simple", + "Control.Applicative", + "Data.Bifunctor", + "Data.Bits", + "Data.Bool", + "Data.Char", + "Data.Either", + "Data.Foldable", + "Data.Function", + "Data.Functor", + "Data.Int", + "Data.List", + "Data.Maybe", + "Data.Monoid", + "Data.Ord", + "Data.Ratio", + "Data.Semigroup", + "Data.String", + "Data.Traversable", + "Data.Tuple", + "Data.Typeable", + "Data.IORef", + "GHC.Float", + "GHC.Real", + "System.IO", + "System.Directory" ] libsU' :: [ModuleImport] libsU' = [ModuleImport x NotQualified NoImportList | x <- libsU] libs :: [ModuleImport] -libs = [ModuleImport "Data.Map" (QualifiedAs $ Just "Map") NoImportList - ,ModuleImport "System.IO.Silently" NotQualified (HidingList ["silence"]) - ] ++ libsU' +libs = + [ ModuleImport "Data.Map" (QualifiedAs $ Just "Map") NoImportList, + ModuleImport "System.IO.Silently" NotQualified (HidingList ["silence"]) + ] + ++ libsU' exts :: [Extension] exts = [OverloadedStrings, BangPatterns, MonadComprehensions] - bootTidal' :: [String] -bootTidal' = [ "p = streamReplace tidal" - ,"d1 !pat = p 1 $ pat |< orbit 0" - ,"d2 !pat = p 2 $ pat |< orbit 1" - ,"d3 !pat = p 3 $ pat |< orbit 2" - ,"d4 !pat = p 4 $ pat |< orbit 3" - ,"d5 !pat = p 5 $ pat |< orbit 4" - ,"d6 !pat = p 6 $ pat |< orbit 5" - ,"d7 !pat = p 7 $ pat |< orbit 6" - ,"d8 !pat = p 8 $ pat |< orbit 7" - ,"d9 !pat = p 9 $ pat |< orbit 8" - ,"d10 !pat = p 10 $ pat |< orbit 9" - ,"d11 !pat = p 11 $ pat |< orbit 10" - ,"d12 !pat = p 12 $ pat |< orbit 11" - ,"d13 !pat = p 13 $ pat |< orbit 12" - ,"d14 !pat = p 14 $ pat |< orbit 13" - ,"d15 !pat = p 15 $ pat |< orbit 14" - ,"d16 !pat = p 16 $ pat |< orbit 15" - ,"hush = streamHush tidal" - ,"panic = do hush; once $ sound \"superpanic\"" - ,"list = streamList tidal" - -- ,"mute = streamMute tidal" - --,"unmute = streamUnmute tidal :: Show a => a -> IO ()" - ,"unmuteAll = streamUnmuteAll tidal" - ,"unsoloAll = streamUnsoloAll tidal" - --,"solo = streamSolo tidal :: Show a => a -> IO ()" - --,"unsolo = streamUnsolo tidal :: Show a => a -> IO ()" - ,"once = streamOnce tidal" - ,"first = streamFirst tidal" - ,"asap = once" - ,"nudgeAll = streamNudgeAll tidal" - ,"all = streamAll tidal" - ,"resetCycles = streamResetCycles 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" - ,"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" - ] +bootTidal' = + [ "p = streamReplace tidal", + "d1 !pat = p 1 $ pat |< orbit 0", + "d2 !pat = p 2 $ pat |< orbit 1", + "d3 !pat = p 3 $ pat |< orbit 2", + "d4 !pat = p 4 $ pat |< orbit 3", + "d5 !pat = p 5 $ pat |< orbit 4", + "d6 !pat = p 6 $ pat |< orbit 5", + "d7 !pat = p 7 $ pat |< orbit 6", + "d8 !pat = p 8 $ pat |< orbit 7", + "d9 !pat = p 9 $ pat |< orbit 8", + "d10 !pat = p 10 $ pat |< orbit 9", + "d11 !pat = p 11 $ pat |< orbit 10", + "d12 !pat = p 12 $ pat |< orbit 11", + "d13 !pat = p 13 $ pat |< orbit 12", + "d14 !pat = p 14 $ pat |< orbit 13", + "d15 !pat = p 15 $ pat |< orbit 14", + "d16 !pat = p 16 $ pat |< orbit 15", + "hush = streamHush tidal", + "panic = do hush; once $ sound \"superpanic\"", + "list = streamList tidal", + -- ,"mute = streamMute tidal" + -- ,"unmute = streamUnmute tidal :: Show a => a -> IO ()" + "unmuteAll = streamUnmuteAll tidal", + "unsoloAll = streamUnsoloAll tidal", + -- ,"solo = streamSolo tidal :: Show a => a -> IO ()" + -- ,"unsolo = streamUnsolo tidal :: Show a => a -> IO ()" + "once = streamOnce tidal", + "first = streamFirst tidal", + "asap = once", + "nudgeAll = streamNudgeAll tidal", + "all = streamAll tidal", + "resetCycles = streamResetCycles 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", + "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" + ] bootTidal :: String bootTidal = "let \n" ++ (intercalate "\n" bootTidal') diff --git a/tidal-listener/src/Sound/Tidal/Listener/Parse.hs b/tidal-listener/src/Sound/Tidal/Listener/Parse.hs index 2ea8349e..f7153bbd 100644 --- a/tidal-listener/src/Sound/Tidal/Listener/Parse.hs +++ b/tidal-listener/src/Sound/Tidal/Listener/Parse.hs @@ -1,26 +1,29 @@ module Sound.Tidal.Listener.Parse where isSeperator :: String -> Bool -isSeperator ('\n':xs) = case mungeWhite xs of - ('\n':_) -> True - _ -> False - where mungeWhite (' ':ys) = mungeWhite ys - mungeWhite ('\t':ys) = mungeWhite ys - mungeWhite x = x +isSeperator ('\n' : xs) = case mungeWhite xs of + ('\n' : _) -> True + _ -> False + where + mungeWhite (' ' : ys) = mungeWhite ys + mungeWhite ('\t' : ys) = mungeWhite ys + mungeWhite x = x isSeperator _ = False -oneBlock :: String -> (String,String) +oneBlock :: String -> (String, String) oneBlock s = case isSeperator rest of - False -> case rest == "" of - True -> (white++b++rest,"") - False -> (white++b++r,t) - True -> (white++b,rest) - where (white,s2) = break (\x -> not $ elem x " \t\n") s - (b,rest) = break (=='\n') s2 - (r,t) = oneBlock rest + False -> case rest == "" of + True -> (white ++ b ++ rest, "") + False -> (white ++ b ++ r, t) + True -> (white ++ b, rest) + where + (white, s2) = break (\x -> not $ elem x " \t\n") s + (b, rest) = break (== '\n') s2 + (r, t) = oneBlock rest blocks :: String -> [String] blocks s = case rest == "" of - True -> [b] - False -> b:(blocks rest) - where (b,rest) = oneBlock s + True -> [b] + False -> b : (blocks rest) + where + (b, rest) = oneBlock s diff --git a/tidal-listener/src/Sound/Tidal/Tidali.hs b/tidal-listener/src/Sound/Tidal/Tidali.hs index e13833bc..bdb1edf4 100644 --- a/tidal-listener/src/Sound/Tidal/Tidali.hs +++ b/tidal-listener/src/Sound/Tidal/Tidali.hs @@ -1,57 +1,68 @@ module Sound.Tidal.Tidali where -import Sound.Tidal.Stream (Target(..)) -import qualified Sound.Tidal.Context as T -import Sound.Tidal.Hint import Control.Concurrent import Control.Concurrent.MVar +import qualified Sound.Tidal.Context as T +import Sound.Tidal.Hint +import Sound.Tidal.Stream (Target (..)) import qualified Sound.Tidal.Tempo as Tempo -data State = State {sIn :: MVar String, - sOut :: MVar Response, - sStream :: T.Stream - } +data State = State + { sIn :: MVar String, + sOut :: MVar Response, + sStream :: T.Stream + } -readBlock = do l <- getLine - if l == ":{" - then readBlock' - else (return l) - where readBlock' = do l <- getLine - if l == ":}" - then (return "") - else (fmap ((l ++) . ('\n':)) readBlock') +readBlock = do + l <- getLine + if l == ":{" + then readBlock' + else (return l) + where + readBlock' = do + l <- getLine + if l == ":}" + then (return "") + else (fmap ((l ++) . ('\n' :)) readBlock') main :: IO () -main = do -- start Haskell interpreter, with input and output mutable - -- variables to communicate with it - (mIn, mOut) <- startHint - stream <- - T.startStream T.defaultConfig [(T.superdirtTarget {oLatency = 0.1}, - [T.superdirtShape] - ) - ] - let st = State mIn mOut stream - loopit st - where - loopit :: State -> IO () - loopit st = - do block <- readBlock - st' <- run st block - loopit st' +main = do + -- start Haskell interpreter, with input and output mutable + -- variables to communicate with it + (mIn, mOut) <- startHint + stream <- + T.startStream + T.defaultConfig + [ ( T.superdirtTarget {oLatency = 0.1}, + [T.superdirtShape] + ) + ] + let st = State mIn mOut stream + loopit st + where + loopit :: State -> IO () + loopit st = + do + block <- readBlock + st' <- run st block + loopit st' -- TODO - use Chan or TChan for in/out channels instead of mvars directly? -startHint = do mIn <- newEmptyMVar - mOut <- newEmptyMVar - forkIO $ hintJob mIn mOut - return (mIn, mOut) +startHint = do + mIn <- newEmptyMVar + mOut <- newEmptyMVar + forkIO $ hintJob mIn mOut + return (mIn, mOut) getcps st = streamGetcps (sStream st) run :: State -> String -> IO State run st code = - do putMVar (sIn st) code - r <- takeMVar (sOut st) - respond r - return st - where respond (HintOK pat) = putStrLn $ show pat - respond (HintError s) = putStrLn s + do + putMVar (sIn st) code + r <- takeMVar (sOut st) + respond r + return st + where + respond (HintOK pat) = putStrLn $ show pat + respond (HintError s) = putStrLn s diff --git a/tidal-parse/src/Sound/Tidal/Parse.hs b/tidal-parse/src/Sound/Tidal/Parse.hs index 81911bb6..4a5aea52 100644 --- a/tidal-parse/src/Sound/Tidal/Parse.hs +++ b/tidal-parse/src/Sound/Tidal/Parse.hs @@ -65,8 +65,9 @@ instance Parse T.Note where instance Parse String where parser = string - <|> (parser :: H (String -> String)) <*!> parser - "expected String" + <|> (parser :: H (String -> String)) + <*!> parser + "expected String" instance (Parse a, Parse b) => Parse (a, b) where parser = Haskellish.tuple parser parser @@ -85,12 +86,12 @@ instance Parse [Double] where parser = numList instance Parse [T.Note] where parser = numList -instance {-# OVERLAPPABLE #-} Parse a => Parse [a] where parser = list parser +instance {-# OVERLAPPABLE #-} (Parse a) => Parse [a] where parser = list parser numList :: (Parse a, Num a) => H [a] numList = list parser <|> chords -chords :: Num a => H [a] +chords :: (Num a) => H [a] chords = $( fromTidalList [ "major", @@ -156,7 +157,7 @@ instance Parse ControlPattern where <|> (parser :: H (Pattern Int -> ControlPattern)) <*!> parser <|> listCp_cp <*!> parser <|> genericPatternExpressions - "expected ControlPattern" + "expected ControlPattern" genericPatternExpressions :: forall a. (Parse a, Parse (Pattern a), Parse (Pattern a -> Pattern a), Parse [a]) => H (Pattern a) genericPatternExpressions = @@ -189,7 +190,7 @@ numPatternExpressions = $(fromTidal "irand") <*!> parser <|> pInt_pNumA <*!> parser -fractionalPatternExpressions :: Fractional a => H (Pattern a) +fractionalPatternExpressions :: (Fractional a) => H (Pattern a) fractionalPatternExpressions = $(fromTidal "rand") <|> $(fromTidal "perlin") @@ -205,7 +206,7 @@ instance Parse (Pattern Bool) where <|> (parser :: H (Pattern String -> Pattern Bool)) <*!> parser <|> (parser :: H (Pattern Int -> Pattern Bool)) <*!> parser <|> genericPatternExpressions - "expected Pattern Bool" + "expected Pattern Bool" instance Parse (Pattern String) where parser = @@ -213,8 +214,9 @@ instance Parse (Pattern String) where <|> genericPatternExpressions <|> (parser :: H (Pattern Int -> Pattern String)) <*!> parser <|> (parser :: H (String -> Pattern String)) <*!> parser - <|> (parser :: H ([(String, String)] -> Pattern String)) <*!> parser - "expected Pattern String" + <|> (parser :: H ([(String, String)] -> Pattern String)) + <*!> parser + "expected Pattern String" parseBP :: (Enumerable a, T.Parseable a) => H (Pattern a) parseBP = do @@ -234,7 +236,7 @@ instance Parse (Pattern Int) where <|> parseBP <|> genericPatternExpressions <|> numPatternExpressions - "expected Pattern Int" + "expected Pattern Int" instance Parse (Pattern Integer) where parser = @@ -242,7 +244,7 @@ instance Parse (Pattern Integer) where <|> parseBP <|> genericPatternExpressions <|> numPatternExpressions - "expected Pattern Integer" + "expected Pattern Integer" instance Parse (Pattern Double) where parser = @@ -264,7 +266,7 @@ instance Parse (Pattern Double) where <|> $(fromTidal "envLR") <|> (parser :: H (String -> Pattern Double)) <*!> parser <|> $(fromTidalList (fmap (\x -> "in" ++ show x) ([0 .. 127] :: [Int]))) - "expected Pattern Double" + "expected Pattern Double" instance Parse (Pattern T.Note) where parser = @@ -274,7 +276,7 @@ instance Parse (Pattern T.Note) where <|> genericPatternExpressions <|> numPatternExpressions <|> fractionalPatternExpressions - "expected Pattern Note" + "expected Pattern Note" instance Parse (Pattern Time) where parser = @@ -284,11 +286,11 @@ instance Parse (Pattern Time) where <|> genericPatternExpressions <|> numPatternExpressions <|> fractionalPatternExpressions - "expected Pattern Time" + "expected Pattern Time" -- * -> * -a_patternB :: forall a b. Parse (a -> Pattern b) => H (a -> Pattern b) +a_patternB :: forall a b. (Parse (a -> Pattern b)) => H (a -> Pattern b) a_patternB = listAtoPatternB_a_patternB <*> parser "expected a -> Pattern b" listAtoPatternB_a_patternB :: H ([a -> Pattern b] -> a -> Pattern b) @@ -311,9 +313,10 @@ instance Parse (ControlPattern -> ControlPattern) where <|> $(fromTidal "silent") <|> (parser :: H (Pattern Int -> ControlPattern -> ControlPattern)) <*!> parser <|> (parser :: H (Pattern Double -> ControlPattern -> ControlPattern)) <*!> parser - <|> (parser :: H (Pattern Time -> ControlPattern -> ControlPattern)) <*!> parser - -- lCpCp_cp_cp <*!> parser - "expected ControlPattern -> ControlPattern" + <|> (parser :: H (Pattern Time -> ControlPattern -> ControlPattern)) + <*!> parser + -- lCpCp_cp_cp <*!> parser + "expected ControlPattern -> ControlPattern" instance Parse (Pattern Bool -> Pattern Bool) where parser = genericTransformations <|> ordTransformations <|> fBool_fBool "expected Pattern Bool -> Pattern Bool" @@ -338,7 +341,7 @@ instance Parse (Pattern Double -> Pattern Double) where <|> ordTransformations <|> realFracTransformations <|> $(fromTidal "perlin2") - "expected Pattern Double -> Pattern Double" + "expected Pattern Double -> Pattern Double" instance Parse (Pattern T.Note -> Pattern T.Note) where parser = genericTransformations <|> numTransformations <|> floatingTransformations <|> ordTransformations "expected Pattern Note -> Pattern Note" @@ -381,14 +384,14 @@ genericTransformations = -- this only matches the case where the functions being composed are both a -> a (with the same a) -- nonetheless, this is an extremely common case with Tidal -simpleComposition :: forall a. Parse (a -> a) => H (a -> a) +simpleComposition :: forall a. (Parse (a -> a)) => H (a -> a) simpleComposition = $(fromHaskell ".") <*!> (parser :: H (a -> a)) <*!> (parser :: H (a -> a)) numTransformations :: (Num a, Enum a) => H (Pattern a -> Pattern a) numTransformations = $(fromTidal "run") -ordTransformations :: Ord a => H (Pattern a -> Pattern a) +ordTransformations :: (Ord a) => H (Pattern a -> Pattern a) ordTransformations = pInt_pOrd_pOrd <*!> parser @@ -425,7 +428,7 @@ instance Parse ([(Pattern a, Double)] -> Pattern a) where $(fromTidal "wrandcat") <|> a_patternB -pInt_p :: Parse [a] => H (Pattern Int -> Pattern a) +pInt_p :: (Parse [a]) => H (Pattern Int -> Pattern a) pInt_p = (parser :: H ([a] -> Pattern Int -> Pattern a)) <*!> parser @@ -521,34 +524,34 @@ pInt_pNumA :: (Num a, Parse [a]) => H (Pattern Int -> Pattern a) pInt_pNumA = listNumA_pInt_pA <*!> parser -- note: missing pA_pB and a_patternB pathways -pInt_pFractionalA :: Fractional a => H (Pattern Int -> Pattern a) -pInt_pFractionalA = (parser :: Fractional a => H (Pattern String -> Pattern Int -> Pattern a)) <*!> parser +pInt_pFractionalA :: (Fractional a) => H (Pattern Int -> Pattern a) +pInt_pFractionalA = (parser :: (Fractional a) => H (Pattern String -> Pattern Int -> Pattern a)) <*!> parser -pDouble_pFractionalA :: Fractional a => H (Pattern Double -> Pattern a) +pDouble_pFractionalA :: (Fractional a) => H (Pattern Double -> Pattern a) pDouble_pFractionalA = $(fromTidal "perlinWith") -- note: mising a_patternB pathway listCp_cp :: H ([ControlPattern] -> ControlPattern) listCp_cp = (parser :: H (ControlPattern -> [ControlPattern] -> ControlPattern)) <*!> parser -instance Parse (Pattern a) => Parse ([Pattern a -> Pattern a] -> Pattern a) where +instance (Parse (Pattern a)) => Parse ([Pattern a -> Pattern a] -> Pattern a) where parser = (parser :: H (Pattern a -> [Pattern a -> Pattern a] -> Pattern a)) <*!> parser <|> a_patternB -- note: mising a_patternB pathway (? maybe not necessary here though ?) -pA_pB :: Parse (Pattern a -> Pattern b) => H (Pattern a -> Pattern b) +pA_pB :: (Parse (Pattern a -> Pattern b)) => H (Pattern a -> Pattern b) pA_pB = pAB_pA_pB <*!> parser -fBool_fBool :: Functor f => H (f Bool -> f Bool) +fBool_fBool :: (Functor f) => H (f Bool -> f Bool) fBool_fBool = $(fromTidal "inv") -- note: mising a_patternB pathway -list_p :: Parse a => H ([a] -> Pattern a) +list_p :: (Parse a) => H ([a] -> Pattern a) list_p = pDouble_list_p <*!> parser -- note: mising a_patternB pathway -tupleADouble_p :: Parse a => H ([(a, Double)] -> Pattern a) +tupleADouble_p :: (Parse a) => H ([(a, Double)] -> Pattern a) tupleADouble_p = $(fromTidal "wchoose") <|> pDouble_tupleADouble_p <*!> parser @@ -576,13 +579,13 @@ instance Parse (Pattern Int -> Pattern Int -> Pattern Int) where genericBinaryPatternFunctions <|> numMergeOperator <|> pInt_p_p - "expected Pattern Int -> Pattern Int -> Pattern Int" + "expected Pattern Int -> Pattern Int -> Pattern Int" instance Parse (Pattern Integer -> Pattern Integer -> Pattern Integer) where parser = genericBinaryPatternFunctions <|> numMergeOperator - "expected Pattern Integer -> Pattern Integer -> Pattern Integer" + "expected Pattern Integer -> Pattern Integer -> Pattern Integer" instance Parse (Pattern Time -> Pattern Time -> Pattern Time) where parser = @@ -591,7 +594,7 @@ instance Parse (Pattern Time -> Pattern Time -> Pattern Time) where <|> realMergeOperator <|> fractionalMergeOperator <|> pTime_p_p - "expected Pattern Time -> Pattern Time -> Pattern Time" + "expected Pattern Time -> Pattern Time -> Pattern Time" instance Parse (Pattern Double -> Pattern Double -> Pattern Double) where parser = @@ -601,7 +604,7 @@ instance Parse (Pattern Double -> Pattern Double -> Pattern Double) where <|> fractionalMergeOperator <|> $(fromTidal "perlin2With") <|> pDouble_p_p - "expected Pattern Double -> Pattern Double -> Pattern Double" + "expected Pattern Double -> Pattern Double -> Pattern Double" instance Parse (Pattern T.Note -> Pattern T.Note -> Pattern T.Note) where parser = @@ -609,7 +612,7 @@ instance Parse (Pattern T.Note -> Pattern T.Note -> Pattern T.Note) where <|> numMergeOperator <|> realMergeOperator <|> fractionalMergeOperator - "expected Pattern Note -> Pattern Note -> Pattern Note" + "expected Pattern Note -> Pattern Note -> Pattern Note" instance Parse (ControlPattern -> ControlPattern -> ControlPattern) where parser = @@ -617,10 +620,11 @@ instance Parse (ControlPattern -> ControlPattern -> ControlPattern) where <|> numMergeOperator <|> fractionalMergeOperator <|> $(fromTidal "interlace") - <|> (parser :: H ((ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern -> ControlPattern)) <*!> parser - "expected ControlPattern -> ControlPattern -> ControlPattern" + <|> (parser :: H ((ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern -> ControlPattern)) + <*!> parser + "expected ControlPattern -> ControlPattern -> ControlPattern" -genericBinaryPatternFunctions :: T.Unionable a => H (Pattern a -> Pattern a -> Pattern a) +genericBinaryPatternFunctions :: (T.Unionable a) => H (Pattern a -> Pattern a -> Pattern a) genericBinaryPatternFunctions = $(fromTidal "overlay") <|> $(fromTidal "append") @@ -635,7 +639,7 @@ genericBinaryPatternFunctions = <|> (parser :: H (Pattern Bool -> Pattern a -> Pattern a -> Pattern a)) <*!> parser <|> constParser -unionableMergeOperator :: T.Unionable a => H (Pattern a -> Pattern a -> Pattern a) +unionableMergeOperator :: (T.Unionable a) => H (Pattern a -> Pattern a -> Pattern a) unionableMergeOperator = $(fromTidal "#") <|> $(fromTidal "|>|") @@ -662,20 +666,20 @@ numMergeOperator = <|> $(fromHaskell "*") <|> $(fromHaskell "-") -realMergeOperator :: T.Moddable a => H (Pattern a -> Pattern a -> Pattern a) +realMergeOperator :: (T.Moddable a) => H (Pattern a -> Pattern a -> Pattern a) realMergeOperator = $(fromTidal "|%|") <|> $(fromTidal "|%") <|> $(fromTidal "%|") -fractionalMergeOperator :: Fractional a => H (Pattern a -> Pattern a -> Pattern a) +fractionalMergeOperator :: (Fractional a) => H (Pattern a -> Pattern a -> Pattern a) fractionalMergeOperator = $(fromTidal "|/|") <|> $(fromTidal "|/") <|> $(fromTidal "/|") <|> $(fromHaskell "/") -floatingMergeOperator :: Floating a => H (Pattern a -> Pattern a -> Pattern a) +floatingMergeOperator :: (Floating a) => H (Pattern a -> Pattern a -> Pattern a) floatingMergeOperator = $(fromTidal "|**") <|> $(fromTidal "**|") @@ -734,7 +738,7 @@ pInt_p_p = <|> $(fromTidal "stripe") <|> pInt_pInt_p_p <*!> parser -pInt_pOrd_pOrd :: Ord a => H (Pattern Int -> Pattern a -> Pattern a) +pInt_pOrd_pOrd :: (Ord a) => H (Pattern Int -> Pattern a -> Pattern a) pInt_pOrd_pOrd = $(fromTidal "rot") pDouble_p_p :: H (Pattern Double -> Pattern a -> Pattern a) @@ -757,16 +761,16 @@ instance Parse ([ControlPattern -> ControlPattern] -> ControlPattern -> ControlP -- *** pathway leading to spread(etc) should be incorporated above -instance {-# OVERLAPPABLE #-} Parse ((Pattern a -> Pattern a) -> Pattern a -> Pattern a) => Parse ([Pattern a -> Pattern a] -> Pattern a -> Pattern a) where +instance {-# OVERLAPPABLE #-} (Parse ((Pattern a -> Pattern a) -> Pattern a -> Pattern a)) => Parse ([Pattern a -> Pattern a] -> Pattern a -> Pattern a) where parser = lPatApatA_patA_patA -lPatApatA_patA_patA :: Parse ((Pattern a -> Pattern a) -> Pattern a -> Pattern a) => H ([Pattern a -> Pattern a] -> Pattern a -> Pattern a) +lPatApatA_patA_patA :: (Parse ((Pattern a -> Pattern a) -> Pattern a -> Pattern a)) => H ([Pattern a -> Pattern a] -> Pattern a -> Pattern a) lPatApatA_patA_patA = (parser :: H (((Pattern a -> Pattern a) -> Pattern a -> Pattern a) -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a)) <*> parser <|> (parser :: H (Pattern Int -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a)) <*> parser <|> (parser :: H (Pattern Double -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a)) <*> parser -lp_p_p :: Parse (Pattern a -> Pattern a -> Pattern a) => H ([Pattern a] -> Pattern a -> Pattern a) +lp_p_p :: (Parse (Pattern a -> Pattern a -> Pattern a)) => H ([Pattern a] -> Pattern a -> Pattern a) lp_p_p = (parser :: H ((Pattern a -> Pattern a -> Pattern a) -> [Pattern a] -> Pattern a -> Pattern a)) <*> parser instance Parse ([Pattern Double] -> Pattern a -> Pattern a) where @@ -876,10 +880,10 @@ instance Parse (Pattern Double -> [Pattern a] -> Pattern a) where instance Parse (Pattern Int -> [Pattern a] -> Pattern a) where parser = $(fromTidal "squeeze") -instance Fractional a => Parse (Pattern String -> Pattern Int -> Pattern a) where +instance (Fractional a) => Parse (Pattern String -> Pattern Int -> Pattern a) where parser = $(fromTidal "scale") -listNumA_pInt_pA :: Num a => H ([a] -> Pattern Int -> Pattern a) +listNumA_pInt_pA :: (Num a) => H ([a] -> Pattern Int -> Pattern a) listNumA_pInt_pA = $(fromTidal "toScale") -- *** pathway leading to spread(etc) should be incorporated here @@ -896,10 +900,10 @@ instance Parse (Pattern a -> [Pattern a -> Pattern a] -> Pattern a) where pAB_pA_pB :: H ((Pattern a -> Pattern b) -> Pattern a -> Pattern b) pAB_pA_pB = pTime_pAB_pA_pB <*!> parser -pDouble_list_p :: Parse a => H (Pattern Double -> [a] -> Pattern a) +pDouble_list_p :: (Parse a) => H (Pattern Double -> [a] -> Pattern a) pDouble_list_p = $(fromTidal "chooseBy") -pDouble_tupleADouble_p :: Parse a => H (Pattern Double -> [(a, Double)] -> Pattern a) +pDouble_tupleADouble_p :: (Parse a) => H (Pattern Double -> [(a, Double)] -> Pattern a) pDouble_tupleADouble_p = $(fromTidal "wchooseBy") instance Parse (String -> String -> Pattern String) where @@ -914,7 +918,7 @@ instance Parse (String -> String -> String) where floating_pFloating_pFloating :: (Floating a, Parse a) => H (a -> Pattern a -> Pattern a) floating_pFloating_pFloating = floating_floating_pFloating_pFloating <*!> parser -realFrac_pRealFrac_pRealFrac :: RealFrac a => H (a -> Pattern a -> Pattern a) +realFrac_pRealFrac_pRealFrac :: (RealFrac a) => H (a -> Pattern a -> Pattern a) realFrac_pRealFrac_pRealFrac = $(fromTidal "quantise") instance Parse (Double -> String -> Pattern Double) where @@ -922,7 +926,7 @@ instance Parse (Double -> String -> Pattern Double) where -- * -> * -> * -> * -numTernaryTransformations :: Num a => H (Pattern a -> Pattern a -> Pattern a -> Pattern a) +numTernaryTransformations :: (Num a) => H (Pattern a -> Pattern a -> Pattern a -> Pattern a) numTernaryTransformations = $(fromTidal "range") instance Parse (Pattern Int -> Pattern Int -> ControlPattern -> ControlPattern) where @@ -1011,8 +1015,9 @@ instance Parse ((ControlPattern -> ControlPattern) -> ControlPattern -> ControlP parser = $(fromTidal "fix") <|> $(fromTidal "unfix") - <|> (parser :: H ((ControlPattern -> ControlPattern) -> (ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern -> ControlPattern)) <*!> parser - "expected (ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern -> ControlPattern" + <|> (parser :: H ((ControlPattern -> ControlPattern) -> (ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern -> ControlPattern)) + <*!> parser + "expected (ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern -> ControlPattern" instance Parse ([Int] -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a) where parser = $(fromTidal "foldEvery") @@ -1038,12 +1043,12 @@ instance Parse (Pattern Double -> [Pattern a -> Pattern a] -> Pattern a -> Patte instance Parse (Int -> String -> String -> String) where parser = $(fromTidal "lindenmayer") -floating_floating_pFloating_pFloating :: Floating a => H (a -> a -> Pattern a -> Pattern a) +floating_floating_pFloating_pFloating :: (Floating a) => H (a -> a -> Pattern a -> Pattern a) floating_floating_pFloating_pFloating = $(fromTidal "rangex") -- note: rangex actually generalized to Functor a rather than Pattern a, so we are over-specializing -integral_time_pA_pA :: Integral i => H (i -> Time -> Pattern a -> Pattern a) +integral_time_pA_pA :: (Integral i) => H (i -> Time -> Pattern a -> Pattern a) integral_time_pA_pA = $(fromTidal "stutter") instance Parse (Pattern Rational -> Pattern Double -> ControlPattern -> ControlPattern) where diff --git a/vis/Sound/Tidal/Cycle.hs b/vis/Sound/Tidal/Cycle.hs index 8182eeb8..8c5a20ee 100644 --- a/vis/Sound/Tidal/Cycle.hs +++ b/vis/Sound/Tidal/Cycle.hs @@ -1,283 +1,315 @@ module Sound.Tidal.Cycle where +import Control.Concurrent +import Control.Concurrent.MVar import Control.Monad -import Control.Monad.State import Control.Monad.Reader -import Control.Concurrent.MVar +import Control.Monad.State import Data.Array.IArray - +import Data.Bits +import Data.Colour +import Data.Colour.Names +import Data.Colour.RGBSpace.HSV (hsv) +import Data.Colour.SRGB +import Data.Fixed (mod') +import Data.List (intercalate, nub, sortBy, tails) +import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, listToMaybe) +import Data.Ratio +import Debug.Trace (trace) +import GHC.Int (Int16) +import qualified GHC.Word import Graphics.UI.SDL -import Graphics.UI.SDL.Image import qualified Graphics.UI.SDL.Framerate as FR +import Graphics.UI.SDL.Image import qualified Graphics.UI.SDL.Primitives as SDLP import qualified Graphics.UI.SDL.TTF.General as TTFG import Graphics.UI.SDL.TTF.Management import Graphics.UI.SDL.TTF.Render import Graphics.UI.SDL.TTF.Types -import Data.Maybe (listToMaybe, fromMaybe, fromJust, isJust, catMaybes) -import GHC.Int (Int16) -import Data.List (intercalate, tails, nub, sortBy) -import Data.Colour -import Data.Colour.Names -import Data.Colour.SRGB -import Data.Colour.RGBSpace.HSV (hsv) -import qualified GHC.Word -import Data.Bits -import Data.Ratio -import Debug.Trace (trace) -import Data.Fixed (mod') -import Control.Concurrent -import System.Exit - import Sound.OSC.FD - -import Sound.Tidal.Stream (ParamPattern) -import Sound.Tidal.Pattern import Sound.Tidal.Parse +import Sound.Tidal.Pattern +import Sound.Tidal.Stream (ParamPattern) import Sound.Tidal.Tempo import qualified Sound.Tidal.Time as Time import Sound.Tidal.Utils +import System.Exit - ---enumerate :: [a] -> [(Int, a)] ---enumerate = zip [0..] +-- enumerate :: [a] -> [(Int, a)] +-- enumerate = zip [0..] maybeHead [] = Nothing -maybeHead (x:_) = Just x +maybeHead (x : _) = Just x -sortByFst :: Ord a => [(a, b)] -> [(a, b)] +sortByFst :: (Ord a) => [(a, b)] -> [(a, b)] sortByFst = sortBy (\a b -> compare (fst a) (fst b)) parenthesise :: String -> String parenthesise x = "(" ++ x ++ ")" - + spaces :: Int -> String spaces n = take n $ repeat ' ' single :: [a] -> Maybe a -single (x:[]) = Just x +single (x : []) = Just x single _ = Nothing fromJust' (Just x) = x fromJust' Nothing = error "nothing is just" -data Scene = Scene {mouseXY :: (Float, Float), - cursor :: (Float, Float) - } +data Scene = Scene + { mouseXY :: (Float, Float), + cursor :: (Float, Float) + } -data AppConfig = AppConfig { - screen :: Surface, - font :: Font, - tempoMV :: MVar (Tempo), - fr :: FR.FPSManager, - mpat :: MVar (Pattern ColourD) -} +data AppConfig = AppConfig + { screen :: Surface, + font :: Font, + tempoMV :: MVar (Tempo), + fr :: FR.FPSManager, + mpat :: MVar (Pattern ColourD) + } type AppState = StateT Scene IO -type AppEnv = ReaderT AppConfig AppState +type AppEnv = ReaderT AppConfig AppState +screenWidth = 1024 -screenWidth = 1024 screenHeight = 768 -screenBpp = 32 -middle = (fromIntegral $ screenWidth`div`2,fromIntegral $ screenHeight`div`2) + +screenBpp = 32 + +middle = (fromIntegral $ screenWidth `div` 2, fromIntegral $ screenHeight `div` 2) toScreen :: (Float, Float) -> (Int, Int) -toScreen (x, y) = (floor (x * (fromIntegral screenWidth)), - floor (y * (fromIntegral screenHeight)) - ) +toScreen (x, y) = + ( floor (x * (fromIntegral screenWidth)), + floor (y * (fromIntegral screenHeight)) + ) toScreen16 :: (Float, Float) -> (Int16, Int16) -toScreen16 (x, y) = (fromIntegral $ floor (x * (fromIntegral screenWidth)), - fromIntegral $ floor (y * (fromIntegral screenHeight)) - ) +toScreen16 (x, y) = + ( fromIntegral $ floor (x * (fromIntegral screenWidth)), + fromIntegral $ floor (y * (fromIntegral screenHeight)) + ) fromScreen :: (Int, Int) -> (Float, Float) -fromScreen (x, y) = ((fromIntegral x) / (fromIntegral screenWidth), - (fromIntegral y) / (fromIntegral screenHeight) - ) +fromScreen (x, y) = + ( (fromIntegral x) / (fromIntegral screenWidth), + (fromIntegral y) / (fromIntegral screenHeight) + ) -isInside :: Integral a => Rect -> a -> a -> Bool +isInside :: (Integral a) => Rect -> a -> a -> Bool isInside (Rect rx ry rw rh) x y = (x' > rx) && (x' < rx + rw) && (y' > ry) && (y' < ry + rh) - where (x', y') = (fromIntegral x, fromIntegral y) - -ctrlDown mods = or $ map (\x -> elem x [KeyModLeftCtrl, - KeyModRightCtrl - ] - ) mods - -shiftDown mods = or $ map (\x -> elem x [KeyModLeftShift, - KeyModRightShift, - KeyModShift - ] - ) mods + where + (x', y') = (fromIntegral x, fromIntegral y) + +ctrlDown mods = + or $ + map + ( \x -> + elem + x + [ KeyModLeftCtrl, + KeyModRightCtrl + ] + ) + mods + +shiftDown mods = + or $ + map + ( \x -> + elem + x + [ KeyModLeftShift, + KeyModRightShift, + KeyModShift + ] + ) + mods handleEvent :: Scene -> Event -> AppEnv (Scene) handleEvent scene (KeyDown k) = - handleKey scene (symKey k) (symUnicode k) (symModifiers k) - + handleKey scene (symKey k) (symUnicode k) (symModifiers k) handleEvent scene _ = return scene handleKey :: Scene -> SDLKey -> Char -> [Modifier] -> AppEnv Scene handleKey scene SDLK_SPACE _ _ = return scene handleKey scene _ _ _ = return scene - applySurface :: Int -> Int -> Surface -> Surface -> Maybe Rect -> IO Bool applySurface x y src dst clip = blitSurface src clip dst offset - where offset = Just Rect { rectX = x, rectY = y, rectW = 0, rectH = 0 } + where + offset = Just Rect {rectX = x, rectY = y, rectW = 0, rectH = 0} initEnv :: MVar (Pattern ColourD) -> IO AppConfig -initEnv mp = do - screen <- setVideoMode screenWidth screenHeight screenBpp [SWSurface] - font <- openFont "futura.ttf" 22 - setCaption "Cycle" [] - tempoMV <- tempoMVar - fps <- FR.new - FR.init fps - FR.set fps 15 - return $ AppConfig screen font tempoMV fps mp +initEnv mp = do + screen <- setVideoMode screenWidth screenHeight screenBpp [SWSurface] + font <- openFont "futura.ttf" 22 + setCaption "Cycle" [] + tempoMV <- tempoMVar + fps <- FR.new + FR.init fps + FR.set fps 15 + return $ AppConfig screen font tempoMV fps mp blankWidth = 0.015 drawArc' :: Surface -> ColourD -> (Double, Double) -> (Double, Double) -> Double -> Double -> Double -> IO () -drawArc' screen c (x,y) (r,r') t o step | o <= 0 = return () - | otherwise = - do let pix = (colourToPixel c) - steps = [t, (t + step) .. (t + o)] - coords = map (\s -> (floor $ x + (r*cos(s)),floor $ y + (r*sin(s)))) steps - ++ map (\s -> (floor $ x + (r'*cos(s)),floor $ y + (r'*sin(s)))) (reverse steps) - SDLP.filledPolygon screen coords pix - --drawArc screen c (x,y) (r,r') t (o-step) step - return () - where a = max t (t + o - step) - b = t + o - +drawArc' screen c (x, y) (r, r') t o step + | o <= 0 = return () + | otherwise = + do + let pix = (colourToPixel c) + steps = [t, (t + step) .. (t + o)] + coords = + map (\s -> (floor $ x + (r * cos (s)), floor $ y + (r * sin (s)))) steps + ++ map (\s -> (floor $ x + (r' * cos (s)), floor $ y + (r' * sin (s)))) (reverse steps) + SDLP.filledPolygon screen coords pix + -- drawArc screen c (x,y) (r,r') t (o-step) step + return () + where + a = max t (t + o - step) + b = t + o drawArc :: Surface -> ColourD -> (Double, Double) -> (Double, Double) -> Double -> Double -> Double -> IO () -drawArc screen c (x,y) (r,r') t o step | o <= 0 = return () - | otherwise = - do let pix = (colourToPixel c) - SDLP.filledPolygon screen coords pix - drawArc screen c (x,y) (r,r') t (o-step) step - return () - where a = max t (t + o - step) - b = t + o - coords = map ((\(x',y') -> (floor $ x + x', floor $ y + y'))) - [(r * cos(a), r * sin(a)), - (r' * cos(a), r' * sin(a)), - (r' * cos(b), r' * sin(b)), - (r * cos(b), r * sin(b)) - ] +drawArc screen c (x, y) (r, r') t o step + | o <= 0 = return () + | otherwise = + do + let pix = (colourToPixel c) + SDLP.filledPolygon screen coords pix + drawArc screen c (x, y) (r, r') t (o - step) step + return () + where + a = max t (t + o - step) + b = t + o + coords = + map + ((\(x', y') -> (floor $ x + x', floor $ y + y'))) + [ (r * cos (a), r * sin (a)), + (r' * cos (a), r' * sin (a)), + (r' * cos (b), r' * sin (b)), + (r * cos (b), r * sin (b)) + ] loop :: AppEnv () loop = do - quit <- whileEvents $ act - screen <- screen `liftM` ask - font <- font `liftM` ask - tempoM <- tempoMV `liftM` ask - fps <- fr `liftM` ask - scene <- get - mp <- mpat `liftM` ask - liftIO $ do - pat <- readMVar mp - tempo <- readMVar tempoM - beat <- beatNow tempo - bgColor <- (mapRGB . surfaceGetPixelFormat) screen 0x00 0x00 0x00 - clipRect <- Just `liftM` getClipRect screen - fillRect screen clipRect bgColor - --drawArc screen middle (100,110) ((beat) * pi) (pi/2) (pi/32) - drawPat middle (100,(fi screenHeight)/2) pat screen beat - Graphics.UI.SDL.flip screen - FR.delay fps - unless quit loop - where act e = do scene <- get - scene' <- handleEvent scene e - put $ scene' + quit <- whileEvents $ act + screen <- screen `liftM` ask + font <- font `liftM` ask + tempoM <- tempoMV `liftM` ask + fps <- fr `liftM` ask + scene <- get + mp <- mpat `liftM` ask + liftIO $ do + pat <- readMVar mp + tempo <- readMVar tempoM + beat <- beatNow tempo + bgColor <- (mapRGB . surfaceGetPixelFormat) screen 0x00 0x00 0x00 + clipRect <- Just `liftM` getClipRect screen + fillRect screen clipRect bgColor + -- drawArc screen middle (100,110) ((beat) * pi) (pi/2) (pi/32) + drawPat middle (100, (fi screenHeight) / 2) pat screen beat + Graphics.UI.SDL.flip screen + FR.delay fps + unless quit loop + where + act e = do + scene <- get + scene' <- handleEvent scene e + put $ scene' drawPat :: (Double, Double) -> (Double, Double) -> Pattern ColourD -> Surface -> Double -> IO () -drawPat (x, y) (r,r') p screen beat = mapM_ drawEvents es - where es = map (\(_, (s,e), evs) -> ((max s pos, min e (pos + 1)), evs)) $ arc (segment p) (pos, pos + 1) - pos = toRational $ beat / 8 - drawEvents ((s,e), cs) = - mapM_ (\(n', c) -> drawEvent (s,e) c n' (length cs)) (enumerate $ reverse cs) - drawEvent (s,e) c n' len = - do let thickness = (1 / fromIntegral len) * (r' - r) - let start = r + thickness * (fromIntegral n') - drawArc screen c middle (start,start+thickness) ((pi*2) * (fromRational (s-pos))) ((pi*2) * fromRational (e-s)) (pi/16) +drawPat (x, y) (r, r') p screen beat = mapM_ drawEvents es + where + es = map (\(_, (s, e), evs) -> ((max s pos, min e (pos + 1)), evs)) $ arc (segment p) (pos, pos + 1) + pos = toRational $ beat / 8 + drawEvents ((s, e), cs) = + mapM_ (\(n', c) -> drawEvent (s, e) c n' (length cs)) (enumerate $ reverse cs) + drawEvent (s, e) c n' len = + do + let thickness = (1 / fromIntegral len) * (r' - r) + let start = r + thickness * (fromIntegral n') + drawArc screen c middle (start, start + thickness) ((pi * 2) * (fromRational (s - pos))) ((pi * 2) * fromRational (e - s)) (pi / 16) + {- (thickLine h (n*scale+n') (linesz/ (fromIntegral scale)) (x1 + (xd * fromRational (e-pos))) (y1 + (yd * fromRational (e-pos))) - (x1 + (xd * fromRational (s-pos))) + (x1 + (xd * fromRational (s-pos))) (y1 + (yd * fromRational (s-pos))) - ) + ) screen (colourToPixel c)-} segment2 :: Pattern a -> Pattern [(Bool, a)] -segment2 p = Pattern $ \(s,e) -> filter (\(_, (s',e'),_) -> s' < e && e' > s) $ groupByTime (segment2' (arc (fmap (\x -> (True, x)) p) (s,e))) - +segment2 p = Pattern $ \(s, e) -> filter (\(_, (s', e'), _) -> s' < e && e' > s) $ groupByTime (segment2' (arc (fmap (\x -> (True, x)) p) (s, e))) segment2' :: [Time.Event (Bool, a)] -> [Time.Event (Bool, a)] segment2' es = foldr splitEs es pts - where pts = nub $ points es + where + pts = nub $ points es splitEs :: Time.Time -> [Time.Event (Bool, a)] -> [Time.Event (Bool, a)] splitEs _ [] = [] -splitEs t ((ev@(a, (s,e), (h,v))):es) | t > s && t < e = (a, (s,t),(h,v)):(a, (t,e),(False,v)):(splitEs t es) - | otherwise = ev:splitEs t es +splitEs t ((ev@(a, (s, e), (h, v))) : es) + | t > s && t < e = (a, (s, t), (h, v)) : (a, (t, e), (False, v)) : (splitEs t es) + | otherwise = ev : splitEs t es -whileEvents :: MonadIO m => (Event -> m ()) -> m Bool +whileEvents :: (MonadIO m) => (Event -> m ()) -> m Bool whileEvents act = do - event <- liftIO pollEvent - case event of - Quit -> return True - NoEvent -> return False - _ -> do - act event - whileEvents act + event <- liftIO pollEvent + case event of + Quit -> return True + NoEvent -> return False + _ -> do + act event + whileEvents act runLoop :: AppConfig -> Scene -> IO () runLoop = evalStateT . runReaderT loop -textSize :: String -> Font -> IO ((Float,Float)) -textSize text font = - do message <- renderTextSolid font text (Color 0 0 0) - return (fromScreen (surfaceGetWidth message, surfaceGetHeight message)) - -run = do mp <- newMVar silence - forkIO $ run' mp - return mp - - -run' mp = withInit [InitEverything] $ - do result <- TTFG.init - if not result - then putStrLn "Failed to init ttf" - else do enableUnicode True - env <- initEnv mp - --ws <- wordMenu (font env) things - let scene = Scene (0,0) (0.5,0.5) - --putStrLn $ show scene - runLoop env scene - +textSize :: String -> Font -> IO ((Float, Float)) +textSize text font = + do + message <- renderTextSolid font text (Color 0 0 0) + return (fromScreen (surfaceGetWidth message, surfaceGetHeight message)) + +run = do + mp <- newMVar silence + forkIO $ run' mp + return mp + +run' mp = withInit [InitEverything] $ + do + result <- TTFG.init + if not result + then putStrLn "Failed to init ttf" + else do + enableUnicode True + env <- initEnv mp + -- ws <- wordMenu (font env) things + let scene = Scene (0, 0) (0.5, 0.5) + -- putStrLn $ show scene + runLoop env scene -- colourToPixel :: Colour Double -> Pixel -- colourToPixel c = rgbColor (floor $ 256*r) (floor $ 256* g) (floor $ 256*b) -- where (RGB r g b) = toSRGB c colourToPixel :: Colour Double -> Pixel -colourToPixel c = rgbColor (floor $ r*255) (floor $ g*255) (floor $ b *255) -- mapRGB (surfaceGetPixelFormat screen) 255 255 255 - where (RGB r g b) = toSRGB c - ---colourToPixel :: Surface -> Colour Double -> IO Pixel ---colourToPixel s c = (mapRGB . surfaceGetPixelFormat) s (floor $ r*255) (floor $ g*255) (floor $ b*255) +colourToPixel c = rgbColor (floor $ r * 255) (floor $ g * 255) (floor $ b * 255) -- mapRGB (surfaceGetPixelFormat screen) 255 255 255 + where + (RGB r g b) = toSRGB c +-- colourToPixel :: Surface -> Colour Double -> IO Pixel +-- colourToPixel s c = (mapRGB . surfaceGetPixelFormat) s (floor $ r*255) (floor $ g*255) (floor $ b*255) fi a = fromIntegral a rgbColor :: GHC.Word.Word8 -> GHC.Word.Word8 -> GHC.Word.Word8 -> Pixel rgbColor r g b = Pixel (shiftL (fi r) 24 .|. shiftL (fi g) 16 .|. shiftL (fi b) 8 .|. (fi 255)) -pixel :: Surface -> (GHC.Word.Word8,GHC.Word.Word8,GHC.Word.Word8) -> IO Pixel -pixel surface (r,g,b) = mapRGB (surfaceGetPixelFormat surface) r g b +pixel :: Surface -> (GHC.Word.Word8, GHC.Word.Word8, GHC.Word.Word8) -> IO Pixel +pixel surface (r, g, b) = mapRGB (surfaceGetPixelFormat surface) r g b diff --git a/vis/Sound/Tidal/Vis.hs b/vis/Sound/Tidal/Vis.hs index 216c7201..9fe1c211 100644 --- a/vis/Sound/Tidal/Vis.hs +++ b/vis/Sound/Tidal/Vis.hs @@ -1,67 +1,76 @@ module Sound.Tidal.Vis where -import qualified Graphics.Rendering.Cairo as C +import Control.Applicative import Data.Colour import Data.Colour.Names import Data.Colour.SRGB -import Control.Applicative +import Data.Ratio +import qualified Graphics.Rendering.Cairo as C import Sound.Tidal.Parse import Sound.Tidal.Pattern import Sound.Tidal.Utils -import Data.Ratio vPDF = v C.withPDFSurface + vSVG = v C.withSVGSurface -v sf fn (x,y) pat = +v sf fn (x, y) pat = sf fn x y $ \surf -> do - C.renderWith surf $ do - C.save + C.renderWith surf $ do + C.save C.scale x y C.setOperator C.OperatorOver - C.setSourceRGB 0 0 0 + C.setSourceRGB 0 0 0 C.rectangle 0 0 1 1 C.fill mapM_ renderEvent (events pat) - C.restore + C.restore - -vLines sf fn (x,y) pat cyclesPerLine nLines = +vLines sf fn (x, y) pat cyclesPerLine nLines = sf fn x y $ \surf -> do - C.renderWith surf $ do - C.save + C.renderWith surf $ do + C.save C.scale x (y / (fromIntegral nLines)) C.setOperator C.OperatorOver - C.setSourceRGB 0 0 0 + C.setSourceRGB 0 0 0 C.rectangle 0 0 1 1 C.fill - mapM_ (\x -> do C.save - C.translate 0 (fromIntegral x) - drawLine ((cyclesPerLine * (fromIntegral x)) `rotR` pat) - C.restore - ) [0 .. (nLines - 1)] - C.restore - where drawLine p = mapM_ renderEvent (events (_density cyclesPerLine p)) - + mapM_ + ( \x -> do + C.save + C.translate 0 (fromIntegral x) + drawLine ((cyclesPerLine * (fromIntegral x)) `rotR` pat) + C.restore + ) + [0 .. (nLines - 1)] + C.restore + where + drawLine p = mapM_ renderEvent (events (_density cyclesPerLine p)) -renderEvent (_, (s,e), (cs)) = do C.save - drawBlocks cs 0 - C.restore - where height = 1/(fromIntegral $ length cs) - drawBlocks [] _ = return () - drawBlocks (c:cs) n = do let (RGB r g b) = toSRGB c - C.setSourceRGBA r g b 1 - C.rectangle x y w h - C.fill - C.stroke - drawBlocks cs (n+1) - where x = (fromRational s) - y = (fromIntegral n) * height - w = (fromRational (e-s)) - h = height +renderEvent (_, (s, e), (cs)) = do + C.save + drawBlocks cs 0 + C.restore + where + height = 1 / (fromIntegral $ length cs) + drawBlocks [] _ = return () + drawBlocks (c : cs) n = do + let (RGB r g b) = toSRGB c + C.setSourceRGBA r g b 1 + C.rectangle x y w h + C.fill + C.stroke + drawBlocks cs (n + 1) + where + x = (fromRational s) + y = (fromIntegral n) * height + w = (fromRational (e - s)) + h = height +events pat = (map (mapSnd' (\(s, e) -> ((s - (ticks / 2)) / speed, (e - (ticks / 2)) / speed))) $ arc (segment pat) ((ticks / 2), (ticks / 2) + speed)) + where + speed = 1 -events pat = (map (mapSnd' (\(s,e) -> ((s - (ticks/2))/speed,(e - (ticks/2))/speed))) $ arc (segment pat) ((ticks/2), (ticks/2)+speed)) - where speed = 1 ticks = 0 ---pat = p "[red blue green,orange purple]" :: Sequence ColourD + +-- pat = p "[red blue green,orange purple]" :: Sequence ColourD diff --git a/vis/Sound/Tidal/Vis2.hs b/vis/Sound/Tidal/Vis2.hs index e9c6b041..c98f9e0c 100644 --- a/vis/Sound/Tidal/Vis2.hs +++ b/vis/Sound/Tidal/Vis2.hs @@ -1,91 +1,104 @@ module Sound.Tidal.Vis2 where -import qualified Graphics.Rendering.Cairo as C +import Control.Applicative import Data.Colour import Data.Colour.Names import Data.Colour.SRGB -import Control.Applicative +import Data.List +import Data.Maybe +import Data.Ord (comparing) +import Data.Ratio +import qualified Graphics.Rendering.Cairo as C import Sound.Tidal.Parse import Sound.Tidal.Pattern import Sound.Tidal.Time import Sound.Tidal.Utils -import Data.Ratio -import Data.Maybe import System.Cmd -import Data.List -import Data.Ord ( comparing ) totalWidth = 600 :: Double -ratio = 1/40 + +ratio = 1 / 40 + levelHeight = totalWidth * ratio arrangeEvents [] = [] -arrangeEvents (e:es) = addEvent e (arrangeEvents es) +arrangeEvents (e : es) = addEvent e (arrangeEvents es) + fits e es = null $ filter (id) $ map (\e' -> isJust $ subArc (snd' e) (snd' e')) es -addEvent e [] = [[e]] -addEvent e (level:levels) | fits e level = (e:level):levels - | otherwise = level:(addEvent e levels) -v sf fn (x,y) levels = - sf fn x y $ \surf -> do - C.renderWith surf $ do - C.save - -- C.scale x (y / (fromIntegral $ length levels)) - C.setOperator C.OperatorOver - -- C.setSourceRGB 0 0 0 - -- C.rectangle 0 0 1 1 - --C.fill - mapM_ (renderLevel (length levels)) $ enumerate levels - C.restore +addEvent e [] = [[e]] +addEvent e (level : levels) + | fits e level = (e : level) : levels + | otherwise = level : (addEvent e levels) -renderLevel total (n, level) = do C.save - mapM_ drawEvent $ level - C.restore - where drawEvent ((sWhole, eWhole), (s,e), c) = - do let (RGB r g b) = toSRGB c - -- C.setSourceRGBA 0.6 0.6 0.6 1 - -- C.rectangle x y lineW levelHeight - C.withLinearPattern xWhole 0 (wholeLineW+xWhole) 0 $ \pattern -> - do --C.patternAddColorStopRGB pattern 0 0 0 0 - --C.patternAddColorStopRGB pattern 0.5 1 1 1 - C.save - C.patternAddColorStopRGBA pattern 0 r g b 1 - C.patternAddColorStopRGBA pattern 1 r g b 0.5 - C.patternSetFilter pattern C.FilterFast - C.setSource pattern - -- C.setSourceRGBA r g b 1 - --C.arc (x+half) (y+half) (w/2) 0 (2 * pi) - C.rectangle x y lineW levelHeight - C.fill - C.restore - -- C.stroke - --C.fill - -- C.stroke - where x = (fromRational s) * totalWidth - y = (fromIntegral n) * levelHeight - xWhole = (fromRational sWhole) * totalWidth - w = levelHeight - lineW = ((fromRational $ e-s) * totalWidth) - wholeLineW = ((fromRational $ eWhole-sWhole) * totalWidth) - lineH = 2 - lgap = 3 - rgap = 3 - border = 3 - half = levelHeight / 2 - quarter = levelHeight / 4 - vPDF = v C.withPDFSurface +v sf fn (x, y) levels = + sf fn x y $ \surf -> do + C.renderWith surf $ do + C.save + -- C.scale x (y / (fromIntegral $ length levels)) + C.setOperator C.OperatorOver + -- C.setSourceRGB 0 0 0 + -- C.rectangle 0 0 1 1 + -- C.fill + mapM_ (renderLevel (length levels)) $ enumerate levels + C.restore -vis name pat = do v (C.withSVGSurface) (name ++ ".svg") (totalWidth, levelHeight*(fromIntegral $ length levels)) levels - rawSystem "/home/alex/Dropbox/bin/fixsvg.pl" [name ++ ".svg"] - -- rawSystem "convert" [name ++ ".svg", name ++ ".pdf"] - return () - where levels = arrangeEvents $ sortOn ((\x -> snd x - fst x) . snd') (arc pat (0,1)) - sortOn f = map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x)) +renderLevel total (n, level) = do + C.save + mapM_ drawEvent $ level + C.restore + where + drawEvent ((sWhole, eWhole), (s, e), c) = + do + let (RGB r g b) = toSRGB c + -- C.setSourceRGBA 0.6 0.6 0.6 1 + -- C.rectangle x y lineW levelHeight + C.withLinearPattern xWhole 0 (wholeLineW + xWhole) 0 $ \pattern -> + do + -- C.patternAddColorStopRGB pattern 0 0 0 0 + -- C.patternAddColorStopRGB pattern 0.5 1 1 1 + C.save + C.patternAddColorStopRGBA pattern 0 r g b 1 + C.patternAddColorStopRGBA pattern 1 r g b 0.5 + C.patternSetFilter pattern C.FilterFast + C.setSource pattern + -- C.setSourceRGBA r g b 1 + -- C.arc (x+half) (y+half) (w/2) 0 (2 * pi) + C.rectangle x y lineW levelHeight + C.fill + C.restore + where + -- C.stroke + -- C.fill + -- C.stroke + x = (fromRational s) * totalWidth + y = (fromIntegral n) * levelHeight + xWhole = (fromRational sWhole) * totalWidth + w = levelHeight + lineW = ((fromRational $ e - s) * totalWidth) + wholeLineW = ((fromRational $ eWhole - sWhole) * totalWidth) + lineH = 2 + lgap = 3 + rgap = 3 + border = 3 + half = levelHeight / 2 + quarter = levelHeight / 4 + vPDF = v C.withPDFSurface -visAsString pat = do vis "/tmp/vis2-tmp" pat - svg <- readFile "/tmp/vis2-tmp.svg" - return svg +vis name pat = do + v (C.withSVGSurface) (name ++ ".svg") (totalWidth, levelHeight * (fromIntegral $ length levels)) levels + rawSystem "/home/alex/Dropbox/bin/fixsvg.pl" [name ++ ".svg"] + -- rawSystem "convert" [name ++ ".svg", name ++ ".pdf"] + return () + where + levels = arrangeEvents $ sortOn ((\x -> snd x - fst x) . snd') (arc pat (0, 1)) + sortOn f = map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x)) +visAsString pat = do + vis "/tmp/vis2-tmp" pat + svg <- readFile "/tmp/vis2-tmp.svg" + return svg magicallyMakeEverythingFaster = splitArcs 16 - where splitArcs n p = concatMap (\i -> arc p (i,i+(1/n))) [0, (1/n) .. (1-(1/n))] + where + splitArcs n p = concatMap (\i -> arc p (i, i + (1 / n))) [0, (1 / n) .. (1 - (1 / n))] diff --git a/vis/examples/example.hs b/vis/examples/example.hs index be3f907f..c8c22dd7 100644 --- a/vis/examples/example.hs +++ b/vis/examples/example.hs @@ -1,47 +1,58 @@ {-# LANGUAGE OverloadedStrings #-} +import Data.Colour import Sound.Tidal.Context import Sound.Tidal.Vis -import Data.Colour render :: [Pattern ColourD] -> IO () -render xs = mapM_ (\(n, p) -> vPDF (show n ++ ".pdf") (300,100) p) $ zip [0..] xs +render xs = mapM_ (\(n, p) -> vPDF (show n ++ ".pdf") (300, 100) p) $ zip [0 ..] xs -main = do render [a,b,c,d,e,f,g] - return () +main = do + render [a, b, c, d, e, f, g] + return () a = density 16 $ every 2 rev $ every 3 (superimpose (iter 4)) $ rev "[black blue darkblue, grey lightblue]" b = flip darken <$> "[black blue orange, red green]*16" <*> sinewave1 -c = density 10 $ flip darken - <$> "[black blue, grey ~ navy, cornflowerblue blue]*2" - <*> (slow 5 $ (*) <$> sinewave1 <*> (slow 2 triwave1)) - -d = every 2 rev $ density 10 $ (blend' - <$> "blue navy" - <*> "orange [red, orange, purple]" - <*> (slow 6 $ sinewave1) - ) - where blend' a b c = blend c a b - -e = density 32 $ (flip over - <$> ("[grey olive, black ~ brown, darkgrey]") - <*> (withOpacity - <$> "[beige, lightblue white darkgreen, beige]" - <*> ((*) <$> (slow 8 $ slow 4 sinewave1) <*> (slow 3 $ sinewave1))) - ) - -f = density 2 $ (flip darken - <$> (density 8 $ "[black blue, grey ~ navy, cornflowerblue blue]*2") - <*> sinewave1 - ) - -g = density 2 $ - do let x = "[skyblue olive, grey ~ navy, cornflowerblue green]" - coloura <- density 8 x - colourb <- density 4 x - slide <- slow 2 sinewave1 - return $ blend slide coloura colourb - - +c = + density 10 $ + flip darken + <$> "[black blue, grey ~ navy, cornflowerblue blue]*2" + <*> (slow 5 $ (*) <$> sinewave1 <*> (slow 2 triwave1)) + +d = + every 2 rev $ + density 10 $ + ( blend' + <$> "blue navy" + <*> "orange [red, orange, purple]" + <*> (slow 6 $ sinewave1) + ) + where + blend' a b c = blend c a b + +e = + density 32 $ + ( flip over + <$> ("[grey olive, black ~ brown, darkgrey]") + <*> ( withOpacity + <$> "[beige, lightblue white darkgreen, beige]" + <*> ((*) <$> (slow 8 $ slow 4 sinewave1) <*> (slow 3 $ sinewave1)) + ) + ) + +f = + density 2 $ + ( flip darken + <$> (density 8 $ "[black blue, grey ~ navy, cornflowerblue blue]*2") + <*> sinewave1 + ) + +g = density 2 $ + do + let x = "[skyblue olive, grey ~ navy, cornflowerblue green]" + coloura <- density 8 x + colourb <- density 4 x + slide <- slow 2 sinewave1 + return $ blend slide coloura colourb From 1059a13d027bb0296cc8f739b379fe350fcbd7ad Mon Sep 17 00:00:00 2001 From: alex Date: Mon, 27 Jan 2025 17:26:19 +0100 Subject: [PATCH 04/12] hide ghci script from ormolu --- tidal-listener/examples/first.hs | 50 -------------------------------- 1 file changed, 50 deletions(-) delete mode 100644 tidal-listener/examples/first.hs diff --git a/tidal-listener/examples/first.hs b/tidal-listener/examples/first.hs deleted file mode 100644 index 62767f5a..00000000 --- a/tidal-listener/examples/first.hs +++ /dev/null @@ -1,50 +0,0 @@ --- run the following in ghci.. - -import Sound.OSC.FD as O - --- gets a randomly allocated port, might be useful.. --- udp <- udpServer "127.0.0.1" 0 --- udpPort udp - -udp <- udpServer "127.0.0.1" 6012 - -r <- openUDP "127.0.0.1" 6011 - --- execute an arbitrary statement -sendMessage r $ Message "/eval" [string "return 10"] -m <- recvMessage udp -m - --- evaluate a definition -sendMessage r $ Message "/eval" [string "let x = 10"] -m <- recvMessage udp -m - --- evaluate a binding statement -sendMessage r $ Message "/eval" [string "y <- return 1"] -m <- recvMessage udp -m - --- evaluate a tidal statment -sendMessage r $ Message "/eval" [string "d1 $ s \"bd\" # n x"] -m <- recvMessage udp -m - --- error -sendMessage r $ Message "/eval" [string "d1 $ suond \"bd\""] -m <- recvMessage udp -m - --- ask the type of an expression -sendMessage r $ Message "/type" [string "s \"bd\""] -m <- recvMessage udp -m - -sendMessage r $ Message "/ping" [] -m <- recvMessage udp -m - --- receive cps values -sendMessage r $ Message "/cps" [] -m <- recvMessage udp -m From 1cc83416d9396cff09c0097b045a5ddbce0be311 Mon Sep 17 00:00:00 2001 From: alex Date: Mon, 27 Jan 2025 17:26:34 +0100 Subject: [PATCH 05/12] hide ghci script from ormolu --- tidal-listener/examples/first.hs-example | 50 ++++++++++++++++++++++++ 1 file changed, 50 insertions(+) create mode 100644 tidal-listener/examples/first.hs-example diff --git a/tidal-listener/examples/first.hs-example b/tidal-listener/examples/first.hs-example new file mode 100644 index 00000000..62767f5a --- /dev/null +++ b/tidal-listener/examples/first.hs-example @@ -0,0 +1,50 @@ +-- run the following in ghci.. + +import Sound.OSC.FD as O + +-- gets a randomly allocated port, might be useful.. +-- udp <- udpServer "127.0.0.1" 0 +-- udpPort udp + +udp <- udpServer "127.0.0.1" 6012 + +r <- openUDP "127.0.0.1" 6011 + +-- execute an arbitrary statement +sendMessage r $ Message "/eval" [string "return 10"] +m <- recvMessage udp +m + +-- evaluate a definition +sendMessage r $ Message "/eval" [string "let x = 10"] +m <- recvMessage udp +m + +-- evaluate a binding statement +sendMessage r $ Message "/eval" [string "y <- return 1"] +m <- recvMessage udp +m + +-- evaluate a tidal statment +sendMessage r $ Message "/eval" [string "d1 $ s \"bd\" # n x"] +m <- recvMessage udp +m + +-- error +sendMessage r $ Message "/eval" [string "d1 $ suond \"bd\""] +m <- recvMessage udp +m + +-- ask the type of an expression +sendMessage r $ Message "/type" [string "s \"bd\""] +m <- recvMessage udp +m + +sendMessage r $ Message "/ping" [] +m <- recvMessage udp +m + +-- receive cps values +sendMessage r $ Message "/cps" [] +m <- recvMessage udp +m From 253ec2c71f953de2efd2d1e3146dd2d3357c7ac6 Mon Sep 17 00:00:00 2001 From: alex Date: Mon, 27 Jan 2025 17:29:16 +0100 Subject: [PATCH 06/12] format --- Setup.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/Setup.hs b/Setup.hs index 9a994af6..e8ef27db 100644 --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain From db0a677d1ff9bc73c4e011d11da9f4244485f1dc Mon Sep 17 00:00:00 2001 From: alex Date: Mon, 27 Jan 2025 17:42:09 +0100 Subject: [PATCH 07/12] point ormolu at source files --- .github/workflows/ci.yml | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index f1e73bfe..db238598 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -80,4 +80,11 @@ jobs: steps: - uses: actions/checkout@v4 - uses: haskell-actions/run-ormolu@v17 - + with: + pattern: + src/**/*.hs + tidal-link/src/**/*.hs + tidal-parse/src/**/*.hs + tidal-listener/src/**/*.hs + + \ No newline at end of file From 161f8980a4e3d969e10a4426c342c66135ddd6d6 Mon Sep 17 00:00:00 2001 From: alex Date: Mon, 27 Jan 2025 17:47:36 +0100 Subject: [PATCH 08/12] automatic reformat --- .github/workflows/ci.yml | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index db238598..9c479334 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -81,10 +81,14 @@ jobs: - uses: actions/checkout@v4 - uses: haskell-actions/run-ormolu@v17 with: + mode: inplace pattern: src/**/*.hs tidal-link/src/**/*.hs tidal-parse/src/**/*.hs tidal-listener/src/**/*.hs - - \ No newline at end of file + - name: apply ormolu formatting + uses: stefanzweifel/git-auto-commit-action@v4 + if: ${{ always() }} + with: + commit_message: automated ormolu reformatting From 2572db061e9179bb19a771109ad63f2c0699ad89 Mon Sep 17 00:00:00 2001 From: alex Date: Mon, 27 Jan 2025 18:05:42 +0100 Subject: [PATCH 09/12] whitespace change to test ormolu --- src/Sound/Tidal/Pattern.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Sound/Tidal/Pattern.hs b/src/Sound/Tidal/Pattern.hs index e0697429..35b67408 100644 --- a/src/Sound/Tidal/Pattern.hs +++ b/src/Sound/Tidal/Pattern.hs @@ -212,8 +212,8 @@ applyPatToPatSqueeze pf px = squeezeJoin $ (\f -> f <$> px) <$> pf -- as @innerJoin@, @innerJoin@ and @squeezeJoin@. instance Monad Pattern where - return = pure - p >>= f = unwrap (f <$> p) + return = pure + p >>= f = unwrap (f <$> p) -- | Turns a pattern of patterns into a single pattern. -- (this is actually 'join') From 01226c9b056c577cc79f78009460128b026ba403 Mon Sep 17 00:00:00 2001 From: alex Date: Mon, 27 Jan 2025 18:10:00 +0100 Subject: [PATCH 10/12] fix yaml --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 9c479334..77595278 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -82,7 +82,7 @@ jobs: - uses: haskell-actions/run-ormolu@v17 with: mode: inplace - pattern: + pattern: | src/**/*.hs tidal-link/src/**/*.hs tidal-parse/src/**/*.hs From fdc5125da4d61324d79c01b3c18181b878303646 Mon Sep 17 00:00:00 2001 From: alex Date: Mon, 27 Jan 2025 18:15:01 +0100 Subject: [PATCH 11/12] untabify --- .github/workflows/ci.yml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 77595278..d2b5057a 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -80,13 +80,13 @@ jobs: steps: - uses: actions/checkout@v4 - uses: haskell-actions/run-ormolu@v17 - with: - mode: inplace - pattern: | - src/**/*.hs - tidal-link/src/**/*.hs - tidal-parse/src/**/*.hs - tidal-listener/src/**/*.hs + with: + mode: inplace + pattern: | + src/**/*.hs + tidal-link/src/**/*.hs + tidal-parse/src/**/*.hs + tidal-listener/src/**/*.hs - name: apply ormolu formatting uses: stefanzweifel/git-auto-commit-action@v4 if: ${{ always() }} From f7041e5fb57ca6e8a7e38a55abfa8198dfa51e3b Mon Sep 17 00:00:00 2001 From: yaxu Date: Mon, 27 Jan 2025 17:15:20 +0000 Subject: [PATCH 12/12] automated ormolu reformatting --- src/Sound/Tidal/Pattern.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Sound/Tidal/Pattern.hs b/src/Sound/Tidal/Pattern.hs index 35b67408..e0697429 100644 --- a/src/Sound/Tidal/Pattern.hs +++ b/src/Sound/Tidal/Pattern.hs @@ -212,8 +212,8 @@ applyPatToPatSqueeze pf px = squeezeJoin $ (\f -> f <$> px) <$> pf -- as @innerJoin@, @innerJoin@ and @squeezeJoin@. instance Monad Pattern where - return = pure - p >>= f = unwrap (f <$> p) + return = pure + p >>= f = unwrap (f <$> p) -- | Turns a pattern of patterns into a single pattern. -- (this is actually 'join')