Merge pull request #1173 from tidalcycles/wchooseby-patterned-weights

pattern weights for chooseby functions

tidal-core/src/Sound/Tidal/UI.hs

@@ -291,19 +291,19 @@ chooseBy f xs = (xs !!!) . floor <$> range 0 (fromIntegral $ length xs) f
 -- play as the "e" note, and half as likely to play as the "g" note.
 --
 -- > wchoose = 'wchooseBy' 'rand'
-wchoose :: [(a, Double)] -> Pattern a
+wchoose :: [(a, Pattern 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
-wchooseBy pat pairs = match <$> pat
+wchooseBy :: Pattern Double -> [(a, Pattern Double)] -> Pattern a
+wchooseBy pat pairs = match <$> pat <* cweightpat <* totalpat
   where
-    match r = values !! head (findIndices (> (r * total)) cweights)
-    cweights = scanl1 (+) (map snd pairs)
+    match r cweights total = values !! head (findIndices (> (r * total)) cweights)
+    cweightpat = sequence $ scanl1 (+) (map snd pairs)
     values = map fst pairs
-    total = sum $ map snd pairs
+    totalpat = sum $ map snd pairs
 
 -- | @randcat ps@: does a @slowcat@ on the list of patterns @ps@ but
 --  randomises the order in which they are played.
@@ -319,7 +319,7 @@ randcat ps = spread' rotL (_segment 1 $ (% 1) . fromIntegral <$> (_irand (length
 --  > d1 $ sound
 --  >    $ wrandcat
 --  >        [ ("bd*2 sn", 5), ("jvbass*3", 2), ("drum*2", 2), ("ht mt", 1) ]
-wrandcat :: [(Pattern a, Double)] -> Pattern a
+wrandcat :: [(Pattern a, Pattern Double)] -> Pattern a
 wrandcat ps = unwrap $ wchooseBy (segment 1 rand) ps
 
 -- | @degrade@ randomly removes events from a pattern 50% of the time:

tidal-core/tidal-core.cabal

@@ -1,7 +1,7 @@
 cabal-version: 2.0
 
 name: tidal-core
-version: 1.9.6
+version: 1.10
 
 license: GPL-3
 copyright:           (c) Alex McLean and other contributors, 2025

tidal-listener/tidal-listener.cabal

@@ -26,7 +26,7 @@ library
                        deepseq,
                        optparse-applicative,
                        tidal >= 1.10 && < 1.11,
-                       tidal-core,
+                       tidal-core >= 1.10 && < 1.11,
                        hosc >= 0.21 && < 0.22,
                        hint,
                        network

tidal-parse/src/Sound/Tidal/Parse.hs

@@ -6,10 +6,10 @@
 
 module Sound.Tidal.Parse (parseTidal) where
 
-import Control.Applicative
-import Control.Monad.Except
-import Data.Bifunctor
-import Data.Char
+import Control.Applicative (Alternative (empty, (<|>)))
+import Control.Monad.Except (MonadError (throwError))
+import Data.Bifunctor (Bifunctor (bimap))
+import Data.Char (isSpace)
 import Data.List (dropWhileEnd)
 import qualified Data.Text
 import Language.Haskellish as Haskellish
@@ -18,17 +18,21 @@ import Sound.Tidal.Control as T
 import Sound.Tidal.Core as T
 import Sound.Tidal.Params as T
 import Sound.Tidal.Parse.TH
+  ( fromHaskell,
+    fromTidal,
+    fromTidalList,
+  )
 import Sound.Tidal.ParseBP (Enumerable, Parseable, parseBP)
 import Sound.Tidal.Pattern as T
-import Sound.Tidal.Scales as T
-import Sound.Tidal.Simple as T
+import Sound.Tidal.Scales as T (scale)
+import Sound.Tidal.Simple as T (silent)
 import Sound.Tidal.UI as T
 
 type H = Haskellish ()
 
 -- This is depended upon by Estuary, and changes to its type will cause problems downstream for Estuary.
 parseTidal :: String -> Either String ControlPattern
-parseTidal x = if x' == [] then (return silence) else r
+parseTidal x = if null x' then return silence else r
   where
     x' = dropWhileEnd isSpace $ dropWhile isSpace $ Haskellish.removeComments x
     r = bimap showSyntaxError fst $ Haskellish.parseAndRun parser () x
@@ -164,12 +168,12 @@ 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 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
+    <|> tupleApDouble_p <*!> parser
     <|> listTupleStringTransformation_p <*!> parser
     <|> parseSilence
 
@@ -423,7 +427,7 @@ instance Parse ([Pattern a] -> Pattern a) where
       <|> (parser :: H (Pattern Int -> [Pattern a] -> Pattern a)) <*!> parser
       <|> a_patternB
 
-instance Parse ([(Pattern a, Double)] -> Pattern a) where
+instance Parse ([(Pattern a, Pattern Double)] -> Pattern a) where
   parser =
     $(fromTidal "wrandcat")
       <|> a_patternB
@@ -551,10 +555,10 @@ 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 =
+tupleApDouble_p :: (Parse a) => H ([(a, Pattern Double)] -> Pattern a)
+tupleApDouble_p =
   $(fromTidal "wchoose")
-    <|> pDouble_tupleADouble_p <*!> parser
+    <|> pDouble_tupleApDouble_p <*!> parser
 
 instance Parse ([(Time, Pattern a)] -> Pattern a) where
   parser = $(fromTidal "timeCat") <|> $(fromTidal "timecat")
@@ -903,8 +907,8 @@ 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 = $(fromTidal "wchooseBy")
+pDouble_tupleApDouble_p :: (Parse a) => H (Pattern Double -> [(a, Pattern Double)] -> Pattern a)
+pDouble_tupleApDouble_p = $(fromTidal "wchooseBy")
 
 instance Parse (String -> String -> Pattern String) where
   parser = $(fromTidal "sseq")

tidal-parse/tidal-parse.cabal

@@ -30,7 +30,7 @@ library
 
   Build-depends:
       base >=4.8 && <5
-    , tidal-core
+    , tidal-core == 1.10
     , transformers >= 0.5 && < 0.7
     , template-haskell
     , haskellish >= 0.3.2 && < 0.4

tidal.cabal

@@ -61,7 +61,7 @@ library
     , exceptions < 0.11
     , mtl >= 2.2 && < 2.4
     , tidal-link >= 1.1 && < 1.2
-    , tidal-core == 1.9.6
+    , tidal-core == 1.10
 
 test-suite tests
   type: exitcode-stdio-1.0