backport from #1055 and #1012

src/Sound/Tidal/UI.hs

@@ -222,6 +222,27 @@
 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
+-}
+normal :: (Floating a, Ord a) => Pattern a
+normal = do
+  u1 <- max 0.001 <$> rand
+  u2 <- rotL 1000 rand
+  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.
 
 @
@@ -274,9 +295,9 @@
 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)
     cweights = scanl1 (+) (map snd pairs)
     values = map fst pairs
     total = sum $ map snd pairs
@@ -985,7 +1006,7 @@
     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
@@ -1297,10 +1318,10 @@
   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]
@@ -1314,7 +1335,7 @@
           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
 
@@ -1365,7 +1386,7 @@
 -- 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)
@@ -1414,7 +1435,7 @@
 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 ]
 
@@ -1764,7 +1785,7 @@
   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
@@ -1979,7 +2000,7 @@
                 ("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),

test/Sound/Tidal/UITest.hs

@@ -139,6 +139,18 @@ run =
             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)]
+        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)]
+        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)]
+
     describe "range" $ do
       describe "scales a pattern to the supplied range" $ do
         describe "from 3 to 4" $ do

tidal.el

@@ -240,9 +240,9 @@ Two functions will be created, `tidal-run-NAME' and `tidal-stop-NAME'"
 ;; Generate the functions `tidal-run-d1' and `tidal-stop-d1'
 (tidal-create-runner "d1")
 
-;; This generates tidal-run-* and tidal-stop-* functions for d1 to d9.
+;; This generates tidal-run-* and tidal-stop-* functions for d1 to d10.
 (mapc #'tidal-create-runner
-      '("d1" "d2" "d3" "d4" "d5" "d6" "d7" "d8" "d9"))
+      '("d1" "d2" "d3" "d4" "d5" "d6" "d7" "d8" "d9" "d10"))
 
 (defun tidal-run-region ()
   "Place the region in a do block and compile."
@@ -264,6 +264,11 @@ Two functions will be created, `tidal-run-NAME' and `tidal-stop-NAME'"
   (interactive)
   (tidal-send-string "main"))
 
+(defun tidal-hush ()
+  "Stop all the patterns currently running."
+  (interactive)
+  (tidal-send-string "hush"))
+
 (defun tidal-interrupt-haskell ()
   "Interrupt running process."
   (interactive)
@@ -287,6 +292,7 @@ Two functions will be created, `tidal-run-NAME' and `tidal-stop-NAME'"
   (define-key map [?\C-c ?\C-l] 'tidal-load-buffer)
   (define-key map [?\C-c ?\C-i] 'tidal-interrupt-haskell)
   (define-key map [?\C-c ?\C-m] 'tidal-run-main)
+  (define-key map [?\C-c ?\C-h] 'tidal-hush)
   (define-key map [?\C-c ?\C-1] 'tidal-run-d1)
   (define-key map [?\C-c ?\C-2] 'tidal-run-d2)
   (define-key map [?\C-c ?\C-3] 'tidal-run-d3)
@@ -296,6 +302,7 @@ Two functions will be created, `tidal-run-NAME' and `tidal-stop-NAME'"
   (define-key map [?\C-c ?\C-7] 'tidal-run-d7)
   (define-key map [?\C-c ?\C-8] 'tidal-run-d8)
   (define-key map [?\C-c ?\C-9] 'tidal-run-d9)
+  (define-key map [?\C-c ?\C-0] 'tidal-run-d10)
   (define-key map [?\C-v ?\C-1] 'tidal-stop-d1)
   (define-key map [?\C-v ?\C-2] 'tidal-stop-d2)
   (define-key map [?\C-v ?\C-3] 'tidal-stop-d3)
@@ -304,7 +311,8 @@ Two functions will be created, `tidal-run-NAME' and `tidal-stop-NAME'"
   (define-key map [?\C-v ?\C-6] 'tidal-stop-d6)
   (define-key map [?\C-v ?\C-7] 'tidal-stop-d7)
   (define-key map [?\C-v ?\C-8] 'tidal-stop-d8)
-  (define-key map [?\C-v ?\C-9] 'tidal-stop-d9))
+  (define-key map [?\C-v ?\C-9] 'tidal-stop-d9)
+  (define-key map [?\C-c ?\C-0] 'tidal-stop-d10))
 
 (defun tidal-turn-on-keybindings ()
   "Haskell Tidal keybindings in the local map."
@@ -318,6 +326,7 @@ Two functions will be created, `tidal-run-NAME' and `tidal-stop-NAME'"
   (local-set-key [?\C-c ?\C-l] 'tidal-load-buffer)
   (local-set-key [?\C-c ?\C-i] 'tidal-interrupt-haskell)
   (local-set-key [?\C-c ?\C-m] 'tidal-run-main)
+  (local-set-key [?\C-c ?\C-h] 'tidal-hush)
   (local-set-key [?\C-c ?\C-1] 'tidal-run-d1)
   (local-set-key [?\C-c ?\C-2] 'tidal-run-d2)
   (local-set-key [?\C-c ?\C-3] 'tidal-run-d3)
@@ -327,6 +336,7 @@ Two functions will be created, `tidal-run-NAME' and `tidal-stop-NAME'"
   (local-set-key [?\C-c ?\C-7] 'tidal-run-d7)
   (local-set-key [?\C-c ?\C-8] 'tidal-run-d8)
   (local-set-key [?\C-c ?\C-9] 'tidal-run-d9)
+  (local-set-key [?\C-c ?\C-0] 'tidal-run-d10)
   (local-set-key [?\C-v ?\C-1] 'tidal-stop-d1)
   (local-set-key [?\C-v ?\C-2] 'tidal-stop-d2)
   (local-set-key [?\C-v ?\C-3] 'tidal-stop-d3)
@@ -335,7 +345,8 @@ Two functions will be created, `tidal-run-NAME' and `tidal-stop-NAME'"
   (local-set-key [?\C-v ?\C-6] 'tidal-stop-d6)
   (local-set-key [?\C-v ?\C-7] 'tidal-stop-d7)
   (local-set-key [?\C-v ?\C-8] 'tidal-stop-d8)
-  (local-set-key [?\C-v ?\C-9] 'tidal-stop-d9))
+  (local-set-key [?\C-v ?\C-9] 'tidal-stop-d9)
+  (local-set-key [?\C-v ?\C-0] 'tidal-stop-d10)))
 
 (defun tidal-mode-menu (map)
   "Haskell Tidal menu MAP."