hsc3-lang 0.14 → 0.15

raw patch · 34 files changed

+3490/−2377 lines, 34 filesdep +data-ordlistdep +dlistdep +hashabledep ~hoscdep ~hsc3PVP ok

version bump matches the API change (PVP)

Dependencies added: data-ordlist, dlist, hashable, vector

Dependency ranges changed: hosc, hsc3

API changes (from Hackage documentation)

Files

• README +1/−1
• Sound/SC3/Lang/Collection.hs +178/−13
• Sound/SC3/Lang/Collection/Array.hs +31/−0
• Sound/SC3/Lang/Collection/Numerical/Extending.hs +22/−0
• Sound/SC3/Lang/Collection/Numerical/Truncating.hs +0/−5
• Sound/SC3/Lang/Collection/Vector.hs +30/−0
• Sound/SC3/Lang/Control/Duration.hs +33/−14
• Sound/SC3/Lang/Control/Event.hs +10/−13
• Sound/SC3/Lang/Control/Instrument.hs +1/−1
• Sound/SC3/Lang/Control/Midi.hs +55/−52
• Sound/SC3/Lang/Control/Midi/ST.hs +82/−0
• Sound/SC3/Lang/Control/OverlapTexture.hs +154/−107
• Sound/SC3/Lang/Control/Pitch.hs +1/−1
• Sound/SC3/Lang/Core.hs +139/−0
• Sound/SC3/Lang/Data/CMUdict.hs +239/−0
• Sound/SC3/Lang/Math.hs +18/−1
• Sound/SC3/Lang/Math/Warp.hs +53/−9
• Sound/SC3/Lang/Pattern.hs +3/−1
• Sound/SC3/Lang/Pattern/Bind.hs +94/−0
• Sound/SC3/Lang/Pattern/ID.hs +0/−1960
• Sound/SC3/Lang/Pattern/List.hs +16/−173
• Sound/SC3/Lang/Pattern/P.hs +7/−0
• Sound/SC3/Lang/Pattern/P/Base.hs +333/−0
• Sound/SC3/Lang/Pattern/P/Core.hs +261/−0
• Sound/SC3/Lang/Pattern/P/Event.hs +574/−0
• Sound/SC3/Lang/Pattern/P/SC3.hs +883/−0
• Sound/SC3/Lang/Pattern/Plain.hs +5/−0
• Sound/SC3/Lang/Pattern/Stream.hs +139/−0
• Sound/SC3/Lang/Random/Gen.hs +56/−8
• Sound/SC3/Lang/Random/ID.hs +18/−0
• Sound/SC3/Lang/Random/IO.hs +5/−4
• Sound/SC3/Lang/Random/Lorrain_1980.hs +9/−4
• Sound/SC3/Lang/Random/Monad.hs +15/−2
• hsc3-lang.cabal +25/−8

@@ -5,7 +5,7 @@ module that defines a subset of functions from the [SuperCollider Language][sc3] class library. -© [rohan drape][rd], 2007-2013, [gpl][gpl].+© [rohan drape][rd], 2007-2014, [gpl][gpl].  [hs]: http://haskell.org/ [sc3]: http://audiosynth.com/

@@ -3,10 +3,13 @@ -- becomes @m i j c@. module Sound.SC3.Lang.Collection where -import qualified Data.List.Split as S {- split -}+import qualified Data.List.Split as L {- split -} import Data.List as L {- base -} import Data.Maybe {- base -}+import qualified Sound.SC3 as S {- hsc3 -} +import Sound.SC3.Lang.Core+ -- * Collection  -- | @Collection.*fill@ is 'map' over indices to /n/.@@ -77,21 +80,21 @@ -- -- > any' (\i _ -> even i) [1,2,3,4] == True any' :: Integral i => (a -> i -> Bool) -> [a] -> Bool-any' f = isJust . detect f+any' = isJust .: detect  -- | @Collection.every@ is 'True' if /f/ applies at all elements. -- -- > every (\i _ -> even i) [1,2,3,4] == False every :: Integral i => (a -> i -> Bool) -> [a] -> Bool every f =-    let g e = not . f e+    let g = not .: f     in not . any' g --- | @Collection.count@ is 'length' '.' 'select'.+-- | @Collection.count@ is 'length' of 'select'. -- -- > count (\i _ -> even i) [1,2,3,4] == 2 count :: Integral i => (a -> i -> Bool) -> [a] -> i-count f = genericLength . select f+count = genericLength .: select  -- | @Collection.occurencesOf@ is an '==' variant of 'count'. --@@ -100,23 +103,23 @@ occurencesOf :: (Integral i,Eq a) => a -> [a] -> i occurencesOf k = count (\e _ -> e == k) --- | @Collection.sum@ is 'sum' '.' 'collect'.+-- | @Collection.sum@ is 'sum' of 'collect'. -- -- > sum' (ignoringIndex (* 2)) [1,2,3,4] == 20 sum' :: (Num a,Integral i) => (b -> i -> a) -> [b] -> a-sum' f = sum . collect f+sum' = sum .: collect --- | @Collection.maxItem@ is 'maximum' '.' 'collect'.+-- | @Collection.maxItem@ is 'maximum' of 'collect'. -- -- > maxItem (ignoringIndex (* 2)) [1,2,3,4] == 8 maxItem :: (Ord b,Integral i) => (a -> i -> b) -> [a] -> b-maxItem f = maximum . collect f+maxItem = maximum .: collect  -- | @Collection.minItem@ is 'maximum' '.' 'collect'. -- -- > minItem (ignoringIndex (* 2)) [1,2,3,4] == 2 minItem :: (Integral i,Ord b) => (a -> i -> b) -> [a] -> b-minItem f = minimum . collect f+minItem = minimum .: collect  -- | Variant of 'zipWith' that cycles the shorter input. --@@ -250,7 +253,7 @@  -- | 'fromJust' variant of 'indexOf'. indexOf' :: Eq a => [a] -> a -> Int-indexOf' l = fromJust . indexOf l+indexOf' = fromJust .: indexOf  -- | @SequenceableCollection.indexOfEqual@ is just 'indexOf'. indexOfEqual :: Eq a => [a] -> a -> Maybe Int@@ -276,8 +279,10 @@     in maybe (size l - 1) f (indexOfGreaterThan e l)  -- | @SequenceableCollection.indexInBetween@ is the linearly--- interpolated fractional index.+-- interpolated fractional index.  Collection must be sorted. The+-- inverse operation is 'blendAt'. --+-- > > [2,3,5,6].indexInBetween(5.2) == 2.2 -- > indexInBetween 5.2 [2,3,5,6] == 2.2 indexInBetween :: (Ord a,Fractional a) => a -> [a] -> a indexInBetween e l =@@ -412,7 +417,7 @@ -- > > [1,2,3,4,5,6,7,8].clump(3) == [[1,2,3],[4,5,6],[7,8]] -- > clump 3 [1,2,3,4,5,6,7,8] == [[1,2,3],[4,5,6],[7,8]] clump :: Int -> [a] -> [[a]]-clump = S.chunksOf+clump = L.chunksOf  -- | @SequenceableCollection.clumps@ is a synonym for -- 'Data.List.Split.splitPlaces'.@@ -428,6 +433,47 @@          [] -> []          _ -> f (cycle m) s +-- | 'blendAt' with @clip@ function as argument.+blendAtBy :: (Integral i,RealFrac n) => (i -> t -> n) -> n -> t -> n+blendAtBy f ix c =+    let m = floor ix+        m' = fromIntegral m+    in blend (absdif ix m') (f m c) (f (m + 1) c)++-- | @SequenceableCollection.blendAt@ returns a linearly interpolated+-- value between the two closest indices.  Inverse operation is+-- 'indexInBetween'.+--+-- > > [2,5,6].blendAt(0.4) == 3.2+--+-- > blendAt 0 [2,5,6] == 2+-- > blendAt 0.4 [2,5,6] == 3.2+blendAt :: RealFrac a => a -> [a] -> a+blendAt = blendAtBy clipAt++-- | Resampling function, /n/ is destination length, /r/ is source+-- length, /f/ is the indexing function, /c/ is the collection.+resamp1_gen :: (Integral i,RealFrac n) => i -> i -> (i -> t -> n) -> t -> i -> n+resamp1_gen n r f c =+    let n' = fromIntegral n+        fwd = (fromIntegral r - 1) / (n' - 1)+        gen i = blendAtBy f (fromIntegral i * fwd) c+    in gen++-- | @SequenceableCollection.resamp1@ returns a new collection of the+-- desired length, with values resampled evenly-spaced from the+-- receiver with linear interpolation.+--+-- > > [1,2,3,4].resamp1(12)+-- > > [1,2,3,4].resamp1(3) == [1,2.5,4]+--+-- > resamp1 12 [1,2,3,4]+-- > resamp1 3 [1,2,3,4] == [1,2.5,4]+resamp1 :: (Enum n,RealFrac n) => Int -> [n] -> [n]+resamp1 n c =+    let gen = resamp1_gen n (length c) clipAt c+    in map gen [0 .. n - 1]+ -- * List and Array  -- | @List.lace@ is a concatenated transposition of cycled@@ -490,6 +536,37 @@     let n = sum l     in map (/ n) l +-- | @ArrayedCollection.normalize@ returns a new Array with the receiver+-- items normalized between min and max.+--+-- > > [1,2,3].normalize == [0,0.5,1]+-- > > [1,2,3].normalize(-20,10) == [-20,-5,10]+--+-- > normalize 0 1 [1,2,3] == [0,0.5,1]+-- > normalize (-20) 10 [1,2,3] == [-20,-5,10]+normalize :: (S.TernaryOp b,Fractional b, Ord b) => b -> b -> [b] -> [b]+normalize l r c =+    let cl = minimum c+        cr = maximum c+    in map (\e -> S.linlin e cl cr l r) c++-- | @ArrayedCollection.asRandomTable@ returns an integral table that+-- can be used to generate random numbers with a specified+-- distribution.+--+-- > > [1,0,1,0,1,0,1].asRandomTable(256).plot+-- > > ((0..100) ++ (100..50) / 100).asRandomTable.plot+--+-- > import Sound.SC3.Plot+-- > plotTable [asRandomTable 256 [1,0,1,0,1,0,1]]+-- > plotTable [asRandomTable 256 (map (/ 100) ([0..100] ++ [100,99..50]))]+asRandomTable :: (S.TernaryOp a,Enum a, RealFrac a) => Int -> [a] -> [a]+asRandomTable n c =+    let n' = fromIntegral n+        a = integrate (resamp1 n c)+        b = normalize 0 (n' - 1) a+    in map (\i -> indexInBetween i b / n') [0 .. n' - 1]+ -- | @List.slide@ is an identity window function with subsequences of -- length /w/ and stride of /n/. --@@ -636,3 +713,91 @@ to_wavetable =     let f (e0,e1) = (2 * e0 - e1,e1 - e0)     in t2_concat . map f . t2_overlap . (++ [0])++-- | Variant of 'sineFill' that gives each component table.+--+-- > let t = sineGen 1024 (map recip [1,2,3,5,8,13,21,34,55]) (replicate 9 0)+-- > map length t == replicate 9 1024+--+-- > import Sound.SC3.Plot+-- > plotTable t+sineGen :: (Floating n,Enum n) => Int -> [n] -> [n] -> [[n]]+sineGen n =+    let incr = (2 * pi) / fromIntegral n+        ph partial = take n [0,incr * fromIntegral partial ..]+        f h amp iph = map (\z -> sin (z + iph) * amp) (ph h)+    in zipWith3 f [1..]++-- | @Signal.*sineFill@ is a table generator.  Frequencies are+-- partials, amplitudes and initial phases are as given.  Result is+-- normalised.+--+-- > let t = let a = [[21,5,34,3,2,13,1,8,55]+-- >                 ,[13,8,55,34,5,21,3,1,2]+-- >                 ,[55,34,1,3,2,13,5,8,21]]+-- >         in map (\amp -> sineFill 1024 (map recip amp) (replicate 9 0)) a+--+-- > import Sound.SC3.Plot+-- > plotTable t+sineFill :: (S.TernaryOp n,Ord n,Floating n,Enum n) => Int -> [n] -> [n] -> [n]+sineFill n amp iph =+    let t = sineGen n amp iph+    in normalize (-1) 1 (map sum (transpose t))++-- * Required++-- | /z/ ranges from 0 (for /i/) to 1 (for /j/).+--+-- > > 1.5.blend(2.0,0.50) == 1.75+-- > > 1.5.blend(2.0,0.75) == 1.875+--+-- > blend 0.50 1.5 2 == 1.75+-- > blend 0.75 1.5 2 == 1.875+blend :: Num a => a -> a -> a -> a+blend z i j = i + (z * (j - i))++-- | Variant of '(!!)' but values for index greater than the size of+-- the collection will be clipped to the last index.+clipAt :: Int -> [a] -> a+clipAt ix c =+    if ix > length c - 1+    then L.last c+    else c !! ix++-- | 'abs' of '(-)'.+absdif :: Num a => a -> a -> a+absdif i j = abs (j - i)++-- * Variants++-- | Variant where all inputs are lists and the result is not+-- catentated.  Does not generate partial windows.+--+-- > let r = ["abc","bc","def","ef","ghi","hi"]+-- > in slide1 (cycle [3,2]) (cycle [1,2]) ['a'..'i'] == r+--+-- > let r = ["abc","bc","bcd","cd","cde","de"]+-- > in slide1 (cycle [3,2]) (cycle [1,0]) ['a'..'e'] == r+slide1 :: Integral i => [i] -> [i] -> [a] -> [[a]]+slide1 w n l =+    case (w,n,l) of+      (w0:w',n0:n',_) -> case genericTakeMaybe w0 l of+                           Nothing -> []+                           Just r -> let l' = genericDrop n0 l+                                     in r : slide1 w' n' l'+      _ -> []++-- | 'concat' of 'slide1'.+slide2 :: Integral i => [i] -> [i] -> [a] -> [a]+slide2 = concat .:: slide1++-- | Variant where stutter input is a list and the result is not+-- catentated.+--+-- > stutter1 [2,1,2] [1,2,3] == [[1,1],[2],[3,3]]+stutter1 :: Integral i => [i] -> [a] -> [[a]]+stutter1 = zipWith genericReplicate++-- | 'concat' of 'stutter1'.+stutter2 :: Integral i => [i] -> [a] -> [a]+stutter2 = concat .: stutter1

@@ -0,0 +1,31 @@+-- | 'A.Array' variants of "Sound.SC3.Lang.Collection".+module Sound.SC3.Lang.Collection.Array where++import qualified Data.Array as A {- array -}++import qualified Sound.SC3.Lang.Collection as C++-- | 'C.clipAt'.+clipAt :: Int -> A.Array Int a -> a+clipAt ix c =+    let (l,r) = A.bounds c+        f = (A.!) c+    in if ix < l then f l else if ix > r then f r else f ix++-- | 'C.blendAtBy' of 'clipAt'.+--+-- > blendAt 0 (A.listArray (0,2) [2,5,6]) == 2+-- > blendAt 0.4 (A.listArray (0,2) [2,5,6]) == 3.2+blendAt :: RealFrac a => a -> A.Array Int a -> a+blendAt = C.blendAtBy clipAt++-- | 'C.resamp1'.+--+-- > resamp1 12 (A.listArray (0,3) [1,2,3,4])+-- > resamp1 3 (A.listArray (0,3) [1,2,3,4]) == A.listArray (0,2) [1,2.5,4]+resamp1 :: (Enum n,RealFrac n) => Int -> A.Array Int n -> A.Array Int n+resamp1 n c =+    let (_,r) = A.bounds c+        gen = C.resamp1_gen n (r + 1) clipAt c+        rs = map gen [0 .. n - 1]+    in A.listArray (0,n - 1) rs

@@ -23,6 +23,28 @@     signum = map signum     fromInteger n = [fromInteger n] +instance Real a => Real [a] where+  toRational = error "[Real], toRational"++instance Enum a => Enum [a] where+  succ = map succ+  pred = map pred+  toEnum = return . toEnum+  fromEnum = error "[Enum], fromEnum"+  enumFrom = error "[Enum]"+  enumFromThen = error "[Enum]"+  enumFromTo = error "[Enum]"+  enumFromThenTo = error "[Enum]"++instance Integral a => Integral [a] where+  quot = zipWith_c quot+  rem = zipWith_c rem+  div = zipWith_c div+  mod = zipWith_c mod+  quotRem = error "[Integral] is partial"+  divMod = error "[Integral] is partial"+  toInteger = error "[Integral] is partial"+ instance Fractional a => Fractional [a] where     recip = map recip     (/) = zipWith_c (/)

@@ -45,8 +45,3 @@     asinh = map asinh     acosh = map acosh     atanh = map atanh--{--[1,2,3] * [4,5]-[1,2,3] * 2--}

@@ -0,0 +1,30 @@+-- | 'V.Vector' variants of "Sound.SC3.Lang.Collection".+module Sound.SC3.Lang.Collection.Vector where++import qualified Data.Vector as V {- vector -}++import qualified Sound.SC3.Lang.Collection as C++-- | 'C.clipAt'.+clipAt :: Int -> V.Vector a -> a+clipAt ix c =+    let r = V.length c+        f = (V.!) c+    in if ix > r - 1 then f (r - 1) else f ix++-- | 'C.blendAtBy' of 'clipAt'.+--+-- > blendAt 0 (V.fromList [2,5,6]) == 2+-- > blendAt 0.4 (V.fromList [2,5,6]) == 3.2+-- > blendAt 2.1 (V.fromList [2,5,6]) == 6+blendAt :: RealFrac a => a -> V.Vector a -> a+blendAt = C.blendAtBy clipAt++-- | 'C.resamp1'.+--+-- > resamp1 12 (V.fromList [1,2,3,4])+-- > resamp1 3 (V.fromList [1,2,3,4]) == V.fromList [1,2.5,4]+resamp1 :: (Enum n,RealFrac n) => Int -> V.Vector n -> V.Vector n+resamp1 n c =+    let gen = C.resamp1_gen n (V.length c) clipAt c+    in V.generate n gen

@@ -2,26 +2,45 @@ module Sound.SC3.Lang.Control.Duration where  import Data.Maybe {- base -}+import Data.Ratio {- base -} --- * Durational+-- * Duration --- | Values that have duration.+-- | There are three parts to a duration: ----- @occ@ is the interval from the start through to the end of the--- current event, ie. the time span the event /occupies/.+-- 'delta' is the /logical/ or /notated/ duration. ----- @delta@ is the interval from the start of the current event to the--- start of the next /sequential/ event.+-- 'occ' is the /sounding/ duration, the interval that a value+-- actually occupies in time.  If 'occ' '<' 'delta' there will be a+-- /hole/, if 'occ' '>' 'delta' there will be an /overlap/. ----- @fwd@ is the interval from the start of the current event to the--- start of the next /parallel/ event.-class Durational d where-    occ :: d -> Double+-- 'fwd' is the /forward/ duration, the interval to the start time of+-- the next value in the sequence, which may be /parallel/ to the+-- current value.  Ordinarily 'fwd' is either 'delta' or @0@.+class Duration d where     delta :: d -> Double-    delta = occ+    occ :: d -> Double+    occ = delta     fwd :: d -> Double-    fwd = occ+    fwd = delta +instance Duration Int where delta = fromIntegral+instance Duration Integer where delta = fromIntegral+instance Duration Float where delta = realToFrac+instance Duration Double where delta = id+instance Integral i => Duration (Ratio i) where delta = realToFrac++{- FlexibleInstances+instance Real i => Duration (i,i,i) where+    delta (i,_,_) = realToFrac i+    occ (_,i,_) = realToFrac i+    fwd (_,_,i) = realToFrac i+-}++-- | Composite of 'delta', 'occ', and 'fwd'.+duration :: Duration d => d -> (Double,Double,Double)+duration d = (delta d,occ d,fwd d)+ -- * Dur  -- | Variant of the @SC3@ 'Duration' model.@@ -41,9 +60,9 @@         }     deriving (Eq,Show) -instance Durational Dur where-    occ d = fromMaybe (delta d * legato d) (sustain' d)+instance Duration Dur where     delta d = fromMaybe (dur d * stretch d * (60 / tempo d)) (delta' d)+    occ d = fromMaybe (delta d * legato d) (sustain' d)     fwd d = maybe (delta d) (* stretch d) (fwd' d)  -- | Default 'Dur' value, equal to one second.

@@ -11,6 +11,7 @@ import System.Random {- base -}  import qualified Sound.SC3.Lang.Collection as C+import Sound.SC3.Lang.Core import qualified Sound.SC3.Lang.Control.Duration as D import qualified Sound.SC3.Lang.Control.Instrument as I import qualified Sound.SC3.Lang.Control.Pitch as P@@ -228,7 +229,7 @@     floatDigits = f_atf floatDigits     floatRange = f_atf floatRange     decodeFloat = f_atf decodeFloat-    encodeFloat i = F_Double . encodeFloat i+    encodeFloat = F_Double .: encodeFloat     exponent = f_atf exponent     significand = f_uop significand     scaleFloat i = f_uop (scaleFloat i)@@ -248,9 +249,9 @@ instance Enum Field where     fromEnum = f_atf fromEnum     enumFrom = f_atf (map F_Double . enumFrom)-    enumFromThen = f_atf2 (\a -> map F_Double . enumFromThen a)-    enumFromTo = f_atf2 (\a -> map F_Double . enumFromTo a)-    enumFromThenTo = f_atf3 (\a b -> map F_Double . enumFromThenTo a b)+    enumFromThen = f_atf2 (map F_Double .: enumFromThen)+    enumFromTo = f_atf2 (map F_Double .: enumFromTo)+    enumFromThenTo = f_atf3 (map F_Double .:: enumFromThenTo)     toEnum = F_Double . fromIntegral  instance Random Field where@@ -697,7 +698,7 @@ -- | Transform (productively) an 'Event_Seq' into an 'NRT' score. -- -- > let {n1 = nrt_bundles (e_nrt (Event_Seq (replicate 5 mempty)))--- >     ;n2 = take 10 (nrt_bundles (e_nrt (Event_Seq (repeat mempty))))}+-- >     ;n2 = take 11 (nrt_bundles (e_nrt (Event_Seq (repeat mempty))))} -- > in n1 == n2 e_nrt :: Event_Seq -> NRT e_nrt =@@ -706,18 +707,14 @@               [] -> r               (o,c):l' -> let (c',r') = span (<= o) (insert o (insert c r))                           in c' ++ rec r' l'-    in NRT . rec [] . e_bundle_seq 0+        g0 = Bundle 0 [g_new [(1,AddToTail,0)]]+    in NRT . (g0 :) . rec [] . e_bundle_seq 0  -- | Audition 'Event_Seq'. e_play :: Transport m => Event_Seq -> m ()-e_play l = do-  st <- time-  let f (p,q) = pauseThreadUntil (bundleTime p - 0.1) >>-                sendBundle p >>-                sendBundle q-  mapM_ f (e_bundle_seq st l)+e_play = play . e_nrt -instance Audible Event_Seq where play = e_play+instance Audible Event_Seq where play_at _ = e_play  -- * Aliases 

@@ -2,7 +2,7 @@ module Sound.SC3.Lang.Control.Instrument where  import Data.Default {- data-default -}-import Sound.SC3.ID {- hsc3 -}+import Sound.SC3 {- hsc3 -}  -- | An 'Instr' is either a 'Synthdef' or the 'String' naming a -- 'Synthdef'.

@@ -1,16 +1,11 @@--- | For a single input controller, key events always arrive in--- sequence (ie. on->off), ie. for any key on message we can allocate--- an ID and associate it with the key, an off message can retrieve--- the ID given the key.+-- | Trivial midi functions. module Sound.SC3.Lang.Control.Midi where -import qualified Control.Exception as E {- base -}-import Control.Monad {- base -}-import Control.Monad.IO.Class {- transformers -}-import Control.Monad.Trans.State {- transformers -}+import Control.Exception {- base -} import Data.Bits {- base -} import qualified Data.ByteString.Lazy as B {- bytestring -} import qualified Data.Map as M {- containers -}+import Data.Maybe {- base -} import Sound.OSC.FD {- hosc -}  -- * Bits@@ -129,58 +124,66 @@ -- | @SC3@ node identifiers are integers. type Node_Id = Int --- | Map of allocated 'Node_Id's.-data K a = K (M.Map (a,a) Node_Id) Node_Id+-- | Map of allocated 'Node_Id's.  For a single input controller, key+-- events always arrive in sequence (ie. on->off), ie. for any key on+-- message we can allocate an ID and associate it with the key, an off+-- message can retrieve the ID given the key.+data KY a = KY (M.Map a Node_Id) Node_Id --- | 'StateT' of 'K' specialised to 'Int'.-type KT = StateT (K Int) IO+-- | Initialise 'KY' with starting 'Node_Id'.+ky_init :: Node_Id -> KY a+ky_init = KY M.empty --- | Initialise 'K' with starting 'Node_Id'.-k_init :: Node_Id -> K a-k_init = K M.empty+-- | 'KY' 'Node_Id' allocator.+ky_alloc :: Ord a => KY a -> a -> (KY a,Node_Id)+ky_alloc (KY m i) n = (KY (M.insert n i m) (i + 1),i) --- | 'K' 'Node_Id' allocator.-k_alloc :: (Int,Int) -> KT Node_Id-k_alloc n = do-  (K m i) <- get-  put (K (M.insert n i m) (i + 1))-  return i+-- | 'KY' 'Node_Id' removal.+ky_free :: Ord a => KY a -> a -> (KY a,Node_Id)+ky_free (KY m i) n =+    let r = m M.! n+    in (KY (M.delete n m) i,r) --- | 'K' 'Node_Id' retrieval.-k_get :: (Int,Int) -> KT Node_Id-k_get n = do-  (K m _) <- get-  return (m M.! n)+-- | Lookup 'Node_Id'.+ky_get :: Ord a => KY a -> a -> Node_Id+ky_get (KY m _) n = m M.! n --- * IO+-- | All 'Node_Id'.+ky_all :: KY a -> [Node_Id]+ky_all (KY m _) = M.foldl (flip (:)) [] m --- | The 'Midi_Receiver' is passed a 'Midi_Message' and a 'Node_Id'.--- For 'Note_On' and 'Note_Off' messages the 'Node_Id' is positive,--- for all other message it is @-1@.-type Midi_Receiver m n = Midi_Message n -> Int -> m ()+-- * IO (midi-osc) --- | Parse incoming midi messages, do 'K' allocation, and run--- 'Midi_Receiver'.-midi_act :: Midi_Receiver IO Int -> Message -> StateT (K Int) IO ()-midi_act f o = do+type Midi_Init_f st = (UDP -> IO st)++-- | 'Midi_Recv_f' is passed the @SC3@ connection, the user state, a+-- 'Midi_Message' and, for 'Note_On' and 'Note_Off' messages, a+-- 'Node_Id'.+type Midi_Recv_f st = UDP -> st -> Midi_Message Int -> IO st++-- | Parse incoming midi messages and run 'Midi_Receiver'.+midi_act :: Midi_Recv_f st -> UDP -> st -> Message -> IO st+midi_act recv_f fd st o = do     let m = parse_m o-    n <- case m of-           Note_Off ch k _ -> k_get (ch,k)-           Note_On ch k _ -> k_alloc (ch,k)-           _ -> return (-1)-    liftIO (f m n)+    st' <- recv_f fd st m+    return st' --- | Run midi system, handles 'E.AsyncException's.-start_midi :: (UDP -> Midi_Receiver IO Int) -> IO ()-start_midi receiver = do-  s_fd <- openUDP "127.0.0.1" 57110 -- midi-osc+-- | Connect to @midi-osc@ and @sc3@, run initialiser, and then+-- receiver for each incoming message.+run_midi :: Midi_Init_f st -> Midi_Recv_f st -> IO ()+run_midi init_f recv_f = do   m_fd <- openUDP "127.0.0.1" 57150 -- midi-osc+  s_fd <- openUDP "127.0.0.1" 57110 -- scsynth   sendMessage m_fd (Message "/receive" [Int32 0xffff])-  let step = liftIO (recvMessages m_fd) >>=-             midi_act (receiver s_fd) . head-      ex e = print ("start_midi",show (e::E.AsyncException)) >>-             close m_fd >>-             close s_fd-      runs = void (runStateT (forever step) (k_init 1000))-  E.catch runs ex-  return ()+  init_st <- init_f s_fd+  finally+    (iterateM_ init_st (\st -> recvMessage m_fd >>=+                               midi_act recv_f s_fd st . fromJust))+    (sendMessage m_fd (Message "/receive" [Int32 (-1)]))++-- * Monad++iterateM_ :: (Monad m) => st -> (st -> m st) -> m ()+iterateM_ st f = do+  st' <- f st+  iterateM_ st' f

@@ -0,0 +1,82 @@+-- | Maintain midi state, query functions.+module Sound.SC3.Lang.Control.Midi.ST where++import Control.Concurrent {- base -}+import qualified Data.Map as M {- containers -}++import Sound.SC3.Lang.Control.Midi {- hsc3-lang -}++type Midi_7bit = Int+type Midi_Note = Midi_7bit+type Midi_Velocity = Midi_7bit+type Midi_Program = Midi_7bit+type Midi_CC_Ix = Midi_7bit+type Midi_CC_Value = Midi_7bit++type Midi_Key_Map = M.Map Midi_Note Midi_Velocity+type Midi_CC_Map = M.Map Midi_CC_Ix Midi_CC_Value++type Midi_State = MVar (Midi_Key_Map,Midi_Program,Midi_CC_Map)++st_edit_km :: Midi_State -> (Midi_Note,Midi_Velocity) -> IO Midi_State+st_edit_km mv (k,v) =+    let f (m,p,c) = (if v == 0 then M.delete k m else M.insert k v m,p,c)+    in modifyMVar_ mv (return . f) >> return mv++st_edit_cc :: Midi_State -> (Midi_CC_Ix,Midi_CC_Value) -> IO Midi_State+st_edit_cc mv (k,v) =+    let f (m,p,c) = (m,p,M.insert k v c)+    in modifyMVar_ mv (return . f) >> return mv++st_edit_pc :: Midi_State -> Midi_Program -> IO Midi_State+st_edit_pc mv p =+    let f (m,_,c) = (m,p,c)+    in modifyMVar_ mv (return . f) >> return mv++p3_fst :: (t,u,v) -> t+p3_fst (t,_,_) = t++p3_third :: (t,u,v) -> v+p3_third (_,_,v) = v++st_access_km :: (Midi_Key_Map -> r) -> Midi_State -> IO r+st_access_km f mv = withMVar mv (return . f . p3_fst)++st_access_cc :: (Midi_CC_Map -> r) -> Midi_State -> IO r+st_access_cc f mv = withMVar mv (return . f . p3_third)++st_read_note :: Midi_State -> Midi_Note -> IO (Maybe Midi_Velocity)+st_read_note st k = st_access_km (M.lookup k) st++st_read_cc :: Midi_State -> Midi_CC_Ix -> IO Midi_CC_Value+st_read_cc st k = st_access_cc (M.findWithDefault 0 k) st++st_chord :: Midi_State -> IO [Midi_Note]+st_chord = st_access_km (map fst . M.toAscList)++st_init_f :: Midi_State -> Midi_Init_f Midi_State+st_init_f v _ = return v++st_recv_f :: Midi_Recv_f Midi_State+st_recv_f _ st msg =+    case msg of+      Note_Off _ j _ -> st_edit_km st (j,0)+      Note_On _ j k -> st_edit_km st (j,k)+      Control_Change _ j k -> st_edit_cc st (j,k)+      Program_Change _ j -> st_edit_pc st j+      _ -> print msg >> return st++st_run :: IO (Midi_State,ThreadId)+st_run = do+  v <- newMVar (M.empty,0,M.empty)+  th <- forkIO (run_midi (st_init_f v) st_recv_f)+  return (v,th)++{-+(st,th) <- st_run+st_chord st+readMVar st+st_read_note 55 st+st_read_cc 0 st+killThread th+-}

@@ -5,34 +5,75 @@ -- and calculate inter-onset times and durations.  There are variants -- for different graph constructors, and to allow for a -- post-processing stage.+--+-- Here the implementation of texture adds sumOut nodes at bus 0 to+-- the head of group 1, post-processing adds a replaceOut node at bus+-- 0 to the tail of group 1. module Sound.SC3.Lang.Control.OverlapTexture where -import Control.Applicative {- base -} import Data.List {- base -}+import Data.Hashable {- hashable -}+ import Sound.OSC {- hosc -} import Sound.SC3 {- hsc3 -} -import Sound.SC3.Lang.Control.Event-import Sound.SC3.Lang.Control.Instrument-import Sound.SC3.Lang.Pattern.ID+-- * Envelope +-- | Envelope defined by /sustain/ and /transition/ times.+type Env_ST n = (n,n)++-- | Location in node tree, given as (/group/,/bus/).+type Loc_GB = (Int,UGen)+ -- | Make an 'envGen' 'UGen' with 'envLinen'' structure with given--- /sustain/ and /transition/ times.-mk_env :: UGen -> UGen -> UGen-mk_env s t =+-- by 'Env_ST'.+mk_env :: Env_ST UGen -> UGen+mk_env (s,t) =     let c = EnvNum 4         p = envLinen' t s t 1 (c,c,c)     in envGen KR 1 1 0 1 RemoveSynth p --- | Apply 'mk_env' envelope to input signal and write to output bus @0@.-with_env_u :: UGen -> UGen -> UGen -> UGen-with_env_u g a = out 0 . (*) g . mk_env a+-- | Add multiplier stage and 'out' UGen writing to /bus/.+with_env_u :: UGen -> UGen -> Env_ST UGen -> UGen+with_env_u bus sig = out bus . (* sig) . mk_env  -- | Variant of 'with_env_u' where envelope parameters are lifted from -- 'Double' to 'UGen'.-with_env :: (Double,Double) -> UGen -> UGen-with_env (s,t) g = with_env_u g (constant s) (constant t)+with_env :: UGen -> Env_ST Double -> UGen -> UGen+with_env bus (s,t) sig = with_env_u bus sig (constant s,constant t) +gen_nm :: UGen -> String+gen_nm = show . hash . show++-- | Generate 'Synthdef', perhaps with envelope parameters for+-- 'with_env', and a continuous signal.+gen_synth :: UGen -> Maybe (Env_ST Double) -> UGen -> Synthdef+gen_synth bus k g =+  let g' = maybe (out bus g) (flip (with_env bus) g) k+  in synthdef (gen_nm g) g'++-- | Require envelope.+gen_synth' :: UGen -> Env_ST Double -> UGen -> Synthdef+gen_synth' bus k = gen_synth bus (Just k)++-- | Schedule 'Synthdef' at indicated intervals.  Synthdef is sent once at time zero.+nrt_sy1 :: Int -> Synthdef -> [Double] -> NRT+nrt_sy1 grp sy dur =+    let tm = dx_d' dur+        f t = bundle t [s_new0 (synthdefName sy) (-1) AddToHead grp]+    in NRT (bundle 0 [d_recv sy] : map f tm)++-- | Schedule 'Synthdef's at indicated intervals.  Synthdef is sent in+-- activation bundle.+nrt_sy :: Int -> [Synthdef] -> [Time] -> NRT+nrt_sy grp sy dur =+    let tm = dx_d' dur+        f t s = bundle t [d_recv s+                         ,s_new0 (synthdefName s) (-1) AddToHead grp]+    in NRT (zipWith f tm sy)++-- * Overlap texture+ -- | Control parameters for 'overlapTextureU' and related functions. -- Components are: 1. sustain time, 2. transition time, 3. number of -- overlaping (simultaneous) nodes and 4. number of nodes altogether.@@ -47,142 +88,148 @@  -- | Extract envelope parameters (sustain and transition times) for -- 'with_env' from 'OverlapTexture'.-overlapTexture_env :: OverlapTexture -> (Double,Double)+overlapTexture_env :: OverlapTexture -> Env_ST Double overlapTexture_env (s,t,_,_) = (s,t) --- | (/legato/,/duration/) parameters. The /duration/ is the--- inter-offset time, /legato/ is the scalar giving the sounding time--- in relation to the inter-offset time.-type Texture_DT = (Double,Double)+-- | Inter-offset time given 'OverlapTexture'.+--+-- > overlapTexture_iot (3,1,5,maxBound) == 1+overlapTexture_iot :: OverlapTexture -> Double+overlapTexture_iot (s,t,o,_) = (t + s + t) / o --- | Extract /legato/ (duration of sound proportional to inter-offset--- time) and /duration/ (inter-offset time) parameters from--- 'OverlapTexture'.+-- | Generate an 'NRT' score from 'OverlapTexture' control+-- parameters and a continuous signal.+overlapTexture_nrt :: Loc_GB -> OverlapTexture -> UGen -> NRT+overlapTexture_nrt (grp,bus) k g =+    let s = gen_synth' bus (overlapTexture_env k) g+        d = overlapTexture_iot k+        (_,_,_,c) = k+    in nrt_sy1 grp s (replicate c d)++-- | 'audition' of 'overlapTexture_nrt'. ----- > overlapTexture_dt (3,1,5,maxBound) == (5,1)-overlapTexture_dt :: OverlapTexture -> Texture_DT-overlapTexture_dt (s,t,o,_) = (o,(t + s + t) / o)+-- > import Sound.SC3.ID+-- > import Sound.SC3.Lang.Control.OverlapTexture+-- >+-- > let {o = sinOsc AR (rand 'α' 440 880) 0+-- >     ;u = pan2 o (rand 'β' (-1) 1) (rand 'γ' 0.1 0.2)}+-- > in overlapTextureU (3,1,6,9) u+overlapTextureU :: OverlapTexture -> UGen -> IO ()+overlapTextureU t = audition . overlapTexture_nrt (1,0) t +-- * XFade texture+ -- | Control parameters for 'xfadeTextureU' and related functions. -- Components are: 1. sustain time, 2. transition time, 3. number of--- nodes instatiated altogether.+-- nodes instantiated altogether. type XFadeTexture = (Double,Double,Int)  -- | Extract envelope parameters for 'with_env' from 'XFadeTexture'.-xfadeTexture_env :: XFadeTexture -> (Double,Double)+xfadeTexture_env :: XFadeTexture -> Env_ST Double xfadeTexture_env (s,t,_) = (s,t) --- | Extract /legato/ and /duration/ paramaters from 'XFadeTexture'.-xfadeTexture_dt :: XFadeTexture -> Texture_DT-xfadeTexture_dt (s,t,_) = let r = t + s in ((r + t) / r,r)---- | Generate 'Synthdef' from envelope parameters for 'with_env' and--- a continuous signal.-gen_synth :: (Double,Double) -> UGen -> Synthdef-gen_synth k g =-  let n = show (hashUGen g)-      g' = with_env k g-  in synthdef n g'+-- | Inter-offset time from 'XFadeTexture'.+xfadeTexture_iot :: XFadeTexture -> Double+xfadeTexture_iot (s,t,_) = s + t --- | Generate an /event/ pattern from 'OverlapTexture' control--- parameters and a continuous signal.-overlapTextureP :: OverlapTexture -> UGen -> P Event-overlapTextureP k g =-    let s = gen_synth (overlapTexture_env k) g-        (l,d) = overlapTexture_dt k-        (_,_,_,c) = k-    in pbind [(K_instr,pinstr' (Instr_Def s False))-             ,(K_dur,pn (return (F_Double d)) c)-             ,(K_legato,pure (F_Double l))]+-- | Generate an 'NRT' score from 'XFadeTexture' control parameters+-- and a continuous signal.+xfadeTexture_nrt :: Loc_GB -> XFadeTexture -> UGen -> NRT+xfadeTexture_nrt (grp,bus) k g =+    let s = gen_synth' bus (xfadeTexture_env k) g+        d = xfadeTexture_iot k+        (_,_,c) = k+    in nrt_sy1 grp s (replicate c d) --- | Audition pattern given by 'overlapTextureP'.+-- | 'audition' of 'xfadeTexture_nrt'. ----- > import Sound.SC3.ID--- > import Sound.SC3.Lang.Control.OverlapTexture--- > -- > let {o = sinOsc AR (rand 'α' 440 880) 0 -- >     ;u = pan2 o (rand 'β' (-1) 1) (rand 'γ' 0.1 0.2)}--- > in overlapTextureU (3,1,6,9) u-overlapTextureU :: OverlapTexture -> UGen -> IO ()-overlapTextureU k = audition . overlapTextureP k+-- > in xfadeTextureU (1,3,6) u+xfadeTextureU :: XFadeTexture -> UGen -> IO ()+xfadeTextureU t = audition . xfadeTexture_nrt (1,0) t +-- * Spawn texture++-- | Duration  a function of the iteration number.+type Spawn_Texture = (Int -> Double,Int)++-- | Generate an 'NRT' score from 'OverlapTexture' control parameters+-- and a continuous signal.+spawnTexture_nrt :: Loc_GB -> Spawn_Texture -> UGen -> NRT+spawnTexture_nrt (grp,bus) (t,c) g = nrt_sy1 grp (gen_synth bus Nothing g) (map t [0 .. c - 1])++-- | 'audition' 'spawnTexture_nrt'.+spawnTextureU :: Spawn_Texture -> UGen -> IO ()+spawnTextureU sp = audition . spawnTexture_nrt (1,0) sp++-- * Post-process++type PP_Bus = Either UGen (UGen,UGen)+ -- | Generate 'Synthdef' from a signal processing function over the--- indicated number of channels.-post_process_s :: Int -> (UGen -> UGen) -> Synthdef-post_process_s nc f =-    let i = in' nc AR 0-        u = replaceOut 0 (f i)-        nm = show (hashUGen u)-    in synthdef nm u+-- indicated number of channels.  If there is a single bus, writes+-- using 'replaceOut', else using 'out'.+post_process_s :: Int -> PP_Bus -> (UGen -> UGen) -> Synthdef+post_process_s nc b f =+    let (src,dst,wr) = case b of+                         Left b' -> (b',b',replaceOut)+                         Right (b',b'') -> (b',b'',out)+        i = in' nc AR src+        u = wr dst (f i)+    in synthdef (gen_nm u) u --- | Audition /event/ pattern with specified post-processing function.-post_process_a :: (Transport m) => P Event -> Int -> (UGen -> UGen) -> m ()-post_process_a p nc f = do-  let s = post_process_s nc f+-- | Run post-processing function.+post_process :: (Transport m) => Int -> PP_Bus -> Int -> (UGen -> UGen) -> m ()+post_process nc bus grp f = do+  let s = post_process_s nc bus f   _ <- async (d_recv s)-  send (s_new0 (synthdefName s) (-1) AddToTail 2)-  play p+  send (s_new0 (synthdefName s) (-1) AddToTail grp) +-- | Audition 'NRT' with specified post-processing function.+post_process_nrt :: (Transport m) => Loc_GB -> NRT -> Int -> (UGen -> UGen) -> m ()+post_process_nrt (grp,bus) sc nc f = post_process nc (Left bus) grp f >> play sc+ -- | Post processing function. type PPF = (UGen -> UGen)  -- | Variant of 'overlapTextureU' with post-processing stage. overlapTextureU_pp :: OverlapTexture -> UGen -> Int -> PPF -> IO () overlapTextureU_pp k u nc f = do-  let p = overlapTextureP k u-  withSC3 (post_process_a p nc f)---- | Generate an /event/ pattern from 'XFadeTexture' control--- parameters and a continuous signal.-xfadeTextureP :: XFadeTexture -> UGen -> P Event-xfadeTextureP k g =-    let s = gen_synth (xfadeTexture_env k) g-        (l,d) = xfadeTexture_dt k-        (_,_,c) = k-    in pbind [(K_instr,pinstr' (Instr_Def s False))-             ,(K_dur,pn (return (F_Double d)) c)-             ,(K_legato,pure (F_Double l))]---- | Audition pattern given by 'xfadeTextureP'.------ > let {o = sinOsc AR (rand 'α' 440 880) 0--- >     ;u = pan2 o (rand 'β' (-1) 1) (rand 'γ' 0.1 0.2)}--- > in xfadeTextureU (1,3,6) u-xfadeTextureU :: XFadeTexture -> UGen -> IO ()-xfadeTextureU k = audition . xfadeTextureP k+  let p = overlapTexture_nrt (1,0) k u+  withSC3 (post_process_nrt (1,0) p nc f)  -- | Variant of 'xfadeTextureU' with post-processing stage. xfadeTextureU_pp :: XFadeTexture -> UGen -> Int -> PPF -> IO () xfadeTextureU_pp k u nc f = do-  let p = xfadeTextureP k u-  withSC3 (post_process_a p nc f)+  let p = xfadeTexture_nrt (1,0) k u+  withSC3 (post_process_nrt (1,0) p nc f) +-- * State+ -- | UGen generating state transform function. type USTF st = (st -> (UGen,st)) --- | Variant of 'overlapTextureP' where the continuous signal for each+-- | Variant of 'overlapTexture_nrt' where the continuous signal for each -- /event/ is derived from a state transform function seeded with -- given initial state.-overlapTextureP_st :: OverlapTexture -> USTF st -> st -> P Event-overlapTextureP_st k u i_st =-    let (l,d) = overlapTexture_dt k+overlapTexture_nrt_st :: Loc_GB -> OverlapTexture -> USTF st -> st -> NRT+overlapTexture_nrt_st (grp,bus) k u i_st =+    let d = overlapTexture_iot k         (_,_,_,c) = k         g = take c (unfoldr (Just . u) i_st)-        i = flip Instr_Def False-        s = toP (map (i . gen_synth (overlapTexture_env k)) g)-    in pbind [(K_instr,fmap F_Instr s)-             ,(K_dur,pure (F_Double d))-             ,(K_legato,pure (F_Double l))]+        s = map (gen_synth' bus (overlapTexture_env k)) g+    in nrt_sy grp s (replicate c d) --- | Audition pattern given by 'overlapTextureP_st'.+-- | 'audition' of 'overlapTexture_nrt_st'. overlapTextureS :: OverlapTexture -> USTF st -> st -> IO ()-overlapTextureS k u = audition . overlapTextureP_st k u+overlapTextureS t f = audition . overlapTexture_nrt_st (1,0) t f  -- | Variant of 'overlapTextureS' with post-processing stage. overlapTextureS_pp :: OverlapTexture -> USTF st -> st -> Int -> PPF  -> IO () overlapTextureS_pp k u i_st nc f = do-  let p = overlapTextureP_st k u i_st-  withSC3 (post_process_a p nc f)+  let sc = overlapTexture_nrt_st (1,0) k u i_st+  withSC3 (post_process_nrt (1,0) sc nc f)  -- | Monadic state transform function. type MSTF st m = (st -> m (Maybe st))@@ -192,23 +239,23 @@ -- the function. dt_rescheduler_m :: MonadIO m => MSTF (st,Time) m -> (st,Time) -> m () dt_rescheduler_m f =-    let rec (st,t) = do+    let recur (st,t) = do           pauseThreadUntil t           r <- f (st,t)           case r of-            Just (st',dt) -> rec (st',t + dt)+            Just (st',dt) -> recur (st',t + dt)             Nothing -> return ()-    in rec+    in recur  -- | Underlying function of 'overlapTextureM' with explicit 'Transport'. overlapTextureR :: Transport m =>                    OverlapTexture -> IO UGen -> MSTF (Int,Time) m overlapTextureR k uf =   let nm = "ot_" ++ show k-      (_,dt) = overlapTexture_dt k+      dt = overlapTexture_iot k   in \(st,_) -> do         u <- liftIO uf-        let g = with_env (overlapTexture_env k) u+        let g = with_env 0 (overlapTexture_env k) u         _ <- async (d_recv (synthdef nm g))         send (s_new0 nm (-1) AddToTail 1)         case st of

@@ -67,7 +67,7 @@                    ,scale :: [Double]                    ,degree :: Double                    ,stepsPerOctave :: Double-                   ,detune :: Double+                   ,detune :: Double -- Hz                    ,harmonic :: Double                    ,freq' :: Maybe Double                    ,midinote' :: Maybe Double

@@ -0,0 +1,139 @@+-- | Core (shared) functions.+module Sound.SC3.Lang.Core where++import Data.Maybe {- base -}+import Data.Monoid {- base -}++-- * "Data.Function" variants++-- | 'fmap' '.' 'fmap', ie. @(t -> c) -> (a -> b -> t) -> a -> b -> c@.+(.:) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)+(.:) = fmap . fmap++-- | 'fmap' '.' '.:', ie. @(t -> d) -> (a -> b -> c -> t) -> a -> b -> c -> d@.+(.::) :: (Functor f, Functor g, Functor h) => (a -> b) -> f (g (h a)) -> f (g (h b))+(.::) = fmap . (.:)++-- | 'fmap' '.' '.::'.+(.:::) :: (Functor f, Functor g, Functor h,Functor i) => (a -> b) -> f (g (h (i a))) -> f (g (h (i b)))+(.:::) = fmap . (.::)++-- | 'fmap' '.' '.:::'.+(.::::) :: (Functor f, Functor g, Functor h,Functor i,Functor j) => (a -> b) -> f (g (h (i (j a)))) -> f (g (h (i (j b))))+(.::::) = fmap . (.:::)++-- | 'fmap' '.' '.::::'.+(.:::::) :: (Functor f, Functor g, Functor h,Functor i,Functor j,Functor k) => (a -> b) -> f (g (h (i (j (k a))))) -> f (g (h (i (j (k b)))))+(.:::::) = fmap . (.::::)++-- * "Data.List" variants++-- | Variant that either takes precisely /n/ elements or 'Nothing'.+--+-- > map (genericTake 3) (inits "abc") == inits "abc"+-- > Data.Maybe.mapMaybe (genericTakeMaybe 3) (inits "abc") == ["abc"]+genericTakeMaybe :: Integral i => i -> [a] -> Maybe [a]+genericTakeMaybe n l =+    case compare n 0 of+      LT -> Nothing+      EQ -> Just []+      GT -> case l of+              [] -> Nothing+              e : l' -> fmap (e :) (genericTakeMaybe (n - 1) l')++-- | Inverse of 'Data.List.:'.+--+-- > map uncons [[],1:[]] == [(Nothing,[]),(Just 1,[])]+uncons :: [a] -> (Maybe a,[a])+uncons l =+    case l of+      [] -> (Nothing,[])+      x:l' -> (Just x,l')++-- | 'Maybe' variant of '!!'.+--+-- > map (lindex "str") [2,3] == [Just 'r',Nothing]+lindex :: [a] -> Int -> Maybe a+lindex l n =+    if n < 0+    then Nothing+    else case (l,n) of+           ([],_) -> Nothing+           (x:_,0) -> Just x+           (_:l',_) -> lindex l' (n - 1)++-- | If /n/ is 'maxBound' this is 'id', else it is 'take'.+take_inf :: Int -> [a] -> [a]+take_inf n = if n == maxBound then id else take n++-- | Variant of 'transpose' for /fixed width/ interior lists.  Holes+-- are represented by 'Nothing'.+--+-- > transpose_fw undefined [] == []+--+-- > transpose [[1,3],[2,4]] == [[1,2],[3,4]]+-- > transpose_fw 2 [[1,3],[2,4]] == [[Just 1,Just 2],[Just 3,Just 4]]+--+-- > transpose [[1,5],[2],[3,7]] == [[1,2,3],[5,7]]+--+-- > transpose_fw 2 [[1,4],[2],[3,6]] == [[Just 1,Just 2,Just 3]+-- >                                     ,[Just 4,Nothing,Just 6]]+--+-- This function is more productive than 'transpose' for the case of+-- an infinite list of finite lists.+--+-- > map head (transpose_fw 4 (repeat [1..4])) == map Just [1,2,3,4]+-- > map head (transpose (repeat [1..4])) == _|_+transpose_fw :: Int -> [[a]] -> [[Maybe a]]+transpose_fw w l =+    if null l+    then []+    else let f n = map (`lindex` n) l+         in map f [0 .. w - 1]++-- | Variant of 'transpose_fw' with default value for holes.+transpose_fw_def :: a -> Int -> [[a]] -> [[a]]+transpose_fw_def def w l =+    let f n = map (fromMaybe def . (`lindex` n)) l+    in map f [0 .. w - 1]++-- | Variant of 'transpose_fw_def' deriving /width/ from first element.+transpose_fw_def' :: a -> [[a]] -> [[a]]+transpose_fw_def' def l =+    case l of+      [] -> []+      h:_ -> transpose_fw_def def (length h) l++-- | A 'transpose' variant, halting when first hole appears.+--+-- > transpose_st [[1,2,3],[4,5,6],[7,8]] == [[1,4,7],[2,5,8]]+transpose_st :: [[a]] -> [[a]]+transpose_st l =+    let (h,l') = unzip (map uncons l)+    in case all_just h of+         Just h' -> h' : transpose_st l'+         Nothing -> []++-- * Data.Maybe variants++-- | Variant of 'catMaybes' that returns 'Nothing' unless /all/+-- elements are 'Just'.+--+-- > map all_just [[Nothing,Just 1],[Just 0,Just 1]] == [Nothing,Just [0,1]]+all_just :: [Maybe a] -> Maybe [a]+all_just =+    let rec r l =+            case l of+              [] -> Just (reverse r)+              Nothing:_ -> Nothing+              Just e:l' -> rec (e:r) l'+    in rec []++-- * Data.Monoid variants++-- | 'mconcat' of 'repeat', for lists this is 'cycle'.+--+-- > [1,2,3,1,2] `isPrefixOf` take 5 (mcycle [1,2,3])+mcycle :: Monoid a => a -> a+mcycle = mconcat . repeat+

@@ -0,0 +1,239 @@+-- | Arpabet phoneme definitions and CMU dictionary functions.+--+-- <http://www.speech.cs.cmu.edu/cgi-bin/cmudict>+-- <http://en.wikipedia.org/wiki/Arpabet>+module Sound.SC3.Lang.Data.CMUdict where++import Data.Char {- base -}+import Data.Maybe {- base -}+import Data.List {- base -}+import Data.List.Split {- split -}+import qualified Data.Map as M {- containers -}++-- | Stress indicators, placed at the stressed syllabic vowel.+data Stress = No_stress | Primary_stress | Secondary_stress+            deriving (Eq,Ord,Enum,Bounded,Read,Show)++-- | Arpabet phonemes as used at CMU dictionary.+--+-- > [AO .. NX] == [minBound .. maxBound]+-- > length [AO .. NX] == 48+data Phoneme+    -- Vowels (Monophthongs)+    = AO | AA | IY | UW | EH | IH | UH | AH | AX | AE+    -- Vowels (Diphthongs)+    | EY | AY | OW | AW | OY+    -- Vowels (R-colored)+    | ER | AXR+    -- Semivowels+    | Y | W | Q+    -- Consonants (Stops)+    | P | B | T | D | K | G+    -- Consonants (Affricates)+    | CH | JH+    -- Consonants (Fricatives)+    | F | V | TH | DH | S | Z | SH | ZH+    -- Consonants (Aspirate)+    | HH+    -- Nasals+    | M | EM | N | EN | NG | ENG+    -- Liquids+    | L | EL | R | DX | NX+      deriving (Eq,Ord,Enum,Bounded,Read,Show)++-- | 'Phoneme' with 'Stress', if given.+type Phoneme_str = (Phoneme,Maybe Stress)++-- | There is a variant CMU dictionary with syllable marks.+-- <http://webdocs.cs.ualberta.ca/~kondrak/cmudict.html>+type SYLLABLE = [Phoneme_str]++-- | An ARPABET word.+type ARPABET = [Phoneme_str]++-- | An ARPABET word, with syllables.+type ARPABET_syl = [SYLLABLE]++-- | Parameterised CMU dictionary.+type CMU_Dict_ty a = M.Map String a++-- | The CMU dictionary.+type CMU_Dict = CMU_Dict_ty ARPABET++-- | The syllabic CMU dictionary.+type CMU_Dict_syl = CMU_Dict_ty ARPABET_syl++-- | Parse 'Phoneme_str'+--+-- > parse_phoneme_str "EY1" == (EY,Just Primary_stress)+-- > parse_phoneme_str "R" == (R,Nothing)+parse_phoneme_str :: String -> Phoneme_str+parse_phoneme_str w =+    case reverse w of+      '0':w' -> (read (reverse w'),Just No_stress)+      '1':w' -> (read (reverse w'),Just Primary_stress)+      '2':w' -> (read (reverse w'),Just Secondary_stress)+      _ -> (read w,Nothing)++parse_arpabet :: String -> (String,ARPABET)+parse_arpabet e =+    case words e of+      w:p -> (w,map parse_phoneme_str p)+      _ -> error "parse_arpabet"++parse_arpabet_syl :: String -> (String,ARPABET_syl)+parse_arpabet_syl e =+    case words e of+      w:p -> let p' = wordsBy (== "-") p+             in (w,map (map parse_phoneme_str) p')+      _ -> error "parse_arpabet_syl"++-- | Classification of 'Phoneme's.+data Phoneme_Class = Monophthong | Diphthong | R_Coloured+                   | Semivowel+                   | Stop | Affricate | Fricative | Aspirate+                   | Nasal+                   | Liquid+                     deriving (Eq,Ord,Enum,Bounded,Read,Show)++-- | Classification table for 'Phoneme'.+arpabet_classification_table :: [(Phoneme_Class,[Phoneme])]+arpabet_classification_table =+    [(Monophthong,[AO,AA,IY,UW,EH,IH,UH,AH,AX,AE])+    ,(Diphthong,[EY,AY,OW,AW,OY])+    ,(R_Coloured,[ER,AXR])+    ,(Semivowel,[Y,W,Q])+    ,(Stop,[P,B,T,D,K,G])+    ,(Affricate,[CH,JH])+    ,(Fricative,[F,V,TH,DH,S,Z,SH,ZH])+    ,(Aspirate,[HH])+    ,(Nasal,[M,EM,N,EN,NG,ENG])+    ,(Liquid,[L,EL,R,DX,NX])]++-- | Consult 'arpabet_classification_table'.+--+-- > arpabet_classification HH == Aspirate+-- > map arpabet_classification [minBound .. maxBound]+arpabet_classification :: Phoneme -> Phoneme_Class+arpabet_classification p =+    let f (_,l) = p `elem` l+    in fromMaybe (error "arpabet_classification") $+       fmap fst $+       find f arpabet_classification_table++cmudict_load_ty :: (String -> (String,a)) -> FilePath -> IO (CMU_Dict_ty a)+cmudict_load_ty pf fn = do+  s <- readFile fn+  let is_comment w = case w of {';':_ -> True;_ -> False}+      l = filter (not . is_comment) (lines s)+  return (M.fromList (map pf l))++-- | Load CMU dictionary from file.+--+-- > d <- cmudict_load "/home/rohan/data/cmudict/cmudict.0.7a"+-- > M.size d == 133313+cmudict_load :: FilePath -> IO CMU_Dict+cmudict_load = cmudict_load_ty parse_arpabet++-- | Load syllable CMU dictionary from file.+--+-- > d <- cmudict_syl_load "/home/rohan/data/cmudict/cmudict.0.6d.syl"+-- > M.size d == 129463+cmudict_syl_load :: FilePath -> IO CMU_Dict_syl+cmudict_syl_load = cmudict_load_ty parse_arpabet_syl++-- | Dictionary lookup.+--+-- > let r = [(R,Nothing),(EY,Just Primary_stress)+-- >         ,(N,Nothing),(ER,Just No_stress),(D,Nothing)]+-- > in d_lookup d "reynard" == Just r+d_lookup :: CMU_Dict_ty a -> String -> Maybe a+d_lookup d w = M.lookup (map toUpper w) d++-- | Variant that retains query string if not in dictionary.+d_lookup' :: CMU_Dict_ty a -> String -> Either String a+d_lookup' d w = maybe (Left w) Right (d_lookup d w)++-- * IPA++-- | Table mapping /Arpabet/ phonemes to /IPA/ strings.+--+-- > length arpabet_ipa_table == 48+arpabet_ipa_table :: [(Phoneme,Either String [(Stress,String)])]+arpabet_ipa_table =+    -- Vowels (Monophthongs)+    [(AO,Left "ɔ")+    ,(AA,Left "ɑ")+    ,(IY,Left "i")+    ,(UW,Left "u")+    ,(EH,Left "ɛ")+    ,(IH,Left "ɪ")+    ,(UH,Left "ʊ")+    ,(AH,Right [(Primary_stress,"ʌ"),(No_stress,"ə")])+    ,(AX,Left "ə")+    ,(AE,Left "æ")+    -- Vowels (Diphthongs)+    ,(EY,Left "eɪ")+    ,(AY,Left "aɪ")+    ,(OW,Left "oʊ")+    ,(AW,Left "aʊ")+    ,(OY,Left "ɔɪ")+    -- Vowels (R-colored)+    ,(ER,Left "ɝ")+    ,(AXR,Left "ɚ")+    -- Semivowels+    ,(Y,Left "j")+    ,(W,Left "w")+    ,(Q,Left "ʔ")+    -- Consonants (Stops)+    ,(P,Left "p")+    ,(B,Left "b")+    ,(T,Left "t")+    ,(D,Left "d")+    ,(K,Left "k")+    ,(G,Left "ɡ")+    -- Consonants (Affricates)+    ,(CH,Left "tʃ")+    ,(JH,Left "dʒ")+    -- Consonants (Fricatives)+    ,(F,Left "f")+    ,(V,Left "v")+    ,(TH,Left "θ")+    ,(DH,Left "ð")+    ,(S,Left "s")+    ,(Z,Left "z")+    ,(SH,Left "ʃ")+    ,(ZH,Left "ʒ")+    -- Consonants (Aspirate)+    ,(HH,Left "h")+    -- Nasals+    ,(M,Left "m")+    ,(EM,Left "m̩")+    ,(N,Left "n")+    ,(EN,Left "n̩")+    ,(NG,Left "ŋ")+    ,(ENG,Left "ŋ̍")+    -- Liquids+    ,(L,Left "ɫ")+    ,(EL,Left "ɫ̩")+    ,(R,Left "ɹ")+    ,(DX,Left "ɾ")+    ,(NX,Left "ɾ̃")+    ]++-- | Consult 'arpabet_ipa_table'.+--+-- > map (phoneme_ipa (Just Primary_stress)) [minBound .. maxBound]+phoneme_ipa :: Maybe Stress -> Phoneme -> String+phoneme_ipa s =+    either id (fromMaybe (error (show ("phoneme_ipa: no stressed phoneme",s))) .+               lookup (fromMaybe (error "phoneme_ipa: no stress") s)) .+    fromMaybe (error "phoneme_ipa: no phoneme") .+    flip lookup arpabet_ipa_table++-- | Consult 'arpabet_ipa_table'.+--+-- > let r = map parse_phoneme_str (words "R EY1 N ER0 D")+-- > in arpabet_ipa r == "ɹeɪnɝd"+arpabet_ipa :: ARPABET -> String+arpabet_ipa = concatMap (\(p,s) -> phoneme_ipa s p)

@@ -28,7 +28,7 @@ -- > > (0..5).collect({|i| i.degreeToKey([0,1,5,9,11],12)}) == [0,1,5,9,11,12] -- > map (degreeToKey [0,1,5,9,11] 12) [0..5] == [0,1,5,9,11,12] ----- > degreeToKey [0,2,4,5,7,9,11] 12 5 == 9+-- > map (degreeToKey [0,2,4,5,7,9,11] 12) [5,6,7,8] == [9,11,12,14] degreeToKey :: (RealFrac a) => [a] -> a -> a -> a degreeToKey s n d =     let l = length s@@ -64,6 +64,9 @@ log10 :: Floating a => a -> a log10 = logBase 10 +octpc_to_midi :: Num a => (a,a) -> a+octpc_to_midi (o,pc) = 60 + ((o - 4) * 12) + pc+ -- | @SimpleNumber.midicps@ translates from midi note number to cycles -- per second. --@@ -71,6 +74,20 @@ -- > map midicps [57,69] == [220,440] midicps :: (Floating a) => a -> a midicps a = 440.0 * (2.0 ** ((a - 69.0) * (1.0 / 12.0)))++-- | 'midicps' of 'octpc_to_midi'.+octpc_to_cps :: (Floating a) => (a,a) -> a+octpc_to_cps = midicps . octpc_to_midi++-- | 'octpc_to_cps' of 'degreeToKey'.+degree_to_cps :: (Floating a, RealFrac a) => [a] -> a -> a -> a -> a+degree_to_cps sc n d o =+    let pc = degreeToKey sc n d+    in octpc_to_cps (o,pc)++-- | Variant with list inputs for degree and octave, and scalar inputs for scale and steps.+degree_to_cps' :: (Floating a, RealFrac a) => [a] -> a -> [a] -> [a] -> [a]+degree_to_cps' sc n = zipWith (degree_to_cps sc n)  -- * UGen 

@@ -2,6 +2,9 @@ -- space /[l,r]/. module Sound.SC3.Lang.Math.Warp where +import Numeric {- base -}+import Sound.SC3.UGen.Math {- hsc3 -}+ import Sound.SC3.Lang.Math  -- | Warp direction.  'W_Map' is forward, 'W_Unmap' is reverse.@@ -39,6 +42,9 @@ -- > > [0,0.5,1].collect{|n| w.map(n)} == [1,pow(2,0.5),2] -- -- > map (warpExponential 1 2 W_Map) [0,0.5,1] == [1,2 ** 0.5,2]+--+-- > import Sound.SC3.Plot+-- > plotTable1 (map (warpExponential 1 2 W_Map) [0,0.01 .. 1]) warpExponential :: (Floating a) => a -> a -> Warp a warpExponential l r d n =     let z = r / l@@ -52,6 +58,8 @@ -- > > [0,0.25,0.5,0.75,1].collect{|n| w.map(n)} -- -- > map (warpCosine 1 2 W_Map) [0,0.25,0.5,0.75,1]+--+-- > plotTable1 (map (warpCosine 1 2 W_Map) [0,0.01 .. 1]) warpCosine :: (Floating a) => a -> a -> Warp a warpCosine l r d n =     let w = warpLinear 0 (r - l) d@@ -62,6 +70,8 @@ -- | Sine warp -- -- > map (warpSine 1 2 W_Map) [0,0.25,0.5,0.75,1]+--+-- > plotTable1 (map (warpSine 1 2 W_Map) [0,0.01 .. 1]) warpSine :: (Floating a) => a -> a -> Warp a warpSine l r d n =     let w = warpLinear 0 (r - l) d@@ -69,26 +79,38 @@        then w (sin (pi * 0.5 * n))        else asin (w n) / (pi / 2) --- | Fader warp.  Left and right values are implicitly zero and one.+-- | Fader warp.  Left and right values are ordinarily zero and one. ----- > map (warpFader W_Map) [0,0.5,1] == [0,0.25,1]-warpFader :: Floating a => Warp a-warpFader d n = if d == W_Map then n * n else sqrt n+-- > map (warpFader 0 1 W_Map) [0,0.5,1] == [0,0.25,1]+--+-- > plotTable1 (map (warpFader 0 1 W_Map) [0,0.01 .. 1])+-- > plotTable1 (map (warpFader 0 2 W_Map) [0,0.01 .. 1])+warpFader :: Floating a => a -> a -> Warp a+warpFader l r d n =+    let n' = if d == W_Map then n * n else sqrt n+    in warpLinear l r d n' --- | DB fader warp. Left and right values are implicitly negative+-- | DB fader warp. Left and right values are ordinarily negative -- infinity and zero.  An input of @0@ gives @-180@. -- -- > map (round . warpDbFader W_Map) [0,0.5,1] == [-180,-12,0]-warpDbFader :: (Eq a,Floating a) => Warp a-warpDbFader d n =+--+-- > plotTable1 (map (warpDbFader (-60) 0 W_Map) [0,0.01 .. 1])+-- > plotTable1 (map (warpDbFader 0 60 W_Unmap) [0 .. 60])+warpDbFader :: (TernaryOp a,Eq a,Floating a) => a -> a -> Warp a+warpDbFader l r d n =     if d == W_Map-    then if n == 0 then -180 else ampdb (n * n)-    else sqrt (dbamp n)+    then let n' = if n == 0 then -180 else ampdb (n * n)+         in linlin n' (-180) 0 l r+    else sqrt (dbamp (linlin n l r (-180) 0))  -- | A curve warp given by a real /n/. -- -- > w_map (warpCurve (-3) 1 2) 0.25 == 1.5552791692202022 -- > w_map (warpCurve (-3) 1 2) 0.50 == 1.8175744761936437+--+-- > plotTable1 (map (warpCurve (-3) 1 2 W_Map) [0,0.01 .. 1])+-- > plotTable1 (map (warpCurve 9 1 2 W_Map) [0,0.01 .. 1]) warpCurve :: (Ord a,Floating a) => a -> a -> a -> Warp a warpCurve k l r d n =     let e = exp k@@ -99,3 +121,25 @@        else if d == W_Map             then b - ((e ** n) * a)             else log ((b - n) / a) / k++-- | Select warp function by name.  Numerical names are interpreted as+-- /curve/ values for 'warpCurve'.+--+-- > let Just w = warpNamed "lin"+-- > let Just w = warpNamed "-3"+-- > let Just w = warpNamed "6"+-- > plotTable1 (map (w 1 2 W_Map) [0,0.01 .. 1])+warpNamed :: (TernaryOp a,Ord a,Eq a,RealFrac a,Floating a) =>+             String -> Maybe (a -> a -> Warp a)+warpNamed nm =+    case nm of+      "lin" -> Just warpLinear+      "exp" -> Just warpExponential+      "sin" -> Just warpSine+      "cos" -> Just warpCosine+      "amp" -> Just warpFader+      "db" -> Just warpDbFader+      _ -> case readSigned readFloat nm of+             [(c,"")] -> Just (warpCurve c)+             _ -> Nothing+

@@ -6,4 +6,6 @@ import Sound.SC3.Lang.Control.Instrument as P import Sound.SC3.Lang.Control.Pitch as P import Sound.SC3.Lang.Control.OverlapTexture as P-import Sound.SC3.Lang.Pattern.ID as P++import Sound.SC3.Lang.Pattern.P as P+import Sound.SC3.Lang.Pattern.P.Event as P

@@ -0,0 +1,94 @@+-- | Minimal functions for binding values to parameter names and sending to scsynth.+module Sound.SC3.Lang.Pattern.Bind where++import Data.List {- base -}+import qualified Data.List.Ordered as O {- data-ordlist -}+import Data.Maybe {- base -}++import Sound.OSC {- hosc -}+import Sound.SC3 {- hsc3 -}++import qualified Sound.SC3.Lang.Core as L {- hsc3-lang -}++type Param = [(String,[Double])]++pr_unused :: Synthdef -> Param -> [String]+pr_unused sy pr = (map fst pr \\ synthdefParam sy) \\ ["dur","sustain"]++-- * Synthdef bind++sbind_init :: Int -> [Synthdef] -> [Bundle]+sbind_init grp sy =+    let sy_b = bundle 0 (map d_recv sy)+        grp_b = bundle 0 [g_new [(grp,AddToHead,0)]]+    in [sy_b,grp_b]++sbind_tseq :: Int -> [Int] -> (Synthdef,[Time],Maybe [Time],Param) -> [Bundle]+sbind_tseq grp nid (sy,tm,sus,pr) =+    let sy_pr = synthdefParam sy+        has_gate = "gate" `elem` sy_pr+        nd (t,k,ar) = let nm = synthdefName sy+                      in bundle t [s_new nm k AddToHead grp ar]+        pr' = let f (p,l) = zip (repeat p) l+              in L.transpose_st (map f pr)+        gt = if has_gate+             then let sus' = fromMaybe (d_dx' tm) sus+                      -- pr' may be finite, zipped here to halt if required...+                      f (t,g,k,_) = bundle (t + g) [n_set1 k "gate" 0]+                  in map f (zip4 tm sus' nid pr')+             else if isNothing sus || "sustain" `elem` sy_pr+                  then []+                  else error ("sbind_tseq: sus given but no gate parameter")+    in case pr_unused sy pr of+         [] -> O.merge (map nd (zip3 tm nid pr')) gt+         u -> error (show ("sbind_tseq: unused parameters",u))++sbind_deriv :: Int -> [Int] -> (Synthdef,Param) -> [Bundle]+sbind_deriv grp nid (sy,pr) =+    let dur = fromMaybe (error "sbind_deriv: no dur parameter") (lookup "dur" pr)+        sus = lookup "sustain" pr+        tm = dx_d' dur+    in sbind_tseq grp nid (sy,tm,sus,pr)++sbind :: [(Synthdef,Param)] -> NRT+sbind set =+    let grp = 1+        nid = map (\n -> [n..]) [1000,6000 ..]+    in NRT (sbind_init grp (map fst set) ++ foldl1 O.merge (zipWith (sbind_deriv grp) nid set))++sbind1 :: (Synthdef,Param) -> NRT+sbind1 = sbind . return++-- * Node bind++nbind_init :: Int -> [(Synthdef,Int,Param)] -> [Bundle]+nbind_init grp m =+    let (sy,nid,_) = unzip3 m+        sy_b = bundle 0 (map d_recv sy)+        grp_b = bundle 0 [g_new [(grp,AddToHead,0)]]+        nd_b = bundle 0 (map (\(s,k) -> s_new (synthdefName s) k AddToHead grp []) (zip sy nid))+    in [sy_b,grp_b,nd_b]++nbind_tseq :: (Synthdef,Int,[Time],Param) -> [Bundle]+nbind_tseq (sy,nid,tm,pr) =+    let m (t,k,ar) = bundle t [n_set k ar]+        pr' = let f (p,l) = zip (repeat p) l+              in L.transpose_st (map f pr)+    in case pr_unused sy pr of+         [] -> map m (zip3 tm (repeat nid) pr')+         u -> error (show ("nbind_tseq: unused parameters",u))++nbind_deriv :: (Synthdef,Int,Param) -> [Bundle]+nbind_deriv (sy,k,pr) =+    let dur = fromMaybe (error "nbind_deriv: no dur parameter") (lookup "dur" pr)+        tm = dx_d' dur+    in nbind_tseq (sy,k,tm,pr)++nbind :: [(Synthdef,Int,Param)] -> NRT+nbind set =+    let grp = 1+        set' = map nbind_deriv set+    in NRT (nbind_init grp set ++ foldl1 O.merge set')++nbind1 :: (Synthdef,Int,Param) -> NRT+nbind1 = nbind . return

@@ -1,1960 +0,0 @@-{-# Language FlexibleInstances #-}--- | @sclang@ pattern library functions.--- See <http://rd.slavepianos.org/?t=hsc3-texts> for tutorial.------ SC3 /value/ patterns: `pbrown` (Pbrown), `pclutch` (Pclutch),--- `pcollect` (Pcollect), `pconst` (Pconst), `pdegreeToKey`--- (PdegreeToKey), `pdiff` (Pdiff), `pdrop` (Pdrop), `pdurStutter`--- (PdurStutter), `pexprand` (Pexprand), `pfinval` (Pfinval), `pfuncn`--- (Pfuncn), `pgeom` (Pgeom), `pif` (Pif), `place` (Place), `pn` (Pn),--- `ppatlace` (Ppatlace), `prand` (Prand), `preject` (Preject),--- `prorate` (Prorate), `pselect` (Pselect), `pseq` (Pseq), `pser`--- (Pser), `pseries` (Pseries), `pshuf` (Pshuf), `pslide` (Pslide),--- `pstutter` (Pstutter), `pswitch1` (Pswitch1), `pswitch` (Pswitch),--- `ptuple` (Ptuple), `pwhite` (Pwhite), `pwrand` (Pwrand), `pwrap`--- (Pwrap), `pxrand` (Pxrand).------ SC3 /event/ patterns: `padd` (Padd), `pbind` (Pbind), `pkey`--- (PKey), `pmono` (Pmono), `pmul` (Pmul), `ppar` (Ppar), `pstretch`--- (Pstretch), `ptpar` (Ptpar).  `pedit`, `pinstr`, `pmce2`, `psynth`,--- `punion`.------ SC3 variant patterns: `pbrown`', `prand'`, `prorate'`, `pseq1`,--- `pseqn`, `pser1`, `pseqr`, `pwhite'`, `pwhitei`.------ SC3 collection patterns: `pfold`------ Haskell patterns: `pappend`, `pbool`, `pconcat`, `pcons`,--- `pcountpost`, `pcountpre`, `pcycle`, `pempty`,`pfilter`, `phold`,--- `pinterleave`,`pjoin`, `prepeat`, `preplicate`, `prsd`, `pscanl`,--- `psplitPlaces`, `psplitPlaces'`, `ptail`, `ptake`, `ptrigger`,--- `pzip`, `pzipWith`-module Sound.SC3.Lang.Pattern.ID where--import Control.Applicative hiding ((<*)) {- base -}-import Control.Monad {- base -}-import Data.Bifunctor {- bifunctors -}-import qualified Data.Foldable as F {- base -}-import qualified Data.List as L {- base -}-import qualified Data.List.Split as S {- split -}-import Data.Maybe {- base -}-import Data.Monoid {- base -}-import qualified Data.Traversable as T {- base -}-import Sound.OSC {- hsc3 -}-import Sound.SC3 {- hsc3 -}-import System.Random {- random -}--import qualified Sound.SC3.Lang.Collection as C-import Sound.SC3.Lang.Control.Duration-import Sound.SC3.Lang.Control.Event-import Sound.SC3.Lang.Control.Instrument-import qualified Sound.SC3.Lang.Math as M-import qualified Sound.SC3.Lang.Pattern.List as P-import qualified Sound.SC3.Lang.Random.Gen as R---- * P---- | Patterns are opaque.  @P a@ is a pattern with elements of type--- @a@.  Patterns are constructed, manipulated and destructured using--- the functions provided, ie. the pattern instances for 'return',--- 'pure' and 'F.toList', and the pattern specific functions--- 'undecided' and 'toP'.------ > F.toList (toP [1,2,3] * 2) == [2,4,6]------ Patterns are 'Functor's.  'fmap' applies a function to each element--- of a pattern.------ > fmap (* 2) (toP [1,2,3,4,5]) == toP [2,4,6,8,10]------ Patterns are 'Monoid's.  'mempty' is the empty pattern, and--- 'mappend' ('<>') makes a sequence of two patterns.------ > 1 <> mempty <> 2 == toP [1,2]------ Patterns are 'Applicative'.  The pattern instance is pointwise &--- truncating, unlike the combinatorial instance for ordinary lists.--- 'pure' lifts a value into an infinite pattern of itself, '<*>'--- applies a pattern of functions to a pattern of values.  This is--- distinct from the list instance which is monadic, ie. 'pure' is--- 'return' and '<*>' is 'ap'.------ > liftA2 (+) (toP [1,2]) (toP [3,4,5]) == toP [4,6]--- > liftA2 (+) [1,2] [3,4,5] == [4,5,6,5,6,7]------ Patterns are 'Monad's, and therefore allow /do/ notation.------ > let p = do {x <- toP [1,2]; y <- toP [3,4,5]; return (x,y)}--- > in p == toP [(1,3),(1,4),(1,5),(2,3),(2,4),(2,5)]------ Patterns are 'Num'erical.  The instances can be derived from the--- 'Applicative' instance.------ > 1 + toP [2,3,4] == liftA2 (+) 1 (toP [2,3,4])-data P a = P {unP_either :: Either a [a]}-           deriving (Eq,Show)---- | Lift a value to a pattern deferring deciding if the constructor--- ought to be 'pure' or 'return' to the consuming function.  The--- pattern instances for 'fromInteger' and 'fromRational' make--- 'undecided' patterns.  In general /horizontal/ functions (ie. '<>')--- resolve using 'return' and /vertical/ functions (ie. 'zip') resolve--- using 'pure'.------ > 1 <> toP [2,3] == return 1 <> toP [2,3]--- > toP [1,2] * 3  == toP [1,2] * pure 3-undecided :: a -> P a-undecided a = P (Left a)---- | The basic list to pattern function, inverse is 'unP'.------ > unP (toP "str") == "str"------ > audition (pbind [(K_degree,pxrand 'α' [0,1,5,7] inf)--- >                 ,(K_dur,toP [0.1,0.2,0.1])])------ > > Pbind(\degree,(Pxrand([0,1,5,7],inf))--- > >      ,\dur,Pseq([0.1,0.2,0.1],1)).play------ The pattern above is finite, `toP` can sometimes be replaced with--- `pseq`.------ > audition (pbind [(K_degree,pxrand 'α' [0,1,5,7] inf)--- >                 ,(K_dur,pseq [0.1,0.2,0.1] inf)])-toP :: [a] -> P a-toP = P . Right---- | Type specialised 'F.toList'.  'undecided' values are singular.------ > F.toList (undecided 'a') == ['a']--- > unP (return 'a') == ['a']--- > "aaa" `L.isPrefixOf` unP (pure 'a')-unP :: P a -> [a]-unP = either return id . unP_either---- | Variant of 'unP' where 'undecided' values are 'repeat'ed.------ > unP_repeat (return 'a') == ['a']--- > take 2 (unP_repeat (undecided 'a')) == ['a','a']--- > take 2 (unP_repeat (pure 'a')) == ['a','a']-unP_repeat :: P a -> [a]-unP_repeat = either repeat id . unP_either--instance Functor P where-    fmap f (P p) = P (bimap f (map f) p)--instance Monoid (P a) where-    mappend p q = toP (unP p ++ unP q)-    mempty = toP []--instance Applicative P where-    pure = toP . repeat-    f <*> e = pzipWith ($) f e--instance Alternative P where-    empty = mempty-    (<|>) = mappend--instance F.Foldable P where-    foldr f i p = L.foldr f i (unP p)--instance T.Traversable P where-    traverse f p = pure toP <*> T.traverse f (unP p)--instance Monad P where-    m >>= k =-        case m of-          P (Left e) -> k e-          P (Right l) -> L.foldr (mappend . k) mempty l-    return x = toP [x]--instance MonadPlus P where-    mzero = mempty-    mplus = mappend--instance (Num a) => Num (P a) where-    (+) = pzipWith (+)-    (-) = pzipWith (-)-    (*) = pzipWith (*)-    abs = fmap abs-    signum = fmap signum-    negate = fmap negate-    fromInteger = undecided . fromInteger--instance (Fractional a) => Fractional (P a) where-    (/) = pzipWith (/)-    recip = fmap recip-    fromRational = undecided . fromRational--instance (Ord a) => Ord (P a) where-    (>) = error ("~> Ord>*")-    (>=) = error ("~> Ord>=*")-    (<) = error ("~> Ord<*")-    (<=) = error ("~> Ord<=*")--instance (OrdE a) => OrdE (P a) where-    (>*) = pzipWith (>*)-    (>=*) = pzipWith (>=*)-    (<*) = pzipWith (<*)-    (<=*) = pzipWith (<=*)---- * Lift P---- | Lift unary list function to pattern function.-liftP :: ([a] -> [b]) -> P a -> P b-liftP f = toP . f . unP---- | Lift binary list function to pattern function.------ > liftP2 (zipWith (+)) (toP [1,2]) (toP [3,4,5]) == toP [4,6]--- > liftA2 (+) (toP [1,2]) (toP [3,4,5]) == toP [4,6]-liftP2 :: ([a] -> [b] -> [c]) -> P a -> P b -> P c-liftP2 f p q =-    let p' = unP p-        q' = unP q-    in toP (f p' q')---- | Lift binary list function to /implicitly repeating/ pattern function.-liftP2_repeat :: ([a] -> [b] -> [c]) -> P a -> P b -> P c-liftP2_repeat f p q =-    let p' = unP_repeat p-        q' = unP_repeat q-    in toP (f p' q')---- | Lift ternary list function to pattern function.-liftP3 :: ([a] -> [b] -> [c] -> [d]) -> P a -> P b -> P c -> P d-liftP3 f p q r =-    let p' = unP p-        q' = unP q-        r' = unP r-    in toP (f p' q' r')---- | Lift ternary list function to /implicitly repeating/ pattern function.-liftP3_repeat :: ([a] -> [b] -> [c] -> [d]) -> P a -> P b -> P c -> P d-liftP3_repeat f p q r =-    let p' = unP_repeat p-        q' = unP_repeat q-        r' = unP_repeat r-    in toP (f p' q' r')---- * Zip P---- | An /implicitly repeating/ pattern variant of 'zipWith'.------ > zipWith (*) [1,2,3] [5,6] == [5,12]--- > pzipWith (*) (toP [1,2,3]) (toP [5,6]) == toP [5,12]------ It is the basis for lifting binary operators to patterns.------ > toP [1,2,3] * toP [5,6] == toP [5,12]------ > let p = pzipWith (,) (pseq [1,2] 2) (pseq [3,4] inf)--- > in p == toP [(1,3),(2,4),(1,3),(2,4)]------ > zipWith (,) (return 0) (return 1) == return (0,1)--- > pzipWith (,) 0 1 == undecided (0,1)-pzipWith :: (a -> b -> c) -> P a -> P b -> P c-pzipWith f p q =-    case (p,q) of-      (P (Left m),P (Left n)) -> undecided (f m n)-      _ -> toP (zipWith f (unP_repeat p) (unP_repeat q))---- | An /implicitly repeating/ pattern variant of 'zipWith3'.-pzipWith3 :: (a -> b -> c -> d) -> P a -> P b -> P c -> P d-pzipWith3 f p q r =-    case (p,q,r) of-      (P (Left m),P (Left n),P (Left o)) -> undecided (f m n o)-      _ -> toP (zipWith3 f (unP_repeat p) (unP_repeat q) (unP_repeat r))---- | An /implicitly repeating/ pattern variant of 'zip'.------ > zip (return 0) (return 1) == return (0,1)--- > pzip (undecided 3) (undecided 4) == undecided (3,4)--- > pzip 0 1 == undecided (0,1)------ Note that 'pzip' is otherwise like haskell 'zip', ie. truncating.------ > zip [1,2] [0] == [(1,0)]--- > pzip (toP [1,2]) (return 0) == toP [(1,0)]--- > pzip (toP [1,2]) (pure 0) == toP [(1,0),(2,0)]--- > pzip (toP [1,2]) 0 == toP [(1,0),(2,0)]-pzip :: P a -> P b -> P (a,b)-pzip = pzipWith (,)---- | Pattern variant of 'zip3'.-pzip3 :: P a -> P b -> P c -> P (a,b,c)-pzip3 = pzipWith3 (,,)---- | Pattern variant on 'unzip'.------ > let p = punzip (pzip (toP [1,2,3]) (toP [4,5]))--- > in p == (toP [1,2],toP [4,5])-punzip :: P (a,b) -> (P a,P b)-punzip p = let (i,j) = unzip (unP p) in (toP i,toP j)---- * Math---- | Type specialised 'maxBound', a pseudo-/infinite/ value for use at--- pattern repeat counts.------ > inf == maxBound-inf :: Int-inf = maxBound--{-| Constant /NaN/ (not a number) value.--> isNaN nan == True--A frequency value of NaN indicates a rest. This constant value can be-used as a rest indicator at a frequency model input (not at a @rest@-key).--> audition (pbind [(K_dur,pseq [0.1,0.7] inf)->                 ,(K_legato,0.2)->                 ,(K_degree,pseq [0,2,return nan] inf)])---}-nan :: Floating a => a-nan = sqrt (-1)---- * Data.List Patterns---- | Pattern variant of 'Data.List.:'.------ > pcons 'α' (pn (return 'β') 2) == toP "αββ"-pcons :: a -> P a -> P a-pcons = mappend . return---- | Pattern variant of 'Data.List.null'.------ > pnull mempty == True--- > pnull (undecided 'a') == False--- > pnull (pure 'a') == False--- > pnull (return 'a') == False-pnull :: P a -> Bool-pnull = null . unP---- | Alias for 'pure', pattern variant of 'Data.List.repeat'.------ > ptake 5 (prepeat 3) == toP [3,3,3,3,3]--- > ptake 5 (pure 3) == toP [3,3,3,3,3]--- > take 5 (pure 3) == [3]-prepeat :: a -> P a-prepeat = pure---- | Pattern variant of 'splitAt'.-psplitAt :: Int -> P a -> (P a,P a)-psplitAt n p =-    let (i,j) = splitAt n (unP p)-    in (toP i,toP j)---- | Pattern variant of 'Data.List.Split.splitPlaces'.------ > psplitPlaces' (toP [1,2,3]) (pseries 1 1 6) == toP [[1],[2,3],[4,5,6]]--- > psplitPlaces' (toP [1,2,3]) (toP ['a'..]) == toP ["a","bc","def"]-psplitPlaces' :: P Int -> P a -> P [a]-psplitPlaces' = liftP2 S.splitPlaces---- | 'fmap' 'toP' of 'psplitPlaces''.------ > psplitPlaces (toP [1,2,3]) (toP ['a'..]) == toP (map toP ["a","bc","def"])-psplitPlaces :: P Int -> P a -> P (P a)-psplitPlaces n = fmap toP . psplitPlaces' n---- | Pattern variant of 'P.take_inf', see also 'pfinval'.------ > ptake 5 (pseq [1,2,3] 2) == toP [1,2,3,1,2]--- > ptake 5 (toP [1,2,3]) == toP [1,2,3]--- > ptake 5 (pseq [1,2,3] inf) == toP [1,2,3,1,2]--- > ptake 5 (pwhite 'α' 0 5 inf) == toP [5,2,1,2,0]------ Note that `ptake` does not extend the input pattern, unlike `pser`.------ > ptake 5 (toP [1,2,3]) == toP [1,2,3]--- > pser [1,2,3] 5 == toP [1,2,3,1,2]-ptake :: Int -> P a -> P a-ptake n = liftP (P.take_inf n)---- | Type specialised 'P.mcycle'.------ > ptake 5 (pcycle 1) == preplicate 5 1--- > ptake 5 (pcycle (pure 1)) == preplicate 5 1--- > ptake 5 (pcycle (return 1)) == preplicate 5 1-pcycle :: P a -> P a-pcycle = P.mcycle---- | Type specialised 'mfilter'.  Aliased to `pselect`.  See also--- `preject`.------ > mfilter even (pseq [1,2,3] 2) == toP [2,2]--- > mfilter (< 3) (pseq [1,2,3] 2) == toP [1,2,1,2]-pfilter :: (a -> Bool) -> P a -> P a-pfilter = mfilter---- | Pattern variant of `replicate`.------ > preplicate 4 1 == toP [1,1,1,1]------ Compare to `pn`:------ > pn 1 4 == toP [1,1,1,1]--- > pn (toP [1,2]) 3 == toP [1,2,1,2,1,2]--- > preplicate 4 (toP [1,2]) :: P (P Int)-preplicate :: Int -> a -> P a-preplicate n = toP . (if n == inf then repeat else replicate n)---- | Pattern variant of `scanl`.  `scanl` is similar to `foldl`, but--- returns a list of successive reduced values from the left.  pscanl--- is an accumulator, it provides a mechanism for state to be threaded--- through a pattern. It can be used to write a function to remove--- succesive duplicates from a pattern, to count the distance between--- occurences of an element in a pattern and so on.------ > F.foldl (\x y -> 2 * x + y) 4 (pseq [1,2,3] 1) == 43--- > pscanl (\x y -> 2 * x + y) 4 (pseq [1,2,3] 1) == toP [4,9,20,43]------ > F.foldl (flip (:)) [] (toP [1..3]) == [3,2,1]--- > pscanl (flip (:)) [] (toP [1..3]) == toP [[],[1],[2,1],[3,2,1]]------ > F.foldl (+) 0 (toP [1..5]) == 15--- > pscanl (+) 0 (toP [1..5]) == toP [0,1,3,6,10,15]-pscanl :: (a -> b -> a) -> a -> P b -> P a-pscanl f i = liftP (L.scanl f i)---- | 'pdrop' @1@.  Pattern variant of `Data.List.tail`.  Drops first--- element from pattern.  Note that the haskell `tail` function is--- partial, although `drop` is not.  `ptake` is equal to `pdrop 1`.------ > tail [] == _|_--- > drop 1 [] == []------ > ptail (toP [1,2]) == toP [2]--- > ptail mempty == mempty-ptail :: P a -> P a-ptail = pdrop 1---- | Variant of 'L.transpose'.------ > L.transpose [[1,2],[3,4,5]] == [[1,3],[2,4],[5]]--- > ptranspose [toP [1,2],toP [3,4,5]] == toP [[1,3],[2,4],[5]]------ > let p = ptranspose [pseq [1,2] inf,pseq [4,5] inf]--- > in ptake 2 (pdrop (2^16) p) == toP [[1,4],[2,5]]-ptranspose :: [P a] -> P [a]-ptranspose l = toP (L.transpose (map unP l))---- | An /implicitly repeating/ pattern variant of 'P.transpose_st'.-ptranspose_st_repeat :: [P a] -> P [a]-ptranspose_st_repeat l = toP (P.transpose_st (map unP_repeat l))---- * SC3 Collection Patterns---- | Variant of 'C.flop'.------ > pflop' [toP [1,2],toP [3,4,5]] == toP [[1,3],[2,4],[1,5]]--- > pflop' [toP [1,2],3] == toP [[1,3],[2,3]]--- > pflop' [pseq [1,2] 1,pseq [3,4] inf]-pflop' :: [P a] -> P [a]-pflop' l = toP (C.flop (map unP l))---- | 'fmap' 'toP' of 'pflop''.------ > C.flop [[1,2],[3,4,5]] == [[1,3],[2,4],[1,5]]--- > pflop [toP [1,2],toP [3,4,5]] == toP (map toP [[1,3],[2,4],[1,5]])-pflop :: [P a] -> P (P a)-pflop = fmap toP . pflop'---- | Type specialised 'P.ffold'.------ > pfold (toP [10,11,12,-6,-7,-8]) (-7) 11 == toP [10,11,10,-6,-7,-6]------ > audition (pbind [(K_degree,pfold (pseries 4 1 inf) (-7) 11)--- >                 ,(K_dur,0.0625)])------ The underlying primitive is then `fold_` function.------ > let f = fmap (\n -> fold_ n (-7) 11)--- > in audition (pbind [(K_degree,f (pseries 4 1 inf))--- >                    ,(K_dur,0.0625)])-pfold :: (RealFrac n) => P n -> n -> n -> P n-pfold = P.ffold---- | Pattern variant of 'C.normalizeSum'.-pnormalizeSum :: Fractional n => P n -> P n-pnormalizeSum = liftP C.normalizeSum---- * SC3 Patterns--{-| Pbrown.  Lifted 'P.brown'.  SC3 pattern to generate-psuedo-brownian motion.--> pbrown 'α' 0 9 1 5 == toP [4,4,5,4,3]--> audition (pbind [(K_dur,0.065)->                 ,(K_freq,pbrown 'α' 440 880 20 inf)])---}-pbrown :: (Enum e,Random n,Num n,Ord n) => e -> n -> n -> n -> Int -> P n-pbrown e l r s n = ptake n (toP (P.brown e l r s))--{-| Pclutch.  SC3 sample and hold pattern.  For true values in the-control pattern, step the value pattern, else hold the previous value.--> > c = Pseq([1,0,1,0,0,1,1],inf);-> > p = Pclutch(Pser([1,2,3,4,5],8),c);-> > r = [1,1,2,2,2,3,4,5,5,1,1,1,2,3];-> > p.asStream.all == r--> let {c = pbool (pseq [1,0,1,0,0,1,1] inf)->     ;p = pclutch (pser [1,2,3,4,5] 8) c->     ;r = toP [1,1,2,2,2,3,4,5,5,1,1,1,2,3]}-> in p == toP [1,1,2,2,2,3,4,5,5,1,1,1,2,3]--Note the initialization behavior, nothing is generated until the-first true value.--> let {p = pseq [1,2,3,4,5] 1->     ;q = pbool (pseq [0,0,0,0,0,0,1,0,0,1,0,1] 1)}-> in pclutch p q == toP [1,1,1,2,2,3]--> > Pbind(\degree,Pstutter(Pwhite(3,10,inf),Pwhite(-4,11,inf)),-> >       \dur,Pclutch(Pwhite(0.1,0.4,inf),-> >                    Pdiff(Pkey(\degree)).abs > 0),-> >       \legato,0.3).play;--> let {d = pstutter (pwhite 'α' 3 10 inf) (pwhitei 'β' (-4) 11 inf)->     ;p = [(K_degree,d)->          ,(K_dur,pclutch (pwhite 'γ' 0.1 0.4 inf)->                          (pbool (abs (pdiff d) >* 0)))->          ,(K_legato,0.3)]}-> in audition (pbind p)---}-pclutch :: P a -> P Bool -> P a-pclutch p q =-    let r = fmap (+ 1) (pcountpost q)-    in pstutter r p---- | Pcollect.  SC3 name for 'fmap', ie. patterns are functors.------ > > Pcollect({|i| i * 3},Pseq(#[1,2,3],1)).asStream.all == [3,6,9]--- > pcollect (* 3) (toP [1,2,3]) == toP [3,6,9]------ > > Pseq(#[1,2,3],1).collect({|i| i * 3}).asStream.all == [3,6,9]--- > fmap (* 3) (toP [1,2,3]) == toP [3,6,9]-pcollect :: (a -> b) -> P a -> P b-pcollect = fmap---- | Pconst.  SC3 pattern to constrain the sum of a numerical pattern.--- Is equal to /p/ until the accumulated sum is within /t/ of /n/.  At--- that point, the difference between the specified sum and the--- accumulated sum concludes the pattern.------ > > p = Pconst(10,Pseed(Pn(1000,1),Prand([1,2,0.5,0.1],inf),0.001));--- > > p.asStream.all == [0.5,0.1,0.5,1,2,2,0.5,1,0.5,1,0.9]------ > let p = pconst 10 (prand 'α' [1,2,0.5,0.1] inf) 0.001--- > in (p,Data.Foldable.sum p)------ > > Pbind(\degree,Pseq([-7,Pwhite(0,11,inf)],1),--- > >       \dur,Pconst(4,Pwhite(1,4,inf) * 0.25)).play------ > let p = [(K_degree,pcons (-7) (pwhitei 'α' 0 11 inf))--- >         ,(K_dur,pconst 4 (pwhite 'β' 1 4 inf * 0.25) 0.001)]--- > in audition (pbind p)-pconst :: (Ord a,Num a) => a -> P a -> a -> P a-pconst n p t =-    let f _ [] = []-        f j (i:is) = if i + j < n - t-                     then i : f (j + i) is-                     else [n - j]-    in toP (f 0 (unP p))--{-| PdegreeToKey.  SC3 pattern to derive notes from an index into a-scale.--> let {p = pseq [0,1,2,3,4,3,2,1,0,2,4,7,4,2] 2->     ;q = pure [0,2,4,5,7,9,11]->     ;r = [0,2,4,5,7,5,4,2,0,4,7,12,7,4,0,2,4,5,7,5,4,2,0,4,7,12,7,4]}-> in pdegreeToKey p q (pure 12) == toP r--> let {p = pseq [0,1,2,3,4,3,2,1,0,2,4,7,4,2] 2->     ;q = pseq (map return [[0,2,4,5,7,9,11],[0,2,3,5,7,8,11]]) 1->     ;r = [0,2,4,5,7,5,4,2,0,4,7,12,7,4,0,2,3,5,7,5,3,2,0,3,7,12,7,3]}-> in pdegreeToKey p (pstutter 14 q) (pure 12) == toP r--This is the pattern variant of 'M.degreeToKey'.--> let s = [0,2,4,5,7,9,11]-> in map (M.degreeToKey s 12) [0,2,4,7,4,2,0] == [0,4,7,12,7,4,0]--> > Pbind(\note,PdegreeToKey(Pseq([1,2,3,2,5,4,3,4,2,1],2),-> >                          #[0,2,3,6,7,9],-> >                          12),\dur,0.25).play--> let {n = pdegreeToKey (pseq [1,2,3,2,5,4,3,4,2,1] 2)->                       (pure [0,2,3,6,7,9])->                       12}-> in audition (pbind [(K_note,n),(K_dur,0.25)])--> > s = #[[0,2,3,6,7,9],[0,1,5,6,7,9,11],[0,2,3]];-> > d = [1,2,3,2,5,4,3,4,2,1];-> > Pbind(\note,PdegreeToKey(Pseq(d,4),-> >                          Pstutter(3,Prand(s,inf)),-> >                          12),\dur,0.25).play;--> let {s = map return [[0,2,3,6,7,9],[0,1,5,6,7,9,11],[0,2,3]]->     ;d = [1,2,3,2,5,4,3,4,2,1]->     ;k = pdegreeToKey (pseq d 4)->                       (pstutter 3 (prand 'α' s 14))->                       (pn 12 40)}-> in audition (pbind [(K_note,k),(K_dur,0.25)])---}-pdegreeToKey :: (RealFrac a) => P a -> P [a] -> P a -> P a-pdegreeToKey = pzipWith3 (\i j k -> M.degreeToKey j k i)---- | Pdiff.  SC3 pattern to calculate adjacent element difference.------ > > Pdiff(Pseq([0,2,3,5,6,8,9],1)).asStream.all == [2,1,2,1,2,1]--- > pdiff (pseq [0,2,3,5,6,8,9] 1) == toP [2,1,2,1,2,1]-pdiff :: Num n => P n -> P n-pdiff p = ptail p - p---- | Pdrop.  Lifted 'L.drop'.------ > > p = Pseries(1,1,20).drop(5);--- > > p.asStream.all == [6,7,8,9,10,11,12,13,14,15,16,17,18,19,20]------ > pdrop 5 (pseries 1 1 10) == toP [6,7,8,9,10]--- > pdrop 1 mempty == mempty-pdrop :: Int -> P a -> P a-pdrop n = liftP (drop n)---- | PdurStutter.  Lifted 'P.durStutter'.------ > > s = Pseq(#[1,1,1,1,1,2,2,2,2,2,0,1,3,4,0],inf);--- > > d = Pseq(#[0.5,1,2,0.25,0.25],1);--- > > PdurStutter(s,d).asStream.all == [0.5,1,2,0.25,0.25]------ > let {s = pseq [1,1,1,1,1,2,2,2,2,2,0,1,3,4,0] inf--- >     ;d = pseq [0.5,1,2,0.25,0.25] 1}--- > in pdurStutter s d == toP [0.5,1.0,2.0,0.25,0.25]------ Applied to duration.------ > > d = PdurStutter(Pseq(#[1,1,1,1,1,2,2,2,2,2,3,3,3,3,3,4,4,4,4,4],inf),--- > >                 Pseq(#[0.5,1,2,0.25,0.25],inf));--- > > Pbind(\freq,440,\dur,d).play------ > let {s = pseq [1,1,1,1,1,2,2,2,2,2,3,3,3,3,3,4,4,4,4,4] inf--- >     ;d = pseq [0.5,1,2,0.25,0.25] inf}--- > in audition (pbind [(K_freq,440),(K_dur,pdurStutter s d)])------ Applied to frequency.------ > let {s = pseq [1,1,1,1,1,2,2,2,2,2,3,3,3,3,4,4,0,4,4] inf--- >     ;d = pseq [0,2,3,5,7,9,10] inf + 80}--- > in audition (pbind [(K_midinote,pdurStutter s d),(K_dur,0.15)])-pdurStutter :: Fractional a => P Int -> P a -> P a-pdurStutter = liftP2 P.durStutter---- | Pexprand.  Lifted 'P.exprand'.------ > > Pexprand(0.0001,1,10).asStream.all--- > pexprand 'α' 0.0001 1 10------ > > Pbind(\freq,Pexprand(0.0001,1,inf) * 600 + 300,\dur,0.02).play------ > audition (pbind [(K_freq,pexprand 'α' 0.0001 1 inf * 600 + 300)--- >                 ,(K_dur,0.02)])-pexprand :: (Enum e,Random a,Floating a) => e -> a -> a -> Int -> P a-pexprand e l r = toP . P.exprand e l r---- | Pfinval.  Alias for 'ptake'------ > > Pfinval(5,Pseq(#[1,2,3],inf)).asStream.all == [1,2,3,1,2]--- > pfinval 5 (pseq [1,2,3] inf) == toP [1,2,3,1,2]-pfinval :: Int -> P a -> P a-pfinval = ptake--{-|-A variant of the SC3 pattern that evaluates a closure at each-step.  The haskell variant function has a 'StdGen' form.--> > p = Pfuncn({exprand(0.1,0.3) + #[1,2,3,6,7].choose},inf);-> > Pbind(\freq,p * 100 + 300,\dur,0.02).play--> let {exprand = Sound.SC3.Lang.Random.Gen.exprand->     ;choose = Sound.SC3.Lang.Random.Gen.choose->     ;p = pfuncn 'α' (exprand 0.1 0.3) inf->     ;q = pfuncn 'β' (choose [1,2,3,6,7]) inf}-> in audition (pbind [(K_freq,(p + q) * 100 + 300),(K_dur,0.02)])--Of course in this case there is a pattern equivalent.--> let {p = pexprand 'α' 0.1 0.3 inf + prand 'β' [1,2,3,6,7] inf}-> in audition (pbind [(K_freq,p * 100 + 300),(K_dur,0.02)])---}-pfuncn :: Enum e => e -> (StdGen -> (n,StdGen)) -> Int -> P n-pfuncn e f n = toP (P.funcn e f n)---- | Pgeom.  SC3 geometric series pattern.------ > > Pgeom(3,6,5).asStream.all == [3,18,108,648,3888]--- > pgeom 3 6 5 == toP [3,18,108,648,3888]------ > > Pgeom(1,2,10).asStream.all == [1,2,4,8,16,32,64,128,256,512]--- > pgeom 1 2 10 == toP [1,2,4,8,16,32,64,128,256,512]------ Real numbers work as well.------ > > p = Pgeom(1.0,1.1,6).collect({|i| (i * 100).floor});--- > > p.asStream.all == [100,110,121,133,146,161];------ > let p = fmap (floor . (* 100)) (pgeom 1.0 1.1 6)--- > in p == toP [100,110,121,133,146,161]------ > > Pbind(\degree,Pseries(-7,1,15),--- > >       \dur,Pgeom(0.5,0.89140193218427,15)).play;------ > audition (pbind [(K_degree,pseries (-7) 1 15)--- >                 ,(K_dur,pgeom 0.5 0.89140193218427 15)])------ There is a list variant.------ > > 5.geom(3,6)--- > C.geom 5 3 6 == [3,18,108,648,3888]-pgeom :: (Num a) => a -> a -> Int -> P a-pgeom i s n = toP (C.geom n i s)---- | Pif.  SC3 /implicitly repeating/ pattern-based conditional expression.------ > > a = Pfunc({0.3.coin});--- > > b = Pwhite(0,9,3);--- > > c = Pwhite(10,19,3);--- > > Pfin(9,Pif(a,b,c)).asStream.all------ > let {a = fmap (< 0.75) (pwhite 'α' 0.0 1.0 inf)--- >     ;b = pwhite 'β' 0 9 6--- >     ;c = pwhite 'γ' 10 19 6}--- > in pif a b c * (-1) == toP [-7,-3,-11,-17,-18,-6,-3,-4,-5]-pif :: P Bool -> P a -> P a -> P a-pif = liftP3_repeat P.if_demand---- | Place.  SC3 interlaced embedding of subarrays.------ > > Place([0,[1,2],[3,4,5]],3).asStream.all == [0,1,3,0,2,4,0,1,5]--- > C.lace 9 [[0],[1,2],[3,4,5]] == [0,1,3,0,2,4,0,1,5]--- > place [[0],[1,2],[3,4,5]] 3 == toP [0,1,3,0,2,4,0,1,5]------ > > Place(#[1,[2,5],[3,6]],2).asStream.all == [1,2,3,1,5,6]--- > C.lace 6 [[1],[2,5],[3,6]] == [1,2,3,1,5,6]--- > place [[1],[2,5],[3,6]] 2 == toP [1,2,3,1,5,6]------ > C.lace 12 [[1],[2,5],[3,6..]] == [1,2,3,1,5,6,1,2,9,1,5,12]--- > place [[1],[2,5],[3,6..]] 4 == toP [1,2,3,1,5,6,1,2,9,1,5,12]-place :: [[a]] -> Int -> P a-place a n =-    let f = toP . concat . P.take_inf n . L.transpose . map cycle-    in f a---- | Pn.  SC3 pattern to repeat the enclosed pattern a number of--- times.------ > pn 1 4 == toP [1,1,1,1]--- > pn (toP [1,2,3]) 3 == toP [1,2,3,1,2,3,1,2,3]------ This is related to `concat`.`replicate` in standard list processing.------ > concat (replicate 4 [1]) == [1,1,1,1]--- > concat (replicate 3 [1,2,3]) == [1,2,3,1,2,3,1,2,3]------ There is a `pconcatReplicate` near-alias (reversed argument order).------ > pconcatReplicate 4 1 == toP [1,1,1,1]--- > pconcatReplicate 3 (toP [1,2]) == toP [1,2,1,2,1,2]------ This is productive over infinite lists.------ > concat (replicate inf [1])--- > pconcat (replicate inf 1)--- > pconcatReplicate inf 1-pn :: P a -> Int -> P a-pn p n = mconcat (replicate n p)---- | Ppatlace.  SC3 /implicitly repeating/ pattern to lace input patterns.------ > > p = Ppatlace([1,Pseq([2,3],2),4],5);--- > > p.asStream.all == [1,2,4,1,3,4,1,2,4,1,3,4,1,4]------ > ppatlace [1,pseq [2,3] 2,4] 5 == toP [1,2,4,1,3,4,1,2,4,1,3,4,1,4]------ > > p = Ppatlace([1,Pseed(Pn(1000,1),Prand([2,3],inf))],5);--- > > p.asStream.all == [1,3,1,3,1,3,1,2,1,2]------ > ppatlace [1,prand 'α' [2,3] inf] 5 == toP [1,3,1,2,1,3,1,2,1,2]------ > > Pbind(\degree,Ppatlace([Pseries(0,1,8),Pseries(2,1,7)],inf),--- > >       \dur,0.25).play;------ > let p = [(K_degree,ppatlace [pseries 0 1 8,pseries 2 1 7] inf)--- >         ,(K_dur,0.125)]--- > in audition (pbind p)-ppatlace :: [P a] -> Int -> P a-ppatlace a n =-    let a' = L.transpose (map unP_repeat a)-    in toP (L.concat (P.take_inf n a'))--{-| Prand.  SC3 pattern to make n random selections from a list of-patterns, the resulting pattern is flattened (joined).--> > p = Pseed(Pn(1000,1),Prand([1,Pseq([10,20,30]),2,3,4,5],6));-> > p.asStream.all == [3,5,3,10,20,30,2,2]--> prand 'α' [1,toP [10,20],2,3,4,5] 5 == toP [5,2,10,20,2,1]--> > Pbind(\note,Prand([0,1,5,7],inf),\dur,0.25).play--> audition (pbind [(K_note,prand 'α' [0,1,5,7] inf),(K_dur,0.25)])--Nested sequences of pitches:--> > Pbind(\midinote,Prand([Pseq(#[60,61,63,65,67,63]),-> >                        Prand(#[72,73,75,77,79],6),-> >                        Pshuf(#[48,53,55,58],2)],inf),-> >       \dur,0.25).play--> let {n = prand 'α' [pseq [60,61,63,65,67,63] 1->                    ,prand 'β' [72,73,75,77,79] 6->                    ,pshuf 'γ' [48,53,55,58] 2] inf}-> in audition (pbind [(K_midinote,n),(K_dur,0.075)])--The below cannot be written as intended with the list-based pattern library.  This is precisely because the-noise patterns are values, not processes with a state-threaded non-locally.--> do {n0 <- Sound.SC3.Lang.Random.IO.rrand 2 5->    ;n1 <- Sound.SC3.Lang.Random.IO.rrand 3 9->    ;let p = pseq [prand 'α' [pempty,pseq [24,31,36,43,48,55] 1] 1->                  ,pseq [60,prand 'β' [63,65] 1->                        ,67,prand 'γ' [70,72,74] 1] n0->                  ,prand 'δ' [74,75,77,79,81] n1] inf->     in return (ptake 24 p)}---}-prand :: Enum e => e -> [P a] -> Int -> P a-prand e a = join . prand' e a---- | Preject.  SC3 pattern to rejects values for which the predicate--- is true.  reject f is equal to filter (not . f).------ > preject (== 1) (pseq [1,2,3] 2) == toP [2,3,2,3]--- > pfilter (not . (== 1)) (pseq [1,2,3] 2) == toP [2,3,2,3]------ > > p = Pseed(Pn(1000,1),Pwhite(0,255,20).reject({|x| x.odd}));--- > > p.asStream.all == [224,60,88,94,42,32,110,24,122,172]------ > preject odd (pwhite 'α' 0 255 10) == toP [32,158,62,216,240,20]------ > > p = Pseed(Pn(1000,1),Pwhite(0,255,20).select({|x| x.odd}));--- > > p.asStream.all == [151,157,187,129,45,245,101,79,77,243]------ > pselect odd (pwhite 'α' 0 255 10) == toP [241,187,119,127]-preject :: (a -> Bool) -> P a -> P a-preject f = liftP (filter (not . f))---- | Prorate.  SC3 /implicitly repeating/ sub-dividing pattern.------ > > p = Prorate(Pseq([0.35,0.5,0.8]),1);--- > > p.asStream.all == [0.35,0.65,0.5,0.5,0.8,0.2];------ > let p = prorate (fmap Left (pseq [0.35,0.5,0.8] 1)) 1--- > in fmap roundE (p * 100) == toP [35,65,50,50,80,20]------ > > p = Prorate(Pseq([0.35,0.5,0.8]),Pseed(Pn(100,1),Prand([20,1],inf)));--- > > p.asStream.all == [7,13,0.5,0.5,16,4]------ > let p = prorate (fmap Left (pseq [0.35,0.5,0.8] 1))--- >                 (prand 'α' [20,1] 3)--- > in fmap roundE (p * 100) == toP [35,65,1000,1000,80,20]------ > > l = [[1,2],[5,7],[4,8,9]].collect(_.normalizeSum);--- > > Prorate(Pseq(l,1)).asStream.all------ > let l = map (Right . C.normalizeSum) [[1,2],[5,7],[4,8,9]]--- > in prorate (toP l) 1------ > > Pfinval(5,Prorate(0.6,0.5)).asStream.all == [0.3,0.2,0.3,0.2,0.3]------ > pfinval 5 (prorate (fmap Left 0.6) 0.5) == toP [0.3,0.2,0.3,0.2,0.3]------ > > Pbind(\degree,Pseries(4,1,inf).fold(-7,11),--- > >       \dur,Prorate(0.6,0.5)).play------ > audition (pbind [(K_degree,pfold (pseries 4 1 inf) (-7) 11)--- >                 ,(K_dur,prorate (fmap Left 0.6) 0.25)])-prorate :: Num a => P (Either a [a]) -> P a -> P a-prorate p = pjoin_repeat . pzipWith prorate' p---- | Pselect.  See 'pfilter'.------ > pselect (< 3) (pseq [1,2,3] 2) == toP [1,2,1,2]-pselect :: (a -> Bool) -> P a -> P a-pselect f = liftP (filter f)--{-| Pseq.  SC3 pattern to cycle over a list of patterns. The repeats-pattern gives the number of times to repeat the entire list.--> pseq [return 1,return 2,return 3] 2 == toP [1,2,3,1,2,3]-> pseq [1,2,3] 2 == toP [1,2,3,1,2,3]-> pseq [1,pn 2 2,3] 2 == toP [1,2,2,3,1,2,2,3]--There is an 'inf' value for the repeats variable.--> ptake 3 (pdrop (10^5) (pseq [1,2,3] inf)) == toP [2,3,1]--Unlike the SC3 Pseq, `pseq` does not have an offset argument to give a-starting offset into the list.--> pseq (C.rotate 3 [1,2,3,4]) 3 == toP [2,3,4,1,2,3,4,1,2,3,4,1]--As scale degrees.--> > Pbind(\degree,Pseq(#[0,0,4,4,5,5,4],1),-> >       \dur,Pseq(#[0.5,0.5,0.5,0.5,0.5,0.5,1],1)).play--> audition (pbind [(K_degree,pseq [0,0,4,4,5,5,4] 1)->                 ,(K_dur,pseq [0.5,0.5,0.5,0.5,0.5,0.5,1] 1)])--> > Pseq(#[60,62,63,65,67,63],inf) + Pseq(#[0,0,0,0,-12],inf)--> let n = pseq [60,62,63,65,67,63] inf + pser [0,0,0,0,-12] 25-> in audition (pbind [(K_midinote,n),(K_dur,0.2)])--Pattern `b` pattern sequences `a` once normally, once transposed up a-fifth and once transposed up a fourth.--> > a = Pseq(#[60,62,63,65,67,63]);-> > b = Pseq([a,a + 7,a + 5],inf);-> > Pbind(\midinote,b,\dur,0.3).play--> let {a = pseq [60,62,63,65,67,63] 1->     ;b = pseq [a,a + 7,a + 5] inf}-> in audition (pbind [(K_midinote,b),(K_dur,0.13)])--}-pseq :: [P a] -> Int -> P a-pseq a i =-    let a' = mconcat a-    in if i == inf then pcycle a' else pn a' i---- | Pser.  SC3 pattern that is like 'pseq', however the repeats--- variable gives the number of elements in the sequence, not the--- number of cycles of the pattern.------ > pser [1,2,3] 5 == toP [1,2,3,1,2]--- > pser [1,pser [10,20] 3,3] 9 == toP [1,10,20,10,3,1,10,20,10]--- > pser [1,2,3] 5 * 3 == toP [3,6,9,3,6]-pser :: [P a] -> Int -> P a-pser a i = ptake i (pcycle (mconcat a))---- | Pseries.  SC3 arithmetric series pattern, see also 'pgeom'.------ > pseries 0 2 10 == toP [0,2,4,6,8,10,12,14,16,18]--- > pseries 9 (-1) 10 == toP [9,8 .. 0]--- > pseries 1.0 0.2 3 == toP [1.0::Double,1.2,1.4]-pseries :: (Num a) => a -> a -> Int -> P a-pseries i s n = toP (C.series n i s)---- | Pshuf.  SC3 pattern to return @n@ repetitions of a shuffled--- sequence.------ > > Pshuf([1,2,3,4],2).asStream.all--- > pshuf 'α' [1,2,3,4] 2 == toP [2,4,3,1,2,4,3,1]------ > > Pbind(\degree,Pshuf([0,1,2,4,5],inf),\dur,0.25).play------ > audition (pbind [(K_degree,pshuf 'α' [0,1,2,4,5] inf)--- >                 ,(K_dur,0.25)])-pshuf :: Enum e => e -> [a] -> Int -> P a-pshuf e a =-    let (a',_) = R.scramble a (mkStdGen (fromEnum e))-    in pn (toP a')---- | Pslide.  Lifted 'P.slide'.------ > > Pslide([1,2,3,4],inf,3,1,0).asStream.all--- > pslide [1,2,3,4] 4 3 1 0 True == toP [1,2,3,2,3,4,3,4,1,4,1,2]--- > pslide [1,2,3,4,5] 3 3 (-1) 0 True == toP [1,2,3,5,1,2,4,5,1]------ > > Pbind(\degree,Pslide((-6,-4 .. 12),8,3,1,0),--- > >       \dur,Pseq(#[0.1,0.1,0.2],inf),--- > >       \sustain,0.15).play------ > audition (pbind [(K_degree,pslide [-6,-4 .. 12] 8 3 1 0 True)--- >                 ,(K_dur,pseq [0.05,0.05,0.1] inf)--- >                 ,(K_sustain,0.15)])-pslide :: [a] -> Int -> Int -> Int -> Int -> Bool -> P a-pslide a n j s i = toP . P.slide a n j s i---- | Pstutter.  SC3 /implicitly repeating/ pattern to repeat each--- element of a pattern /n/ times.------ > > Pstutter(2,Pseq([1,2,3],1)).asStream.all == [1,1,2,2,3,3]--- > pstutter 2 (pseq [1,2,3] 1) == toP [1,1,2,2,3,3]------ The count input may be a pattern.------ > let {p = pseq [1,2] inf--- >     ;q = pseq [1,2,3] 2}--- > in pstutter p q == toP [1,2,2,3,1,1,2,3,3]------ > pstutter (toP [1,2,3]) (toP [4,5,6]) == toP [4,5,5,6,6,6]--- > pstutter 2 (toP [4,5,6]) == toP [4,4,5,5,6,6]------ Stutter scale degree and duration with the same random sequence.------ > > Pbind(\n,Pwhite(3,10,inf),--- > >       \degree,Pstutter(Pkey(\n),Pwhite(-4,11,inf)),--- > >       \dur,Pstutter(Pkey(\n),Pwhite(0.05,0.4,inf)),--- > >       \legato,0.3).play------ > let {n = pwhite 'α' 3 10 inf--- >     ;p = [(K_degree,pstutter n (pwhitei 'β' (-4) 11 inf))--- >          ,(K_dur,pstutter n (pwhite 'γ' 0.05 0.4 inf))--- >          ,(K_legato,0.3)]}--- > in audition (pbind p)-pstutter :: P Int -> P a -> P a-pstutter = liftP2_repeat P.stutter---- | Pswitch.  Lifted 'P.switch'.------ > let p = pswitch [pseq [1,2,3] 2,pseq [65,76] 1,800] (toP [2,2,0,1])--- > in p == toP [800,800,1,2,3,1,2,3,65,76]-pswitch :: [P a] -> P Int -> P a-pswitch l = liftP (P.switch (map unP l))---- | Pswitch1.  Lifted /implicitly repeating/ 'P.switch1'.------ > > l = [Pseq([1,2,3],inf),Pseq([65,76],inf),8];--- > > p = Pswitch1(l,Pseq([2,2,0,1],3));--- > > p.asStream.all == [8,8,1,65,8,8,2,76,8,8,3,65];------ > let p = pswitch1 [pseq [1,2,3] inf--- >                  ,pseq [65,76] inf--- >                  ,8] (pseq [2,2,0,1] 6)--- > in p == toP [8,8,1,65,8,8,2,76,8,8,3,65,8,8,1,76,8,8,2,65,8,8,3,76]-pswitch1 :: [P a] -> P Int -> P a-pswitch1 l = liftP (P.switch1 (map unP_repeat l))---- | Ptuple.  'pseq' of 'ptranspose_st_repeat'.------ > > l = [Pseries(7,-1,8),3,Pseq([9,7,4,2],1),Pseq([4,2,0,0,-3],1)];--- > > p = Ptuple(l,1);--- > > p.asStream.all == [[7,3,9,4],[6,3,7,2],[5,3,4,0],[4,3,2,0]]------ > let p = ptuple [pseries 7 (-1) 8--- >                ,3--- >                ,pseq [9,7,4,2] 1--- >                ,pseq [4,2,0,0,-3] 1] 1--- > in p == toP [[7,3,9,4],[6,3,7,2],[5,3,4,0],[4,3,2,0]]-ptuple :: [P a] -> Int -> P [a]-ptuple p = pseq [ptranspose_st_repeat p]---- | Pwhite.  Lifted 'P.white'.------ > pwhite 'α' 0 9 5 == toP [3,0,1,6,6]--- > pwhite 'α' 0 9 5 - pwhite 'α' 0 9 5 == toP [0,0,0,0,0]------ The pattern below is alternately lower and higher noise.------ > let {l = pseq [0.0,9.0] inf--- >     ;h = pseq [1.0,12.0] inf}--- > in audition (pbind [(K_freq,pwhite' 'α' l h * 20 + 800)--- >                    ,(K_dur,0.25)])-pwhite :: (Random n,Enum e) => e -> n -> n -> Int -> P n-pwhite e l r = toP . P.white e l r---- | Pwrand.  Lifted 'P.wrand'.------ > let w = C.normalizeSum [12,6,3]--- > in pwrand 'α' [1,2,3] w 6 == toP [2,1,2,3,3,2]------ > > r = Pwrand.new([1,2,Pseq([3,4],1)],[1,3,5].normalizeSum,6);--- > > p = Pseed(Pn(100,1),r);--- > > p.asStream.all == [2,3,4,1,3,4,3,4,2]------ > let w = C.normalizeSum [1,3,5]--- > in pwrand 'ζ' [1,2,pseq [3,4] 1] w 6 == toP [3,4,2,2,3,4,1,3,4]------ > > Pbind(\degree,Pwrand((0..7),[4,1,3,1,3,2,1].normalizeSum,inf),--- > >       \dur,0.25).play;------ > let {w = C.normalizeSum [4,1,3,1,3,2,1]--- >     ;d = pwrand 'α' (C.series 7 0 1) w inf}--- > in audition (pbind [(K_degree,d),(K_dur,0.25)])-pwrand :: (Enum e) => e -> [P a] -> [Double] -> Int -> P a-pwrand e a w = toP . P.wrand e (map unP a) w---- | Pwrap.  Type specialised 'P.fwrap', see also 'pfold'.------ > > p = Pwrap(Pgeom(200,1.25,9),200,1000.0);--- > > r = p.asStream.all.collect({|n| n.round});--- > > r == [200,250,313,391,488,610,763,954,392];------ > let p = fmap roundE (pwrap (pgeom 200 1.25 9) 200 1000)--- > in p == toP [200,250,312,391,488,610,763,954,391]-pwrap :: (Ord a,Num a) => P a -> a -> a -> P a-pwrap = P.fwrap---- | Pxrand.  Lifted 'P.xrand'.------ > let p = pxrand 'α' [1,toP [2,3],toP [4,5,6]] 9--- > in p == toP [4,5,6,2,3,4,5,6,1]------ > > Pbind(\note,Pxrand([0,1,5,7],inf),\dur,0.25).play------ > audition (pbind [(K_note,pxrand 'α' [0,1,5,7] inf),(K_dur,0.25)])-pxrand :: Enum e => e -> [P a] -> Int -> P a-pxrand e a n = toP (P.xrand e (map unP a) n)---- * Variant SC3 Patterns---- | Lifted /implicitly repeating/ 'P.pbrown''.------ > pbrown' 'α' 1 700 (pseq [1,20] inf) 4 == toP [415,419,420,428]-pbrown' :: (Enum e,Random n,Num n,Ord n) =>-           e -> P n -> P n -> P n -> Int -> P n-pbrown' e l r s n =-    let f = liftP3_repeat (P.brown' e)-    in ptake n (f l r s)---- | Un-joined variant of 'prand'.------ > let p = prand' 'α' [1,toP [2,3],toP [4,5,6]] 5--- > in p == toP [toP [4,5,6],toP [4,5,6],toP [2,3],toP [4,5,6],1]-prand' :: Enum e => e -> [P a] -> Int -> P (P a)-prand' e a n = toP (P.rand' e a n)---- | Underlying pattern for 'prorate'.------ > prorate' (Left 0.6) 0.5-prorate' :: Num a => Either a [a] -> a -> P a-prorate' p =-    case p of-      Left p' -> toP . P.rorate_n' p'-      Right p' -> toP . P.rorate_l' p'--{-|-Variant of `pseq` that retrieves only one value from each pattern-on each list traversal.  Compare to `pswitch1`.--> pseq [pseq [1,2] 1,pseq [3,4] 1] 2 == toP [1,2,3,4,1,2,3,4]-> pseq1 [pseq [1,2] 1,pseq [3,4] 1] 2 == toP [1,3,2,4]-> pseq1 [pseq [1,2] inf,pseq [3,4] inf] 3 == toP [1,3,2,4,1,3]--> let {p = prand' 'α' [pempty,toP [24,31,36,43,48,55]] inf->     ;q = pflop [60,prand 'β' [63,65] inf->                ,67,prand 'γ' [70,72,74] inf]->     ;r = psplitPlaces (pwhite 'δ' 3 9 inf)->                       (toP [74,75,77,79,81])->     ;n = pjoin (pseq1 [p,q,r] inf)}-> in audition (pbind [(K_midinote,n),(K_dur,0.13)])--}-pseq1 :: [P a] -> Int -> P a-pseq1 a i = join (ptake i (pflop a))---- | A variant of 'pseq' to aid translating a common SC3 idiom where a--- finite random pattern is included in a @Pseq@ list.  In the SC3--- case, at each iteration a new computation is run.  This idiom does--- not directly translate to the declarative haskell pattern library.------ > > Pseq([1,Prand([2,3],1)],5).asStream.all--- > pseq [1,prand 'α' [2,3] 1] 5 == toP [1,3,1,3,1,3,1,3,1,3]------ Although the intended pattern can usually be expressed using an--- alternate construction:------ > > Pseq([1,Prand([2,3],1)],5).asStream.all--- > ppatlace [1,prand 'α' [2,3] inf] 5 == toP [1,3,1,2,1,3,1,2,1,2]------ the 'pseqn' variant handles many common cases.------ > > Pseq([Pn(8,2),Pwhite(9,16,1)],5).asStream.all------ > let p = pseqn [2,1] [8,pwhite 'α' 9 16 inf] 5--- > in p == toP [8,8,10,8,8,9,8,8,12,8,8,15,8,8,15]-pseqn :: [Int] -> [P a] -> Int -> P a-pseqn n q =-    let rec p c = if c == 0-                  then mempty-                  else let (i,j) = unzip (zipWith psplitAt n p)-                       in mconcat i <> rec j (c - 1)-    in rec (map pcycle q)--{-|--A variant of 'pseq' that passes a new seed at each invocation,-see also 'pfuncn'.--> > pseqr (\e -> [pshuf e [1,2,3,4] 1]) 2 == toP [2,3,4,1,4,1,2,3]--> let {d = pseqr (\e -> [pshuf e [-7,-3,0,2,4,7] 4->                       ,pseq [0,1,2,3,4,5,6,7] 1]) inf}-> in audition (pbind [(K_degree,d),(K_dur,0.15)])--> > Pbind(\dur,0.2,-> >       \midinote,Pseq([Pshuf(#[60,61,62,63,64,65,66,67],3)],inf)).play--> let m = pseqr (\e -> [pshuf e [60,61,62,63,64,65,66,67] 3]) inf-> in audition (pbind [(K_dur,0.2),(K_midinote,m)])---}-pseqr :: (Int -> [P a]) -> Int -> P a-pseqr f n = mconcat (L.concatMap f [1 .. n])---- | Variant of 'pser' that consumes sub-patterns one element per--- iteration.------ > pser1 [1,pser [10,20] 3,3] 9 == toP [1,10,3,1,20,3,1,10,3]-pser1 :: [P a] -> Int -> P a-pser1 a i = ptake i (join (pflop a))---- | Lifted /implicitly repeating/ 'P.pwhite'.------ > pwhite' 'α' 0 (pseq [9,19] 3) == toP [3,0,1,6,6,15]-pwhite' :: (Enum e,Random n) => e -> P n -> P n -> P n-pwhite' e = liftP2_repeat (P.white' e)---- | Lifted 'P.whitei'.------ > pwhitei 'α' 1 9 5 == toP [5,1,7,7,8]------ > audition (pbind [(K_degree,pwhitei 'α' 0 8 inf),(K_dur,0.15)])-pwhitei :: (RealFracE n,Random n,Enum e) => e -> n -> n -> Int -> P n-pwhitei e l r =  toP . P.whitei e l r---- * Non-SC3 Patterns---- | Type specialised 'P.fbool'.-pbool :: (Ord a,Num a) => P a -> P Bool-pbool = P.fbool---- | 'mconcat' of 'replicate'.-pconcatReplicate :: Int -> P a -> P a-pconcatReplicate i = mconcat . replicate i---- | Lifted 'P.countpost'.-pcountpost :: P Bool -> P Int-pcountpost = liftP P.countpost---- | Lifted 'P.countpre'.-pcountpre :: P Bool -> P Int-pcountpre = liftP P.countpre---- | Lifted 'P.hold'.-phold :: P a -> P a-phold = liftP P.hold---- | Lifted 'P.interleave2'.------ > let p = pinterleave2 (pwhite 'α' 1 9 inf) (pseries 10 1 5)--- > in [3,10,9,11,2,12,9,13,4,14] `L.isPrefixOf` unP p-pinterleave2 :: P a -> P a -> P a-pinterleave2 = liftP2 P.interleave2---- | Lifted 'P.interleave'.------ > pinterleave [pwhitei 'α' 0 4 3,pwhitei 'β' 5 9 3] == toP [2,7,0,5,3,6]-pinterleave :: [P a] -> P a-pinterleave = toP . P.interleave . map unP---- | Lifted 'L.isPrefixOf'.-pisPrefixOf :: Eq a => P a -> P a -> Bool-pisPrefixOf p q = L.isPrefixOf (unP p) (unP q)---- | Lifted 'P.rsd'.------ > prsd (pstutter 2 (toP [1,2,3])) == toP [1,2,3]--- > prsd (pseq [1,2,3] 2) == toP [1,2,3,1,2,3]-prsd :: (Eq a) => P a -> P a-prsd = liftP P.rsd---- | Lifted 'P.trigger'.------ > let {tr = pbool (toP [0,1,0,0,1,1])--- >     ;p = ptrigger tr (toP [1,2,3])--- >     ;r = [Nothing,Just 1,Nothing,Nothing,Just 2,Just 3]}--- > in p == toP r-ptrigger :: P Bool -> P a -> P (Maybe a)-ptrigger p q =-    let r = pcountpre p-        f i x = preplicate i Nothing <> return (Just x)-    in join (pzipWith f r q)---- * SC3 Event Patterns--instance Audible (P Event) where-    play = e_play . Event_Seq . unP---- | Synonym for ('Key','P Field').-type P_Bind = (Key,P Field)--{-|-Padd.  Add a value to an existing key, or set the key if it doesn't exist.--> > p = Padd(\freq,801,Pbind(\freq,Pseq([100],1)));-> > p.asStream.all(()) == [('freq':901)]--> let p = padd (K_freq,801) (pbind [(K_freq,return 100)])-> in p == pbind [(K_freq,return 901)]--> > Padd(\freq,Pseq([401,801],2),Pbind(\freq,100)).play--> audition (padd (K_freq,pseq [401,801] 2) (pbind [(K_freq,100)]))--> let {d = pseq [pshuf 'α' [-7,-3,0,2,4,7] 2->               ,pseq [0,1,2,3,4,5,6,7] 1] 1->     ;p = pbind [(K_dur,0.15),(K_degree,d)]->     ;t n = padd (K_mtranspose,n) p}-> in audition (pseq [p,t 1,t 2] inf)--}-padd :: P_Bind -> P Event -> P Event-padd (k,p) = pzipWith (\i j -> e_edit k 0 (+ i) j) p--{-| Pbind.  SC3 pattern to assign keys to a set of 'Field' patterns-making an 'Event' pattern.--Each input pattern is assigned to key in the resulting event pattern.--There are a set of reserved keys that have particular roles in the-pattern library.--> > p = Pbind(\x,Pseq([1,2,3],1),\y,Pseed(Pn(100,1),Prand([4,5,6],inf)));-> > p.asStream.all(()) == [('y':4,'x':1),('y':6,'x':2),('y':4,'x':3)]--> let p = pbind [(K_param "x",prand 'α' [100,300,200] inf)->               ,(K_param "y",pseq [1,2,3] 1)]-> in pkey (K_param "x") p == toP [200,200,300]--'K_param' can be elided if /OverloadedStrings/ are in place.--> :set -XOverloadedStrings--> ptake 2 (pbind [("x",pwhitei 'α' 0 9 inf)->                ,("y",pseq [1,2,3] inf)])--'Event's implement variations on the @SC3@ 'Dur' and-'Sound.SC3.Lang.Control.Pitch.Pitch' models.--> > Pbind(\freq,Prand([300,500,231.2,399.2],inf),-> >       \dur,0.1).play;--> audition (pbind [(K_freq,prand 'α' [300,500,231.2,399.2] inf)->                 ,(K_dur,0.1)])--> > Pbind(\freq, Prand([300,500,231.2,399.2],inf),-> >       \dur,Prand([0.1,0.3],inf)).play;--> audition (pbind [(K_freq,prand 'α' [300,500,231.2,399.2] inf)->                 ,(K_dur,prand 'β' [0.1,0.3] inf)])--> > Pbind(\freq,Prand([1,1.2,2,2.5,3,4],inf) * 200,-> >       \dur,0.1).play;--> audition (pbind [(K_freq,prand 'α' [1,1.2,2,2.5,3,4] inf * 200)->                 ,(K_dur,0.1)])--> audition (pbind [(K_freq,pseq [440,550,660,770] 2)->                 ,(K_dur,pseq [0.1,0.15,0.1] inf)->                 ,(K_amp,pseq [0.1,0.05] inf)->                 ,(K_param "pan",pseq [-1,0,1] inf)])--A finite binding stops the `Event` pattern.--> > Pbind(\freq,Prand([300,500,231.2,399.2],inf),-> >       \dur,Pseq([0.1,0.2],3)).play;--> audition (pbind [(K_freq,prand 'α' [300,500,231.2,399.2] inf)->                 ,(K_dur,pseq [0.1,0.2] 3)])--> > Pbind(\freq,Prand([300,500,231.2,399.2],inf),-> >       \dur,Prand([0.1,0.3],inf)).play--All infinite inputs:--> audition (pbind [(K_freq,prand 'α' [300,500,231.2,399.2] inf)->                 ,(K_dur,prand 'β' [0.1,0.3] inf)])--Implicit /field/ patterns is this context are infinite.--> audition (pbind [(K_freq,prand 'α' [1,1.2,2,2.5,3,4] inf * 200)->                 ,(K_dur,0.1)])--> let test = let {freq = control KR "freq" 440->                ;amp = control KR "amp" 0.1->                ;nharms = control KR "nharms" 10->                ;pan = control KR "pan" 0->                ;gate = control KR "gate" 1->                ;s = blip AR freq nharms * amp->                ;e = linen gate 0.01 0.6 0.4 RemoveSynth->                ;o = offsetOut 0 (pan2 s pan e)}->            in synthdef "test" o--> audition (pbind [(K_instr,psynth test)->                 ,(K_freq,prand 'α' [1,1.2,2,2.5,3,4] inf * 200)->                 ,(K_dur,0.1)])--> audition (pbind [(K_instr,psynth test)->                 ,(K_param "nharms",pseq [4,10,40] inf)->                 ,(K_dur,pseq [1,1,2,1] inf / 10)->                 ,(K_freq,pn (pseries 1 1 16 * 50) 4)->                 ,(K_sustain,pseq [1/10,0.5,1,2] inf)])--> let acid = let {freq = control KR "freq" 1000->                ;gate = control KR "gate" 1->                ;pan = control KR "pan" 0->                ;cut = control KR "cut" 4000->                ;res = control KR "res" 0.8->                ;amp = control KR "amp" 1->                ;s = rlpf (pulse AR freq 0.05) cut res->                ;d = envLinen 0.01 1 0.3 1->                ;e = envGen KR gate amp 0 1 RemoveSynth d->                ;o = out 0 (pan2 s pan e)}->            in synthdef "acid" o--> > Pbind(\instrument,\acid,-> >       \dur,Pseq([0.25,0.5,0.25],4),-> >       \root,-24,-> >       \degree,Pseq([0,3,5,7,9,11,5,1],inf),-> >       \pan,Pfunc({1.0.rand2}),-> >       \cut,Pxrand([1000,500,2000,300],inf),-> >       \rez,Pfunc({0.7.rand +0.3}),-> >       \amp,0.2).play--> audition (pbind [(K_instr,psynth acid)->                 ,(K_dur,pseq [0.25,0.5,0.25] 4)->                 ,(K_root,-24)->                 ,(K_degree,pseq [0,3,5,7,9,11,5,1] inf)->                 ,(K_param "pan",pwhite 'α' (-1.0) 1.0 inf)->                 ,(K_param "cut",pxrand 'β' [1000,500,2000,300] inf)->                 ,(K_param "res",pwhite 'γ' 0.3 1.0 inf)->                 ,(K_amp,0.2)])--> > Pseq([Pbind(\instrument,\acid,-> >             \dur,Pseq([0.25,0.5,0.25],4),-> >             \root,-24,-> >             \degree,Pseq([0,3,5,7,9,11,5,1],inf),-> >             \pan,Pfunc({1.0.rand2}),-> >             \cut,Pxrand([1000,500,2000,300],inf),-> >             \rez,Pfunc({0.7.rand + 0.3}),-> >             \amp,0.2),-> >       Pbind(\instrument,\acid,-> >             \dur,Pseq([0.25],6),-> >             \root,-24,-> >             \degree,Pseq([18,17,11,9],inf),-> >             \pan,Pfunc({1.0.rand2}),-> >             \cut,1500,-> >             \rez,Pfunc({0.7.rand + 0.3}),-> >             \amp,0.16)],inf).play--> audition (pseq [pbind [(K_instr,psynth acid)->                       ,(K_dur,pseq [0.25,0.5,0.25] 4)->                       ,(K_root,-24)->                       ,(K_degree,pseq [0,3,5,7,9,11,5,1] inf)->                       ,(K_param "pan",pwhite 'α' (-1.0) 1.0 inf)->                       ,(K_param "cut",pxrand 'β' [1000,500,2000,300] inf)->                       ,(K_param "res",pwhite 'γ' 0.3 1.0 inf)->                       ,(K_amp,0.2)]->                ,pbind [(K_instr,psynth acid)->                       ,(K_dur,pn 0.25 6)->                       ,(K_root,-24)->                       ,(K_degree,pser [18,17,11,9] inf)->                       ,(K_param "pan",pwhite 'δ' (-1.0) 1.0 inf)->                       ,(K_param "cut",1500)->                       ,(K_param "res",pwhite 'ε' 0.3 1.0 inf)->                       ,(K_amp,0.16)]] inf)--> > Pbind(\instrument, \acid,-> >       \dur, Pseq([0.25,0.5,0.25], inf),-> >       \root, [-24,-17],-> >       \degree, Pseq([0,3,5,7,9,11,5,1], inf),-> >       \pan, Pfunc({1.0.rand2}),-> >       \cut, Pxrand([1000,500,2000,300], inf),-> >       \rez, Pfunc({0.7.rand +0.3}),-> >       \amp, 0.2).play;--> audition (pbind [(K_instr,psynth acid)->                 ,(K_dur,pseq [0.25,0.5,0.25] inf)->                 ,(K_root,pmce2 (-24) (-17))->                 ,(K_degree,pseq [0,3,5,7,9,11,5,1] inf)->                 ,(K_param "pan",pwhite 'α' (-1.0) 1.0 inf)->                 ,(K_param "cut",pxrand 'β' [1000,500,2000,300] inf)->                 ,(K_param "res",pwhite 'γ' 0.3 1.0 inf)->                 ,(K_amp,0.2)])--A persistent synthesis node with /freq/ and /amp/ controls.--> import Sound.SC3.ID--> let {freq = control KR "freq" 440->     ;amp = control KR "amp" 0.6->     ;n = pinkNoise 'α' AR * amp}-> in audition (out 0 (pan2 (moogFF n freq 2 0) 0 1))--A pattern to set /freq/ and /amp/ controls at the most recently-instantiated synthesis node.--> :set -XOverloadedStrings--> audition (pbind [(K_type,prepeat "n_set")->                 ,(K_id,(-1))->                 ,(K_freq,pwhite 'α' 100 1000 inf)->                 ,(K_dur,0.2)->                 ,(K_amp,toP [1,0.99 .. 0.1])])--> let berlinb =->   let {k = control KR->       ;o = k "out" 0->       ;f = k "freq" 80->       ;a = k "amp" 0.01->       ;p = k "pan" 0->       ;g = k "gate" 1->       ;env = decay2 g 0.05 8 * 0.0003->       ;syn = rlpf (lfPulse AR f 0 (sinOsc KR 0.12 (mce2 0 (pi/2)) * 0.48 + 0.5))->                   (f * (sinOsc KR 0.21 0 * 18 + 20))->                   0.07->       ;syn_env = syn * env->       ;kil = detectSilence (mceChannel 0 syn_env) 0.1 0.2 RemoveSynth}->   in mrg2 (out o (a * mix (panAz 4 syn_env (mce2 p (p + 1)) 1 2 0.5))) kil--> audition (ppar [pbind [(K_degree,pseq [0,1,2,4,6,3,4,8] inf)->                       ,(K_dur,0.5)->                       ,(K_octave,3)->                       ,(K_instr,psynth (synthdef "berlinb" berlinb))]->                ,pbind [(K_degree,pseq [0,1,2,4,6,3,4,8] inf)->                       ,(K_dur,0.5)->                       ,(K_octave,pmce2 2 1)->                       ,(K_param "pan",pwhite 'a' (-1) 1 inf)->                       ,(K_instr,psynth (synthdef "berlinb" berlinb))]])---}-pbind :: [P_Bind] -> P Event-pbind xs =-    let xs' = fmap (\(k,v) -> pzip (undecided k) v) xs-        xs'' = ptranspose_st_repeat xs'-    in fmap e_from_list xs''---- | Operator to lift 'F_Value' pattern to 'P_Bind' tuple.------ > let {r = True `pcons` preplicate 3 False :: P Bool}--- > in pbind [K_rest <| r] == pbind [(K_rest,pseq [1,0,0,0] 1)]-(<|) :: F_Value v => Key -> P v -> P_Bind-(<|) k p = (k,fmap toF p)-infixl 3 <|---- | Pkey.  SC3 pattern to read 'Key' at 'Event' pattern.  Note--- however that in haskell is usually more appropriate to name the--- pattern using /let/.------ > pkey K_freq (pbind [(K_freq,return 440)]) == toP [440]--- > pkey K_amp (pbind [(K_amp,toP [0,1])]) == toP [0,1]------ > > Pbind(\degree,Pseq([Pseries(-7,1,14),Pseries(7,-1,14)],inf),--- > >       \dur,0.25,--- > >       \legato,Pkey(\degree).linexp(-7,7,2.0,0.05)).play------ > let {d = pseq [pseries (-7) 1 14,pseries 7 (-1) 14] inf--- >     ;l = fmap (Sound.SC3.Lang.Math.linexp (-7) 7 2 0.05) d}--- > in audition (pbind [(K_degree,d)--- >                    ,(K_dur,0.25)--- >                    ,(K_legato,l)])-pkey :: Key -> P Event -> P Field-pkey k = fmap (fromJust . e_get k)---- | Pmono.  SC3 pattern that is a variant of 'pbind' for controlling--- monophonic (persistent) synthesiser nodes.------ > let p = [(K_instr,pinstr' (Instr_Ref "default" False))--- >         ,(K_id,100)--- >         ,(K_degree,pxrand 'α' [0,2,4,5,7,9,11] inf)--- >         ,(K_amp,pwrand 'β' [0.05,0.2] [0.7,0.3] inf)--- >         ,(K_dur,0.25)]--- > in audition (pmono p)-pmono :: [P_Bind] -> P Event-pmono b =-    let ty = fmap F_String ("s_new" `pcons` prepeat "n_set")-    in pbind ((K_type,ty) : b)---- | Pmul.  SC3 pattern to multiply an existing key by a value, or set--- the key if it doesn't exist.------ > let p = pbind [(K_dur,0.15),(K_freq,prand 'α' [440,550,660] 6)]--- > in audition (pseq [p,pmul (K_freq,2) p,pmul (K_freq,0.5) p] 2)-pmul :: P_Bind -> P Event -> P Event-pmul (k,p) = pzipWith (\i j -> e_edit k 1 (* i) j) p--{-| Ppar.  Variant of 'ptpar' with zero start times.--The result of `pmerge` can be merged again, `ppar` merges a list of-patterns.--> let {a = pbind [(K_param "a",pseq [1,2,3] inf)]->     ;b = pbind [(K_param "b",pseq [4,5,6] inf)]->     ;r = toP [e_from_list [(K_param "a",1),(K_fwd',0)]->              ,e_from_list [(K_param "b",4),(K_fwd',1)]]}-> in ptake 2 (ppar [a,b]) == r--> let {p = pbind [(K_dur,0.2),(K_midinote,pseq [62,65,69,72] inf)]->     ;q = pbind [(K_dur,0.4),(K_midinote,pseq [50,45] inf)]->     ;r = pbind [(K_dur,0.6),(K_midinote,pseq [76,79,81] inf)]}-> in audition (ppar [p,q,r])--Multiple nested `ppar` patterns.--> let {a u = pbind [(K_dur,0.2),(K_param "pan",0.5),(K_midinote,pseq u 1)]->     ;b l = pbind [(K_dur,0.4),(K_param "pan",-0.5),(K_midinote,pseq l 1)]->     ;f u l = ppar [a u,b l]->     ;h = pbind [(K_dur,prand 'α' [0.2,0.4,0.6] inf)->                ,(K_midinote,prand 'β' [72,74,76,77,79,81] inf)->                ,(K_db,-26)->                ,(K_legato,1.1)]->     ;m = pseq [pbind [(K_dur,3.2),(K_freq,return nan)]->               ,prand 'γ' [f [60,64,67,64] [48,43]->                          ,f [62,65,69,65] [50,45]->                          ,f [64,67,71,67] [52,47]] 12] inf}-> in audition (ppar [h,m])---}-ppar :: [P Event] -> P Event-ppar l = ptpar (zip (repeat 0) l)---- | Pstretch.  SC3 pattern to do time stretching.  It is equal to--- 'pmul' at 'K_stretch'.------ > let {d = pseq [pshuf 'α' [-7,-3,0,2,4,7] 2--- >               ,pseq [0,1,2,3,4,5,6,7] 1] 1--- >     ;p = pbind [(K_dur,0.15),(K_degree,d)]}--- > in audition (pseq [p,pstretch 0.5 p,pstretch 2 p] inf)-pstretch :: P Field -> P Event -> P Event-pstretch p = pmul (K_stretch,p)--{-| Ptpar.  Merge a set of 'Event' patterns each with indicated--- start 'Time'.--`ptpar` is a variant of `ppar` which allows non-equal start times.--> let {f d p n = pbind [(K_dur,d),(K_param "pan",p),(K_midinote,n)]->     ;a = f 0.2 (-1) (pseries 60 1 15)->     ;b = f 0.15 0 (pseries 58 2 15)->     ;c = f 0.1 1 (pseries 46 3 15)}-> in audition (ptpar [(0,a),(1,b),(2,c)])--> let {d = pseq [pgeom 0.05 1.1 24,pgeom 0.5 0.909 24] 2->     ;f n a p = pbind [(K_dur,d)->                      ,(K_db,a)->                      ,(K_param "pan",p)->                      ,(K_midinote,pseq [n,n-4] inf)]}-> in audition (ptpar [(0,f 53 (-20) (-0.9))->                    ,(2,f 60 (-23) (-0.3))->                    ,(4,f 67 (-26) 0.3)->                    ,(6,f 74 (-29) 0.9)])---}-ptpar :: [(Time,P Event)] -> P Event-ptpar l =-    case l of-      [] -> mempty-      [(_,p)] -> p-      (pt,p):(qt,q):r -> ptpar ((min pt qt,ptmerge (pt,p) (qt,q)) : r)---- * Instrument Event Patterns---- | Pattern from 'Instr'.  An 'Instr' is either a 'Synthdef' or a--- /name/.  In the 'Synthdef' case the instrument is asynchronously--- sent to the server before processing the event, which has timing--- implications.  The pattern constructed here uses the 'Synthdef' for--- the first element, and the subsequently the /name/.------ > audition (pbind [(K_instr,pinstr' defaultInstr)--- >                 ,(K_degree,toP [0,2,4,7])--- >                 ,(K_dur,0.25)])-pinstr' :: Instr -> P Field-pinstr' i = toP (map F_Instr (i_repeat i))--{-| 'Instr' pattern from instrument /name/.  See also `psynth` (where-the /sine/ instrument below is defined).--> let {si = return (F_Instr (Instr_Ref "sine" True))->     ;di = return (F_Instr (Instr_Ref "default" True))->     ;i = pseq [si,si,di] inf->     ;p = pbind [(K_instr,i),(K_degree,pseq [0,2,4,7] inf),(K_dur,0.25)]}-> in audition p---}-pinstr :: String -> P Field-pinstr s = pinstr' (Instr_Ref s True)--{-| `Synthdef`s can be used directly as an instrument using `psynth`.-The default synthdef is at 'Data.Default.def'.--> let sineSynth =->   let {f = control KR "freq" 440->       ;g = control KR "gate" 1->       ;a = control KR "amp" 0.1->       ;d = envASR 0.01 1 1 (EnvNum (-4))->       ;e = envGen KR g a 0 1 RemoveSynth d->       ;o = out 0 (sinOsc AR f 0 * e)}->   in synthdef "sine" o--> audition (pbind [(K_instr,psynth sineSynth)->                 ,(K_degree,toP [0,2,4,7])->                 ,(K_dur,0.25)])---}-psynth :: Synthdef -> P Field-psynth s = pinstr' (Instr_Def s True)---- * MCE Patterns---- | Two-channel MCE for /field/ patterns.------ > pmce2 (toP [1,2]) (toP [3,4]) == toP [f_array [1,3],f_array [2,4]]------ > let p = pmce2 (pseq [1,2] inf) (pseq [3,4] inf)--- > in ptake 2 p == toP [f_array [1,3],f_array [2,4]]-pmce2 :: P Field -> P Field -> P Field-pmce2 p = pzipWith (\m n -> F_Vector [m,n]) p---- | Three-channel MCE for /field/ patterns.-pmce3 :: P Field -> P Field -> P Field -> P Field-pmce3 p q = pzipWith3 (\m n o -> F_Vector [m,n,o]) p q--{-|--Remove one layer of MCE expansion at an /event/ pattern.  The-pattern will be expanded only to the width of the initial input.-Holes are filled with rests.--> let {a = pseq [65,69,74] inf->     ;b = pseq [60,64,67,72,76] inf->     ;c = pseq [pmce3 72 76 79,pmce2 a b] 1}-> in audition (p_un_mce (pbind [(K_midinote,c)->                              ,(K_param "pan",pmce2 (-1) 1)->                              ,(K_dur,1 `pcons` prepeat 0.15)]))--`p_un_mce` translates via `ppar`.  This allows `dur` related fields to-be MCE values.  The underlying event processor also implements one-layer of MCE expansion.--> audition (p_un_mce->           (pbind [(K_dur,pmce2 0.25 0.2525)->                  ,(K_legato,pmce2 0.25 2.5)->                  ,(K_freq,pmce2 (pseq [300,400,500] inf)->                                 (pseq [302,402,502,202] inf))->                  ,(K_param "pan",pmce2 (-0.5) 0.5)]))---}-p_un_mce :: P Event -> P Event-p_un_mce p =-    let l' = P.transpose_fw_def' e_rest (map e_un_mce' (unP p))-    in toP (e_par (zip (repeat 0) l'))---- * Non-SC3 Event Patterns---- | Edit 'a' at 'Key' in each element of an 'Event' pattern.-pedit :: Key -> (Field -> Field) -> P Event -> P Event-pedit k f = fmap (e_edit' k f)---- | Pattern of start times of events at event pattern.------ > p_time (pbind [(K_dur,toP [1,2,3,2,1])]) == toP [0,1,3,6,8,9]--- > p_time (pbind [(K_dur,pseries 0.5 0.5 5)]) == toP [0,0.5,1.5,3,5,7.5]-p_time :: P Event -> P Time-p_time =  pscanl (+) 0 . fmap (fwd . e_dur Nothing)---- | Pattern to extract 'a's at 'Key' from an 'Event'--- pattern.------ > pkey_m K_freq (pbind [(K_freq,return 440)]) == toP [Just 440]-pkey_m :: Key -> P Event -> P (Maybe Field)-pkey_m k = fmap (e_get k)--{-| Variant of 'ptmerge' with zero start times.--`pmerge` merges two event streams, adding /fwd'/ entries as required.--> let {p = pbind [(K_dur,0.2),(K_midinote,pseq [62,65,69,72] inf)]->     ;q = pbind [(K_dur,0.4),(K_midinote,pseq [50,45] inf)]}-> in audition (pmerge p q)---}-pmerge :: P Event -> P Event -> P Event-pmerge p q = ptmerge (0,p) (0,q)---- | Variant that does not insert key.-pmul' :: P_Bind -> P Event -> P Event-pmul' (k,p) = pzipWith (\i j -> e_edit' k (* i) j) p---- | Merge two 'Event' patterns with indicated start 'Time's.-ptmerge :: (Time,P Event) -> (Time,P Event) -> P Event-ptmerge (pt,p) (qt,q) =-    toP (e_merge (pt,F.toList p) (qt,F.toList q))---- | Left-biased union of event patterns.-punion :: P Event -> P Event -> P Event-punion = pzipWith (<>)---- | 'punion' of 'pbind' of 'return', ie. @p_with (K_Instr,psynth s)@.-p_with :: P_Bind -> P Event -> P Event-p_with = punion . pbind . return---- * Aliases---- | Type specialised 'mappend', sequences two patterns,--- ie. 'Data.List.++'.------ > 1 <> mempty <> 2 == toP [1,2]------ > let {p = prand 'α' [0,1] 3--- >     ;q = prand 'β' [5,7] 3}--- > in audition (pbind [(K_degree,pappend p q),(K_dur,0.15)])-pappend :: P a -> P a -> P a-pappend = mappend---- | Type specialised 'mconcat' (or equivalently 'msum' or--- 'Data.List.concat').------ > mconcat [pseq [1,2] 1,pseq [3,4] 2] == toP [1,2,3,4,3,4]--- > msum [pseq [1,2] 1,pseq [3,4] 2] == toP [1,2,3,4,3,4]-pconcat :: [P a] -> P a-pconcat = mconcat---- | Type specialised `mempty`, ie. 'Data.List.[]'.-pempty :: P a-pempty = mempty---- | Type specialised 'F.foldr'.------ > > (Pser([1,2,3],5) + Pseq([0,10],3)).asStream.all == [1,12,3,11,2]------ > let p = pser [1,2,3] 5 + pseq [0,10] 3--- > in F.foldr (:) [] p == [1,12,3,11,2]------ Indefinte patterns may be folded.------ > take 3 (F.foldr (:) [] (prepeat 1)) == [1,1,1]------ The `Foldable` module includes functions for 'F.product', 'F.sum',--- 'F.any', 'F.elem' etc.------ > F.product (toP [1,3,5]) == 15--- > floor (F.sum (ptake 100 (pwhite 'α' 0.25 0.75 inf))) == 51--- > F.any even (toP [1,3,5]) == False--- > F.elem 5 (toP [1,3,5]) == True-pfoldr :: (a -> b -> b) -> b -> P a -> b-pfoldr = F.foldr---- | Type specialised 'join'.------ > join (replicate 2 [1,2]) == [1,2,1,2]--- > join (preplicate 2 (toP [1,2])) == toP [1,2,1,2]-pjoin :: P (P a) -> P a-pjoin = join---- | 'join' that pushes an outer 'undecided' inward.------ > join (undecided (undecided 1)) == undecided 1--- > join (undecided (return 1)) == return 1--- > pjoin_repeat (undecided (return 1)) == pure 1 == _|_-pjoin_repeat :: P (P a) -> P a-pjoin_repeat p =-    case p of-      P (Left (P (Right l))) -> toP (cycle l)-      _ -> join p---- | Type specialised 'fmap', ie. 'Data.List.map'.-pmap :: (a -> b) -> P a -> P b-pmap = fmap---- | Type specialised '>>='.------ > (return 1 >>= return . id) == [1]--- > (undecided 1 >>= undecided . id) == undecided 1------ > (pseq [1,2] 1 >>= \x ->--- >   pseq [3,4,5] 1 >>= \y ->--- >    return (x,y)) == toP [(1,3),(1,4),(1,5),(2,3),(2,4),(2,5)]-pmbind :: P a -> (a -> P b) -> P b-pmbind = (>>=)---- | Type specialised 'pure'.-ppure :: a -> P a-ppure = pure---- | Type specialised 'return'.-preturn :: a -> P a-preturn = return---- | Type specialised 'T.traverse'.------ > let {f i e = (i + e,e * 2)--- >     ;(r,p) = T.mapAccumL f 0 (toP [1,3,5])}--- > in (r,p) == (9,toP [2,6,10])-ptraverse :: Applicative f => (a -> f b) -> P a -> f (P b)-ptraverse = T.traverse---- * NRT--{-| Transform an /event/ pattern into a /non-real time/ SC3 score.--> let n = pNRT (pbind [(K_freq,prand 'α' [300,500,231.2,399.2] inf)->                     ,(K_dur,pseq [0.1,0.2] 3)])-> audition n-> mapM_ (putStrLn . bundlePP) (nrt_bundles n)--Infinite 'NRT' scores are productive for 'audition'ing.--> let n' = pNRT (pbind [(K_dur,0.25),(K_freq,pseq [300,600,900] inf)])-> audition n'-> mapM_ (putStrLn . bundlePP) (take 9 (nrt_bundles n'))---}-pNRT :: P Event -> NRT-pNRT = e_nrt . Event_Seq . unP---- * UId variants---- | 'liftUId' of 'pbrown'.-pbrownM :: (UId m,Num n,Ord n,Random n) => n -> n -> n -> Int -> m (P n)-pbrownM = liftUId4 pbrown---- | 'liftUId' of 'pexprand'.-pexprandM :: (UId m,Random a,Floating a) => a -> a -> Int -> m (P a)-pexprandM = liftUId3 pexprand---- | 'liftUId' of 'prand'.-prandM :: UId m => [P a] -> Int -> m (P a)-prandM = liftUId2 prand---- | 'liftUId' of 'pshuf'.-pshufM :: UId m => [a] -> Int -> m (P a)-pshufM = liftUId2 pshuf---- | 'liftUId' of 'pwhite'.-pwhiteM :: (UId m,Random n) => n -> n -> Int -> m (P n)-pwhiteM = liftUId3 pwhite---- | 'liftUId' of 'pwhitei'.-pwhiteiM :: (UId m,RealFracE n,Random n) => n -> n -> Int -> m (P n)-pwhiteiM = liftUId3 pwhitei---- | 'liftUId' of 'pwrand'.-pwrandM :: UId m => [P a] -> [Double] -> Int -> m (P a)-pwrandM = liftUId3 pwrand---- | 'liftUId' of 'pxrand'.-pxrandM :: UId m => [P a] -> Int -> m (P a)-pxrandM = liftUId2 pxrand

@@ -2,15 +2,13 @@ module Sound.SC3.Lang.Pattern.List where  import qualified Data.Map as M {- containers -}-import Data.Maybe {- base -}-import Data.Monoid {- base -} import Data.List {- base -} import qualified Sound.SC3 as S {- hsc3 -} import System.Random {- random -}  import qualified Sound.SC3.Lang.Collection as C-import qualified Sound.SC3.Lang.Math as M-import qualified Sound.SC3.Lang.Random.Gen as R+import Sound.SC3.Lang.Core+import qualified Sound.SC3.Lang.Pattern.Stream as I  -- * Data.Bool variants @@ -47,112 +45,6 @@ fwrap :: (Functor f,Ord a,Num a) => f a -> a -> a -> f a fwrap xs l r = fmap (S.genericWrap l r) xs --- * Data.List variants---- | Inverse of 'Data.List.:'.------ > map uncons [[],1:[]] == [(Nothing,[]),(Just 1,[])]-uncons :: [a] -> (Maybe a,[a])-uncons l =-    case l of-      [] -> (Nothing,[])-      x:l' -> (Just x,l')---- | 'Maybe' variant of '!!'.------ > map (lindex "str") [2,3] == [Just 'r',Nothing]-lindex :: [a] -> Int -> Maybe a-lindex l n =-    if n < 0-    then Nothing-    else case (l,n) of-           ([],_) -> Nothing-           (x:_,0) -> Just x-           (_:l',_) -> lindex l' (n - 1)---- | List section with /wrapped/ indices.------ > segment [0..4] 5 (3,5) == [3,4,0]-segment :: [a] -> Int -> (Int,Int) -> [a]-segment a k (l,r) =-    let i = map (S.genericWrap 0 (k - 1)) [l .. r]-    in map (a !!) i---- | If /n/ is 'maxBound' this is 'id', else it is 'take'.-take_inf :: Int -> [a] -> [a]-take_inf n = if n == maxBound then id else take n---- | Variant of 'transpose' for /fixed width/ interior lists.  Holes--- are represented by 'Nothing'.------ > transpose_fw undefined [] == []------ > transpose [[1,3],[2,4]] == [[1,2],[3,4]]--- > transpose_fw 2 [[1,3],[2,4]] == [[Just 1,Just 2],[Just 3,Just 4]]------ > transpose [[1,5],[2],[3,7]] == [[1,2,3],[5,7]]------ > transpose_fw 2 [[1,4],[2],[3,6]] == [[Just 1,Just 2,Just 3]--- >                                     ,[Just 4,Nothing,Just 6]]------ This function is more productive than 'transpose' for the case of--- an infinite list of finite lists.------ > map head (transpose_fw 4 (repeat [1..4])) == map Just [1,2,3,4]--- > map head (transpose (repeat [1..4])) == _|_-transpose_fw :: Int -> [[a]] -> [[Maybe a]]-transpose_fw w l =-    if null l-    then []-    else let f n = map (`lindex` n) l-         in map f [0 .. w - 1]---- | Variant of 'transpose_fw' with default value for holes.-transpose_fw_def :: a -> Int -> [[a]] -> [[a]]-transpose_fw_def def w l =-    let f n = map (fromMaybe def . (`lindex` n)) l-    in map f [0 .. w - 1]---- | Variant of 'transpose_fw_def' deriving /width/ from first element.-transpose_fw_def' :: a -> [[a]] -> [[a]]-transpose_fw_def' def l =-    case l of-      [] -> []-      h:_ -> transpose_fw_def def (length h) l---- | A 'transpose' variant, halting when first hole appears.------ > trs [[1,2,3],[4,5,6],[7,8]] == [[1,4,7],[2,5,8]]-transpose_st :: [[a]] -> [[a]]-transpose_st l =-    let (h,l') = unzip (map uncons l)-    in case all_just h of-         Just h' -> h' : transpose_st l'-         Nothing -> []---- * Data.Maybe variants---- | Variant of 'catMaybes' that returns 'Nothing' unless /all/--- elements are 'Just'.------ > map all_just [[Nothing,Just 1],[Just 0,Just 1]] == [Nothing,Just [0,1]]-all_just :: [Maybe a] -> Maybe [a]-all_just =-    let rec r l =-            case l of-              [] -> Just (reverse r)-              Nothing:_ -> Nothing-              Just e:l' -> rec (e:r) l'-    in rec []---- * Data.Monoid variants---- | 'mconcat' of 'repeat', for lists this is 'cycle'.------ > [1,2,3,1,2] `isPrefixOf` take 5 (mcycle [1,2,3])-mcycle :: Monoid a => a -> a-mcycle = mconcat . repeat- -- * Non-SC3 Patterns  -- | Count the number of `False` values following each `True` value.@@ -209,15 +101,6 @@ interleave :: [[a]] -> [a] interleave = concat . transpose --- | Remove successive duplicates.------ > rsd (stutter (repeat 2) [1,2,3]) == [1,2,3]--- > rsd [1,2,3,1,2,3] == [1,2,3,1,2,3]-rsd :: (Eq a) => [a] -> [a]-rsd =-    let f (p,_) i = (Just i,if Just i == p then Nothing else Just i)-    in mapMaybe snd . scanl f (Nothing,Nothing)- -- | Pattern where the 'tr' pattern determines the rate at which -- values are read from the `x` pattern.  For each sucessive true -- value at 'tr' the output is a (`Just` e) of each succesive element at@@ -237,7 +120,7 @@ -- -- > [4,4,1,8,5] `isPrefixOf` brown 'α' 0 9 15 brown :: (Enum e,Random n,Num n,Ord n) => e -> n -> n -> n -> [n]-brown e l r s = brown' e (repeat l) (repeat r) (repeat s)+brown e l r s = I.brown e (repeat l) (repeat r) (repeat s)  -- | PdurStutter.  SC3 pattern to partition a value into /n/ equal -- subdivisions.  Subdivides each duration by each stutter and yields@@ -248,19 +131,19 @@ -- >     ;d = [0.5,1,2,0.25,0.25]} -- > in durStutter s d == [0.5,1.0,2.0,0.25,0.25] durStutter :: Fractional a => [Int] -> [a] -> [a]-durStutter p =+durStutter =     let f s d = case s of                 0 -> []                 1 -> [d]                 _ -> replicate s (d / fromIntegral s)-    in concat . zipWith f p+    in concat .: zipWith f  -- | Pexprand.  SC3 pattern of random values that follow a exponential -- distribution. -- -- > exprand 'α' 0.0001 1 10 exprand :: (Enum e,Random a,Floating a) => e -> a -> a -> Int -> [a]-exprand e l r n = fmap (M.exprange l r) (white e 0 1 n)+exprand e l r n = take_inf n (I.exprand e l r)  -- | Pfuncn.  Variant of the SC3 pattern that evaluates a closure at -- each step that has a 'StdGen' form.@@ -286,10 +169,7 @@ -- -- > rand' 'α' [1..9] 9 == [3,9,2,9,4,7,4,3,8] rand' :: Enum e => e -> [a] -> Int -> [a]-rand' e a n =-    let k = length a - 1-        i = white e 0 k n-    in map (a !!) i+rand' e a n = take_inf n (I.rand e a)  -- | Pseq.  'concat' of 'replicate' of 'concat'. --@@ -302,20 +182,14 @@ -- > slide [1,2,3,4] 4 3 1 0 True == [1,2,3,2,3,4,3,4,1,4,1,2] -- > slide [1,2,3,4,5] 3 3 (-1) 0 True == [1,2,3,5,1,2,4,5,1] slide :: [a] -> Int -> Int -> Int -> Int -> Bool -> [a]-slide a n j s i wr =-    let k = length a-        l = enumFromThen i (i + s)-        r = map (+ (j - 1)) l-    in if wr-       then concat (take n (map (segment a k) (zip l r)))-       else error "slide: non-wrap variant not implemented"+slide a n j s i wr = concat (take n (I.slide a j s i wr))  -- | Pstutter.  Repeat each element of a pattern /n/ times. -- -- > stutter [1,2,3] [4,5,6] == [4,5,5,6,6,6] -- > stutter (repeat 2) [4,5,6] == [4,4,5,5,6,6] stutter :: [Int] -> [a] -> [a]-stutter ns = concat . zipWith replicate ns+stutter = concat .: zipWith replicate  -- | Pswitch.  SC3 pattern to select elements from a list of patterns -- by a pattern of indices.@@ -356,18 +230,18 @@ -- > white 'α' 1 9 5  == [3,9,2,9,4] -- > let p = white 'α' 0.0 1.0 3 in zipWith (-) p p == [0,0,0] white :: (Random n,Enum e) => e -> n -> n -> Int -> [n]-white e l r n = take_inf n (randomRs (l,r) (mkStdGen (fromEnum e)))+white e l r n = take_inf n (I.white e l r)  -- | Pwrand.  SC3 pattern to embed values randomly chosen from a list. -- Returns one item from the list at random for each repeat, the -- probability for each item is determined by a list of weights which--- should sum to 1.0.+-- should sum to 1.0 and must be equal in length to the selection list. -- -- > let w = C.normalizeSum [1,3,5] -- > in wrand 'ζ' [[1],[2],[3,4]] w 6 == [3,4,2,2,3,4,1,3,4] wrand :: (Enum e,Fractional n,Ord n,Random n) =>          e -> [[a]] -> [n] -> Int -> [a]-wrand e a w n = concat (take_inf n (wrand' e a w))+wrand e a w n = concat (take_inf n (I.wrand_generic e a w))  -- | Pxrand.  SC3 pattern that is like 'rand' but filters successive -- duplicates.@@ -378,26 +252,6 @@  -- * SC3 Variant Patterns --- | Underlying 'brown''.-brown_ :: (RandomGen g,Random n,Num n,Ord n) => (n,n,n) -> (n,g) -> (n,g)-brown_ (l,r,s) (n,g) =-    let (i,g') = randomR (-s,s) g-    in (S.foldToRange l r (n + i),g')---- | Brown noise with list inputs.------ > let l = brown' 'α' (repeat 1) (repeat 700) (cycle [1,20])--- > in [415,419,420,428] `isPrefixOf` l-brown' :: (Enum e,Random n,Num n,Ord n) => e -> [n] -> [n] -> [n] -> [n]-brown' e l_ r_ s_ =-    let i = (randomR (head l_,head r_) (mkStdGen (fromEnum e)))-        rec (n,g) z =-            case z of-              [] -> []-              (l,r,s):z' -> let (n',g') = brown_ (l,r,s) (n,g)-                            in n' : rec (n',g') z'-    in rec i (zip3 l_ r_ s_)- -- | Underlying 'if_demand'. if_rec :: ([Bool],[a],[a]) -> Maybe (a,([Bool],[a],[a])) if_rec i =@@ -428,13 +282,13 @@ rorate_n' p i = [i * p,i * (1 - p)]  rorate_n :: Num a => [a] -> [a] -> [a]-rorate_n p = concat . zipWith rorate_n' p+rorate_n = concat .: zipWith rorate_n'  rorate_l' :: Num a => [a] -> a -> [a] rorate_l' p i = map (* i) p  rorate_l :: Num a => [[a]] -> [a] -> [a]-rorate_l p = concat . zipWith rorate_l' p+rorate_l = concat .: zipWith rorate_l'  -- | 'white' with pattern inputs. --@@ -456,19 +310,8 @@ -- -- > whitei 'α' 1 9 5 == [5,1,7,7,8] whitei :: (Random n,S.RealFracE n,Enum e) => e -> n -> n -> Int -> [n]-whitei e l r = fmap S.floorE . white e l r---- | Underlying 'wrand'.-wrand' :: (Enum e,Fractional n,Ord n,Random n) => e -> [[a]] -> [n] -> [[a]]-wrand' e a w =-    let f g = let (r,g') = R.wchoose a w g-              in r : f g'-    in f (mkStdGen (fromEnum e))+whitei = fmap S.floorE .::: white  -- | Underlying 'xrand'. xrand' :: Enum e => e -> [[a]] -> [a]-xrand' e a =-    let k = length a - 1-        f j g = let (i,g') = randomR (0,k) g-                in if i == j then f j g' else (a !! i) ++ f i g'-    in f (-1) (mkStdGen (fromEnum e))+xrand' e = concat . I.xrand e

@@ -0,0 +1,7 @@+-- | Composite of Pattern.P modules.+-- See <http://rd.slavepianos.org/?t=hsc3-texts> for tutorial.+module Sound.SC3.Lang.Pattern.P (module P) where++import Sound.SC3.Lang.Pattern.P.Core as P+import Sound.SC3.Lang.Pattern.P.Base as P+import Sound.SC3.Lang.Pattern.P.SC3 as P

@@ -0,0 +1,333 @@+-- | Pattern functions.+--+-- Haskell: `pappend`, `pconcat`, `pcons`, `pcycle`,+-- `pempty`,`pfilter`, `pjoin`, `prepeat`, `preplicate`, `pscanl`,+-- `psplitPlaces`, `ptail`, `ptake`, `pzip`, `pzipWith`.+--+-- Non SC3: `pbool`, `pcountpost`, `pcountpre`,`phold`, `pinterleave`,+-- `prsd`, `ptrigger`.+module Sound.SC3.Lang.Pattern.P.Base where++import Control.Applicative {- base -}+import Control.Monad {- base -}+import qualified Data.Foldable as F {- base -}+import qualified Data.List as L {- base -}+import qualified Data.List.Split as S {- split -}+import Data.Monoid {- base -}+import qualified Data.Traversable as T {- base -}++import Sound.SC3.Lang.Pattern.P.Core++import Sound.SC3.Lang.Core+import qualified Sound.SC3.Lang.Pattern.List as P+import qualified Sound.SC3.Lang.Pattern.Stream as I++-- * Math++-- | Type specialised 'maxBound', a pseudo-/infinite/ value for use at+-- pattern repeat counts.+--+-- > inf == maxBound+inf :: Int+inf = maxBound++{-| Constant /NaN/ (not a number) value.++> isNaN nan == True++A frequency value of NaN indicates a rest. This constant value can be+used as a rest indicator at a frequency model input (not at a @rest@+key).++> audition (pbind [(K_dur,pseq [0.1,0.7] inf)+>                 ,(K_legato,0.2)+>                 ,(K_degree,pseq [0,2,return nan] inf)])++-}+nan :: Floating a => a+nan = sqrt (-1)++-- * Data.List Patterns++-- | Pattern variant of 'Data.List.:'.+--+-- > pcons 'α' (pn (return 'β') 2) == toP "αββ"+pcons :: a -> P a -> P a+pcons = mappend . return++-- | Pattern variant of 'Data.List.null'.+--+-- > pnull mempty == True+-- > pnull (undecided 'a') == False+-- > pnull (pure 'a') == False+-- > pnull (return 'a') == False+pnull :: P a -> Bool+pnull = null . unP++-- | Alias for 'pure', pattern variant of 'Data.List.repeat'.+--+-- > ptake 5 (prepeat 3) == toP [3,3,3,3,3]+-- > ptake 5 (pure 3) == toP [3,3,3,3,3]+-- > take 5 (pure 3) == [3]+prepeat :: a -> P a+prepeat = pure++-- | Pattern variant of 'splitAt'.+psplitAt :: Int -> P a -> (P a,P a)+psplitAt n p =+    let (i,j) = splitAt n (unP p)+    in (toP i,toP j)++-- * Data.List.Split++-- | Pattern variant of 'Data.List.Split.splitPlaces'.+--+-- > psplitPlaces' (toP [1,2,3]) (pseries 1 1 6) == toP [[1],[2,3],[4,5,6]]+-- > psplitPlaces' (toP [1,2,3]) (toP ['a'..]) == toP ["a","bc","def"]+psplitPlaces' :: P Int -> P a -> P [a]+psplitPlaces' = liftP2 S.splitPlaces++-- | 'fmap' 'toP' of 'psplitPlaces''.+--+-- > psplitPlaces (toP [1,2,3]) (toP ['a'..]) == toP (map toP ["a","bc","def"])+psplitPlaces :: P Int -> P a -> P (P a)+psplitPlaces = fmap toP .: psplitPlaces'++-- | Pattern variant of 'take_inf', see also 'pfinval'.+--+-- > ptake 5 (pseq [1,2,3] 2) == toP [1,2,3,1,2]+-- > ptake 5 (toP [1,2,3]) == toP [1,2,3]+-- > ptake 5 (pseq [1,2,3] inf) == toP [1,2,3,1,2]+-- > ptake 5 (pwhite 'α' 0 5 inf) == toP [5,2,1,2,0]+--+-- Note that `ptake` does not extend the input pattern, unlike `pser`.+--+-- > ptake 5 (toP [1,2,3]) == toP [1,2,3]+-- > pser [1,2,3] 5 == toP [1,2,3,1,2]+ptake :: Int -> P a -> P a+ptake n = liftP (take_inf n)++-- | Type specialised 'mcycle'.+--+-- > ptake 5 (pcycle 1) == preplicate 5 1+-- > ptake 5 (pcycle (pure 1)) == preplicate 5 1+-- > ptake 5 (pcycle (return 1)) == preplicate 5 1+pcycle :: P a -> P a+pcycle = mcycle++-- | Type specialised 'mfilter'.  Aliased to `pselect`.  See also+-- `preject`.+--+-- > mfilter even (pseq [1,2,3] 2) == toP [2,2]+-- > mfilter (< 3) (pseq [1,2,3] 2) == toP [1,2,1,2]+pfilter :: (a -> Bool) -> P a -> P a+pfilter = mfilter++-- | Pattern variant of `replicate`.+--+-- > preplicate 4 1 == toP [1,1,1,1]+--+-- Compare to `pn`:+--+-- > pn 1 4 == toP [1,1,1,1]+-- > pn (toP [1,2]) 3 == toP [1,2,1,2,1,2]+-- > preplicate 4 (toP [1,2]) :: P (P Int)+preplicate :: Int -> a -> P a+preplicate n = toP . (if n == inf then repeat else replicate n)++-- | Pattern variant of `scanl`.  `scanl` is similar to `foldl`, but+-- returns a list of successive reduced values from the left.  pscanl+-- is an accumulator, it provides a mechanism for state to be threaded+-- through a pattern. It can be used to write a function to remove+-- succesive duplicates from a pattern, to count the distance between+-- occurences of an element in a pattern and so on.+--+-- > F.foldl (\x y -> 2 * x + y) 4 (pseq [1,2,3] 1) == 43+-- > pscanl (\x y -> 2 * x + y) 4 (pseq [1,2,3] 1) == toP [4,9,20,43]+--+-- > F.foldl (flip (:)) [] (toP [1..3]) == [3,2,1]+-- > pscanl (flip (:)) [] (toP [1..3]) == toP [[],[1],[2,1],[3,2,1]]+--+-- > F.foldl (+) 0 (toP [1..5]) == 15+-- > pscanl (+) 0 (toP [1..5]) == toP [0,1,3,6,10,15]+pscanl :: (a -> b -> a) -> a -> P b -> P a+pscanl f i = liftP (L.scanl f i)++-- | 'pdrop' @1@.  Pattern variant of `Data.List.tail`.  Drops first+-- element from pattern.  Note that the haskell `tail` function is+-- partial, although `drop` is not.  `ptake` is equal to `pdrop 1`.+--+-- > tail [] == _|_+-- > drop 1 [] == []+--+-- > ptail (toP [1,2]) == toP [2]+-- > ptail mempty == mempty+ptail :: P a -> P a+ptail = liftP (drop 1)++-- | Variant of 'L.transpose'.+--+-- > L.transpose [[1,2],[3,4,5]] == [[1,3],[2,4],[5]]+-- > ptranspose [toP [1,2],toP [3,4,5]] == toP [[1,3],[2,4],[5]]+--+-- > let p = ptranspose [pseq [1,2] inf,pseq [4,5] inf]+-- > in ptake 2 (pdrop (2^16) p) == toP [[1,4],[2,5]]+ptranspose :: [P a] -> P [a]+ptranspose l = toP (L.transpose (map unP l))++-- | An /implicitly repeating/ pattern variant of 'transpose_st'.+ptranspose_st_repeat :: [P a] -> P [a]+ptranspose_st_repeat l = toP (transpose_st (map unP_repeat l))++-- * Non-SC3 Patterns++-- | Type specialised 'P.fbool'.+pbool :: (Ord a,Num a) => P a -> P Bool+pbool = P.fbool++-- | 'mconcat' of 'replicate'.+pconcatReplicate :: Int -> P a -> P a+pconcatReplicate = mconcat .: replicate++-- | Lifted 'P.countpost'.+pcountpost :: P Bool -> P Int+pcountpost = liftP P.countpost++-- | Lifted 'P.countpre'.+pcountpre :: P Bool -> P Int+pcountpre = liftP P.countpre++-- | Lifted 'P.hold'.+phold :: P a -> P a+phold = liftP P.hold++-- | Lifted 'P.interleave2'.+--+-- > let p = pinterleave2 (pwhite 'α' 1 9 inf) (pseries 10 1 5)+-- > in [3,10,9,11,2,12,9,13,4,14] `L.isPrefixOf` unP p+pinterleave2 :: P a -> P a -> P a+pinterleave2 = liftP2 P.interleave2++-- | Lifted 'P.interleave'.+--+-- > pinterleave [pwhitei 'α' 0 4 3,pwhitei 'β' 5 9 3] == toP [2,7,0,5,3,6]+pinterleave :: [P a] -> P a+pinterleave = toP . P.interleave . map unP++-- | Lifted 'L.isPrefixOf'.+pisPrefixOf :: Eq a => P a -> P a -> Bool+pisPrefixOf p q = L.isPrefixOf (unP p) (unP q)++-- | Lifted 'I.rsd'.+--+-- > prsd (pstutter 2 (toP [1,2,3])) == toP [1,2,3]+-- > prsd (pseq [1,2,3] 2) == toP [1,2,3,1,2,3]+prsd :: (Eq a) => P a -> P a+prsd = liftP I.rsd++-- | Lifted 'P.trigger'.+--+-- > let {tr = pbool (toP [0,1,0,0,1,1])+-- >     ;p = ptrigger tr (toP [1,2,3])+-- >     ;r = [Nothing,Just 1,Nothing,Nothing,Just 2,Just 3]}+-- > in p == toP r+ptrigger :: P Bool -> P a -> P (Maybe a)+ptrigger p q =+    let r = pcountpre p+        f i x = preplicate i Nothing <> return (Just x)+    in join (pzipWith f r q)++-- * Aliases++-- | Type specialised 'mappend', sequences two patterns,+-- ie. 'Data.List.++'.+--+-- > 1 <> mempty <> 2 == toP [1,2]+--+-- > let {p = prand 'α' [0,1] 3+-- >     ;q = prand 'β' [5,7] 3}+-- > in audition (pbind [(K_degree,pappend p q),(K_dur,0.15)])+pappend :: P a -> P a -> P a+pappend = mappend++-- | Type specialised 'mconcat' (or equivalently 'msum' or+-- 'Data.List.concat').+--+-- > mconcat [pseq [1,2] 1,pseq [3,4] 2] == toP [1,2,3,4,3,4]+-- > msum [pseq [1,2] 1,pseq [3,4] 2] == toP [1,2,3,4,3,4]+pconcat :: [P a] -> P a+pconcat = mconcat++-- | Type specialised `mempty`, ie. 'Data.List.[]'.+pempty :: P a+pempty = mempty++-- | Type specialised 'F.foldr'.+--+-- > > (Pser([1,2,3],5) + Pseq([0,10],3)).asStream.all == [1,12,3,11,2]+--+-- > let p = pser [1,2,3] 5 + pseq [0,10] 3+-- > in F.foldr (:) [] p == [1,12,3,11,2]+--+-- Indefinte patterns may be folded.+--+-- > take 3 (F.foldr (:) [] (prepeat 1)) == [1,1,1]+--+-- The `Foldable` module includes functions for 'F.product', 'F.sum',+-- 'F.any', 'F.elem' etc.+--+-- > F.product (toP [1,3,5]) == 15+-- > floor (F.sum (ptake 100 (pwhite 'α' 0.25 0.75 inf))) == 51+-- > F.any even (toP [1,3,5]) == False+-- > F.elem 5 (toP [1,3,5]) == True+pfoldr :: (a -> b -> b) -> b -> P a -> b+pfoldr = F.foldr++-- | Type specialised 'join'.+--+-- > join (replicate 2 [1,2]) == [1,2,1,2]+-- > join (preplicate 2 (toP [1,2])) == toP [1,2,1,2]+pjoin :: P (P a) -> P a+pjoin = join++-- | 'join' that pushes an outer 'undecided' inward.+--+-- > join (undecided (undecided 1)) == undecided 1+-- > join (undecided (return 1)) == return 1+-- > pjoin_repeat (undecided (return 1)) == pure 1 == _|_+pjoin_repeat :: P (P a) -> P a+pjoin_repeat p =+    case p of+      P (Left (P (Right l))) -> toP (cycle l)+      _ -> join p++-- | Type specialised 'fmap', ie. 'Data.List.map'.+pmap :: (a -> b) -> P a -> P b+pmap = fmap++-- | Type specialised '>>='.+--+-- > (return 1 >>= return . id) == [1]+-- > (undecided 1 >>= undecided . id) == undecided 1+--+-- > (pseq [1,2] 1 >>= \x ->+-- >   pseq [3,4,5] 1 >>= \y ->+-- >    return (x,y)) == toP [(1,3),(1,4),(1,5),(2,3),(2,4),(2,5)]+pmbind :: P a -> (a -> P b) -> P b+pmbind = (>>=)++-- | Type specialised 'pure'.+ppure :: a -> P a+ppure = pure++-- | Type specialised 'return'.+preturn :: a -> P a+preturn = return++-- | Type specialised 'T.traverse'.+--+-- > let {f i e = (i + e,e * 2)+-- >     ;(r,p) = T.mapAccumL f 0 (toP [1,3,5])}+-- > in (r,p) == (9,toP [2,6,10])+ptraverse :: Applicative f => (a -> f b) -> P a -> f (P b)+ptraverse = T.traverse

@@ -0,0 +1,261 @@+-- | 'P' type, instance and core functions.+module Sound.SC3.Lang.Pattern.P.Core where++import Control.Applicative hiding ((<*)) {- base -}+import Control.Monad {- base -}+import Data.Bifunctor {- bifunctors -}+import qualified Data.Foldable as F {- base -}+import qualified Data.List as L {- base -}+import Data.Monoid {- base -}+import qualified Data.Traversable as T {- base -}++import Sound.SC3 (OrdE(..)) {- hsc3 -}++-- * P++-- | Patterns are opaque.  @P a@ is a pattern with elements of type+-- @a@.  Patterns are constructed, manipulated and destructured using+-- the functions provided, ie. the pattern instances for 'return',+-- 'pure' and 'F.toList', and the pattern specific functions+-- 'undecided' and 'toP'.+--+-- > F.toList (toP [1,2,3] * 2) == [2,4,6]+--+-- Patterns are 'Functor's.  'fmap' applies a function to each element+-- of a pattern.+--+-- > fmap (* 2) (toP [1,2,3,4,5]) == toP [2,4,6,8,10]+--+-- Patterns are 'Monoid's.  'mempty' is the empty pattern, and+-- 'mappend' ('<>') makes a sequence of two patterns.+--+-- > 1 <> mempty <> 2 == toP [1,2]+--+-- Patterns are 'Applicative'.  The pattern instance is pointwise &+-- truncating, as for 'ZipList'.  'pure' lifts a value into an+-- infinite pattern of itself, '<*>' applies a pattern of functions to+-- a pattern of values.  This is distinct from the combinatorial+-- instance for ordinary lists, ie. where 'pure' is 'return' and '<*>'+-- is 'ap'.+--+-- > liftA2 (+) (toP [1,2]) (toP [3,4,5]) == toP [4,6]+-- > liftA2 (+) [1,2] [3,4,5] == [4,5,6,5,6,7]+--+-- Patterns are 'Monad's, and therefore allow /do/ notation.+--+-- > let p = do {x <- toP [1,2]; y <- toP [3,4,5]; return (x,y)}+-- > in p == toP [(1,3),(1,4),(1,5),(2,3),(2,4),(2,5)]+--+-- Patterns are 'Num'erical.  The instances can be derived from the+-- 'Applicative' instance.+--+-- > 1 + toP [2,3,4] == liftA2 (+) 1 (toP [2,3,4])+data P a = P {unP_either :: Either a [a]}+           deriving (Eq,Show)++-- | Lift a value to a pattern deferring deciding if the constructor+-- ought to be 'pure' or 'return' to the consuming function.  The+-- pattern instances for 'fromInteger' and 'fromRational' make+-- 'undecided' patterns.  In general /horizontal/ functions (ie. '<>')+-- resolve using 'return' and /vertical/ functions (ie. 'zip') resolve+-- using 'pure'.  In the documentation functions that resolve using+-- 'pure' are annotated as /implicitly repeating/.+--+-- > 1 <> toP [2,3] == return 1 <> toP [2,3]+-- > toP [1,2] * 3  == toP [1,2] * pure 3+undecided :: a -> P a+undecided a = P (Left a)++{- | The basic list to pattern function, inverse is 'unP'.++> unP (toP "str") == "str"++There is a @default@ sound, given by 'defaultSynthdef' from "Sound.SC3".++> audition defaultSynthdef++If no instrument is specified we hear the default.++> audition (pbind [(K_degree,pxrand 'α' [0,1,5,7] inf)+>                 ,(K_dur,toP [0.1,0.2,0.1])])++> > Pbind(\degree,(Pxrand([0,1,5,7],inf))+> >      ,\dur,Pseq([0.1,0.2,0.1],1)).play++The pattern above is finite, `toP` can sometimes be replaced with+`pseq`.++> audition (pbind [(K_degree,pxrand 'α' [0,1,5,7] inf)+>                 ,(K_dur,pseq [0.1,0.2,0.1] inf)])++-}+toP :: [a] -> P a+toP = P . Right++-- | Type specialised 'F.toList'.  'undecided' values are singular.+--+-- > F.toList (undecided 'a') == ['a']+-- > unP (return 'a') == ['a']+-- > "aaa" `L.isPrefixOf` unP (pure 'a')+unP :: P a -> [a]+unP = either return id . unP_either++-- | Variant of 'unP' where 'undecided' values are 'repeat'ed.+--+-- > unP_repeat (return 'a') == ['a']+-- > take 2 (unP_repeat (undecided 'a')) == ['a','a']+-- > take 2 (unP_repeat (pure 'a')) == ['a','a']+unP_repeat :: P a -> [a]+unP_repeat = either repeat id . unP_either++instance Functor P where+    fmap f (P p) = P (bimap f (map f) p)++instance Monoid (P a) where+    mappend p q = toP (unP p ++ unP q)+    mempty = toP []++instance Applicative P where+    pure = toP . repeat+    f <*> e = pzipWith ($) f e++instance Alternative P where+    empty = mempty+    (<|>) = mappend++instance F.Foldable P where+    foldr f i p = L.foldr f i (unP p)++instance T.Traversable P where+    traverse f p = pure toP <*> T.traverse f (unP p)++instance Monad P where+    m >>= k =+        case m of+          P (Left e) -> k e+          P (Right l) -> L.foldr (mappend . k) mempty l+    return x = toP [x]++instance MonadPlus P where+    mzero = mempty+    mplus = mappend++instance (Num a) => Num (P a) where+    (+) = pzipWith (+)+    (-) = pzipWith (-)+    (*) = pzipWith (*)+    abs = fmap abs+    signum = fmap signum+    negate = fmap negate+    fromInteger = undecided . fromInteger++instance (Fractional a) => Fractional (P a) where+    (/) = pzipWith (/)+    recip = fmap recip+    fromRational = undecided . fromRational++instance (Ord a) => Ord (P a) where+    (>) = error ("~> Ord>*")+    (>=) = error ("~> Ord>=*")+    (<) = error ("~> Ord<*")+    (<=) = error ("~> Ord<=*")++instance (OrdE a) => OrdE (P a) where+    (>*) = pzipWith (>*)+    (>=*) = pzipWith (>=*)+    (<*) = pzipWith (<*)+    (<=*) = pzipWith (<=*)++-- * Lift P++-- | Lift unary list function to pattern function.+liftP :: ([a] -> [b]) -> P a -> P b+liftP f = toP . f . unP++-- | Lift binary list function to pattern function.+--+-- > liftP2 (zipWith (+)) (toP [1,2]) (toP [3,4,5]) == toP [4,6]+-- > liftA2 (+) (toP [1,2]) (toP [3,4,5]) == toP [4,6]+liftP2 :: ([a] -> [b] -> [c]) -> P a -> P b -> P c+liftP2 f p q =+    let p' = unP p+        q' = unP q+    in toP (f p' q')++-- | Lift binary list function to /implicitly repeating/ pattern function.+liftP2_repeat :: ([a] -> [b] -> [c]) -> P a -> P b -> P c+liftP2_repeat f p q =+    let p' = unP_repeat p+        q' = unP_repeat q+    in toP (f p' q')++-- | Lift ternary list function to pattern function.+liftP3 :: ([a] -> [b] -> [c] -> [d]) -> P a -> P b -> P c -> P d+liftP3 f p q r =+    let p' = unP p+        q' = unP q+        r' = unP r+    in toP (f p' q' r')++-- | Lift ternary list function to /implicitly repeating/ pattern function.+liftP3_repeat :: ([a] -> [b] -> [c] -> [d]) -> P a -> P b -> P c -> P d+liftP3_repeat f p q r =+    let p' = unP_repeat p+        q' = unP_repeat q+        r' = unP_repeat r+    in toP (f p' q' r')++-- * Zip P++-- | An /implicitly repeating/ pattern variant of 'zipWith'.+--+-- > zipWith (*) [1,2,3] [5,6] == [5,12]+-- > pzipWith (*) (toP [1,2,3]) (toP [5,6]) == toP [5,12]+--+-- It is the basis for lifting binary operators to patterns.+--+-- > toP [1,2,3] * toP [5,6] == toP [5,12]+--+-- > let p = pzipWith (,) (pseq [1,2] 2) (pseq [3,4] inf)+-- > in p == toP [(1,3),(2,4),(1,3),(2,4)]+--+-- > zipWith (,) (return 0) (return 1) == return (0,1)+-- > pzipWith (,) 0 1 == undecided (0,1)+pzipWith :: (a -> b -> c) -> P a -> P b -> P c+pzipWith f p q =+    case (p,q) of+      (P (Left m),P (Left n)) -> undecided (f m n)+      _ -> toP (zipWith f (unP_repeat p) (unP_repeat q))++-- | An /implicitly repeating/ pattern variant of 'zipWith3'.+pzipWith3 :: (a -> b -> c -> d) -> P a -> P b -> P c -> P d+pzipWith3 f p q r =+    case (p,q,r) of+      (P (Left m),P (Left n),P (Left o)) -> undecided (f m n o)+      _ -> toP (zipWith3 f (unP_repeat p) (unP_repeat q) (unP_repeat r))++-- | An /implicitly repeating/ pattern variant of 'zip'.+--+-- > zip (return 0) (return 1) == return (0,1)+-- > pzip (undecided 3) (undecided 4) == undecided (3,4)+-- > pzip 0 1 == undecided (0,1)+--+-- Note that 'pzip' is otherwise like haskell 'zip', ie. truncating.+--+-- > zip [1,2] [0] == [(1,0)]+-- > pzip (toP [1,2]) (return 0) == toP [(1,0)]+-- > pzip (toP [1,2]) (pure 0) == toP [(1,0),(2,0)]+-- > pzip (toP [1,2]) 0 == toP [(1,0),(2,0)]+pzip :: P a -> P b -> P (a,b)+pzip = pzipWith (,)++-- | Pattern variant of 'zip3'.+pzip3 :: P a -> P b -> P c -> P (a,b,c)+pzip3 = pzipWith3 (,,)++-- | Pattern variant on 'unzip'.+--+-- > let p = punzip (pzip (toP [1,2,3]) (toP [4,5]))+-- > in p == (toP [1,2],toP [4,5])+punzip :: P (a,b) -> (P a,P b)+punzip p = let (i,j) = unzip (unP p) in (toP i,toP j)

@@ -0,0 +1,574 @@+-- | @sclang@ event pattern functions.+--+-- SC3 /event/ patterns: `padd` (Padd), `pbind` (Pbind), `pkey`+-- (Pkey), `pmono` (Pmono), `pmul` (Pmul), `ppar` (Ppar), `pstretch`+-- (Pstretch), `ptpar` (Ptpar).  `pedit`, `pinstr`, `pmce2`, `psynth`,+-- `punion`.+module Sound.SC3.Lang.Pattern.P.Event where++import qualified Data.Foldable as F {- base -}+import Data.Maybe {- base -}+import Data.Monoid {- base -}++import Sound.OSC {- hsc3 -}+import Sound.SC3 {- hsc3 -}++import Sound.SC3.Lang.Control.Duration+import Sound.SC3.Lang.Control.Event+import Sound.SC3.Lang.Control.Instrument+import Sound.SC3.Lang.Core+import Sound.SC3.Lang.Pattern.P++-- * SC3 Event Patterns++-- | NewType for event patterns.+newtype P_Event = P_Event {p_Event :: P Event}++-- | 'P_Event' is audible, 'P' 'Event' could be as well but it'd be an orphan instance.+instance Audible P_Event where+    play_at _ = e_play . Event_Seq . unP . p_Event++pplay :: Transport m => P Event -> m ()+pplay = play . P_Event++-- | 'audition' of 'P_Event'.+paudition :: P Event -> IO ()+paudition = audition . P_Event++-- | Synonym for ('Key','P Field').+type P_Bind = (Key,P Field)++{-|+Padd.  Add a value to an existing key, or set the key if it doesn't exist.++> > p = Padd(\freq,801,Pbind(\freq,Pseq([100],1)));+> > p.asStream.all(()) == [('freq':901)]++> let p = padd (K_freq,801) (pbind [(K_freq,return 100)])+> in p == pbind [(K_freq,return 901)]++> > Padd(\freq,Pseq([401,801],2),Pbind(\freq,100)).play++> paudition (padd (K_freq,pseq [401,801] 2) (pbind [(K_freq,100)]))++> let {d = pseq [pshuf 'α' [-7,-3,0,2,4,7] 2+>               ,pseq [0,1,2,3,4,5,6,7] 1] 1+>     ;p = pbind [(K_dur,0.15),(K_degree,d)]+>     ;t n = padd (K_mtranspose,n) p}+> in paudition (pseq [p,t 1,t 2] inf)++-}+padd :: P_Bind -> P Event -> P Event+padd (k,p) = pzipWith (\i j -> e_edit k 0 (+ i) j) p++{-| Pbind.  SC3 pattern to assign keys to a set of 'Field' patterns+making an 'Event' pattern.++Each input pattern is assigned to key in the resulting event pattern.++There are a set of reserved keys that have particular roles in the+pattern library.++> > p = Pbind(\x,Pseq([1,2,3],1),\y,Pseed(Pn(100,1),Prand([4,5,6],inf)));+> > p.asStream.all(()) == [('y':4,'x':1),('y':6,'x':2),('y':4,'x':3)]++> let p = pbind [(K_param "x",prand 'α' [100,300,200] inf)+>               ,(K_param "y",pseq [1,2,3] 1)]+> in pkey (K_param "x") p == toP [200,200,300]++'K_param' can be elided if /OverloadedStrings/ are in place.++> :set -XOverloadedStrings++> ptake 2 (pbind [("x",pwhitei 'α' 0 9 inf)+>                ,("y",pseq [1,2,3] inf)])++'Event's implement variations on the @SC3@ 'Dur' and+'Sound.SC3.Lang.Control.Pitch.Pitch' models.++> > Pbind(\freq,Prand([300,500,231.2,399.2],inf),+> >       \dur,0.1).play;++> paudition (pbind [(K_freq,prand 'α' [300,500,231.2,399.2] inf)+>                  ,(K_dur,0.1)])++> > Pbind(\freq, Prand([300,500,231.2,399.2],inf),+> >       \dur,Prand([0.1,0.3],inf)).play;++> paudition (pbind [(K_freq,prand 'α' [300,500,231.2,399.2] inf)+>                  ,(K_dur,prand 'β' [0.1,0.3] inf)])++> > Pbind(\freq,Prand([1,1.2,2,2.5,3,4],inf) * 200,+> >       \dur,0.1).play;++> paudition (pbind [(K_freq,prand 'α' [1,1.2,2,2.5,3,4] inf * 200)+>                  ,(K_dur,0.1)])++> paudition (pbind [(K_freq,pseq [440,550,660,770] 2)+>                  ,(K_dur,pseq [0.1,0.15,0.1] inf)+>                  ,(K_amp,pseq [0.1,0.05] inf)+>                  ,(K_param "pan",pseq [-1,0,1] inf)])++A finite binding stops the `Event` pattern.++> > Pbind(\freq,Prand([300,500,231.2,399.2],inf),+> >       \dur,Pseq([0.1,0.2],3)).play;++> paudition (pbind [(K_freq,prand 'α' [300,500,231.2,399.2] inf)+>                  ,(K_dur,pseq [0.1,0.2] 3)])++> > Pbind(\freq,Prand([300,500,231.2,399.2],inf),+> >       \dur,Prand([0.1,0.3],inf)).play++All infinite inputs:++> paudition (pbind [(K_freq,prand 'α' [300,500,231.2,399.2] inf)+>                  ,(K_dur,prand 'β' [0.1,0.3] inf)])++Implicit /field/ patterns is this context are infinite.++> paudition (pbind [(K_freq,prand 'α' [1,1.2,2,2.5,3,4] inf * 200)+>                  ,(K_dur,0.1)])++> let test = let {freq = control KR "freq" 440+>                ;amp = control KR "amp" 0.1+>                ;nharms = control KR "nharms" 10+>                ;pan = control KR "pan" 0+>                ;gate = control KR "gate" 1+>                ;s = blip AR freq nharms * amp+>                ;e = linen gate 0.01 0.6 0.4 RemoveSynth+>                ;o = offsetOut 0 (pan2 s pan e)}+>            in synthdef "test" o++> paudition (pbind [(K_instr,psynth test)+>                  ,(K_freq,prand 'α' [1,1.2,2,2.5,3,4] inf * 200)+>                  ,(K_dur,0.1)])++> paudition (pbind [(K_instr,psynth test)+>                  ,(K_param "nharms",pseq [4,10,40] inf)+>                  ,(K_dur,pseq [1,1,2,1] inf / 10)+>                  ,(K_freq,pn (pseries 1 1 16 * 50) 4)+>                  ,(K_sustain,pseq [1/10,0.5,1,2] inf)])++> let acid = let {freq = control KR "freq" 1000+>                ;gate = control KR "gate" 1+>                ;pan = control KR "pan" 0+>                ;cut = control KR "cut" 4000+>                ;res = control KR "res" 0.8+>                ;amp = control KR "amp" 1+>                ;s = rlpf (pulse AR freq 0.05) cut res+>                ;d = envLinen 0.01 1 0.3 1+>                ;e = envGen KR gate amp 0 1 RemoveSynth d+>                ;o = out 0 (pan2 s pan e)}+>            in synthdef "acid" o++> > Pbind(\instrument,\acid,+> >       \dur,Pseq([0.25,0.5,0.25],4),+> >       \root,-24,+> >       \degree,Pseq([0,3,5,7,9,11,5,1],inf),+> >       \pan,Pfunc({1.0.rand2}),+> >       \cut,Pxrand([1000,500,2000,300],inf),+> >       \rez,Pfunc({0.7.rand +0.3}),+> >       \amp,0.2).play++> paudition (pbind [(K_instr,psynth acid)+>                  ,(K_dur,pseq [0.25,0.5,0.25] 4)+>                  ,(K_root,-24)+>                  ,(K_degree,pseq [0,3,5,7,9,11,5,1] inf)+>                  ,(K_param "pan",pwhite 'α' (-1.0) 1.0 inf)+>                  ,(K_param "cut",pxrand 'β' [1000,500,2000,300] inf)+>                  ,(K_param "res",pwhite 'γ' 0.3 1.0 inf)+>                  ,(K_amp,0.2)])++> > Pseq([Pbind(\instrument,\acid,+> >             \dur,Pseq([0.25,0.5,0.25],4),+> >             \root,-24,+> >             \degree,Pseq([0,3,5,7,9,11,5,1],inf),+> >             \pan,Pfunc({1.0.rand2}),+> >             \cut,Pxrand([1000,500,2000,300],inf),+> >             \rez,Pfunc({0.7.rand + 0.3}),+> >             \amp,0.2),+> >       Pbind(\instrument,\acid,+> >             \dur,Pseq([0.25],6),+> >             \root,-24,+> >             \degree,Pseq([18,17,11,9],inf),+> >             \pan,Pfunc({1.0.rand2}),+> >             \cut,1500,+> >             \rez,Pfunc({0.7.rand + 0.3}),+> >             \amp,0.16)],inf).play++> paudition (pseq [pbind [(K_instr,psynth acid)+>                        ,(K_dur,pseq [0.25,0.5,0.25] 4)+>                        ,(K_root,-24)+>                        ,(K_degree,pseq [0,3,5,7,9,11,5,1] inf)+>                        ,(K_param "pan",pwhite 'α' (-1.0) 1.0 inf)+>                        ,(K_param "cut",pxrand 'β' [1000,500,2000,300] inf)+>                        ,(K_param "res",pwhite 'γ' 0.3 1.0 inf)+>                        ,(K_amp,0.2)]+>                 ,pbind [(K_instr,psynth acid)+>                        ,(K_dur,pn 0.25 6)+>                        ,(K_root,-24)+>                        ,(K_degree,pser [18,17,11,9] inf)+>                        ,(K_param "pan",pwhite 'δ' (-1.0) 1.0 inf)+>                        ,(K_param "cut",1500)+>                        ,(K_param "res",pwhite 'ε' 0.3 1.0 inf)+>                        ,(K_amp,0.16)]] inf)++> > Pbind(\instrument, \acid,+> >       \dur, Pseq([0.25,0.5,0.25], inf),+> >       \root, [-24,-17],+> >       \degree, Pseq([0,3,5,7,9,11,5,1], inf),+> >       \pan, Pfunc({1.0.rand2}),+> >       \cut, Pxrand([1000,500,2000,300], inf),+> >       \rez, Pfunc({0.7.rand +0.3}),+> >       \amp, 0.2).play;++> paudition (pbind [(K_instr,psynth acid)+>                  ,(K_dur,pseq [0.25,0.5,0.25] inf)+>                  ,(K_root,pmce2 (-24) (-17))+>                  ,(K_degree,pseq [0,3,5,7,9,11,5,1] inf)+>                  ,(K_param "pan",pwhite 'α' (-1.0) 1.0 inf)+>                  ,(K_param "cut",pxrand 'β' [1000,500,2000,300] inf)+>                  ,(K_param "res",pwhite 'γ' 0.3 1.0 inf)+>                  ,(K_amp,0.2)])++A persistent synthesis node with /freq/ and /amp/ controls.++> import Sound.SC3.ID++> let {freq = control KR "freq" 440+>     ;amp = control KR "amp" 0.6+>     ;n = pinkNoise 'α' AR * amp}+> in audition (out 0 (pan2 (moogFF n freq 2 0) 0 1))++A pattern to set /freq/ and /amp/ controls at the most recently+instantiated synthesis node.++> :set -XOverloadedStrings++> paudition (pbind [(K_type,prepeat "n_set")+>                  ,(K_id,(-1))+>                  ,(K_freq,pwhite 'α' 100 1000 inf)+>                  ,(K_dur,0.2)+>                  ,(K_amp,toP [1,0.99 .. 0.1])])++> let berlinb =+>   let {k = control KR+>       ;o = k "out" 0+>       ;f = k "freq" 80+>       ;a = k "amp" 0.01+>       ;p = k "pan" 0+>       ;g = k "gate" 1+>       ;env = decay2 g 0.05 8 * 0.0003+>       ;syn = rlpf (lfPulse AR f 0 (sinOsc KR 0.12 (mce2 0 (pi/2)) * 0.48 + 0.5))+>                   (f * (sinOsc KR 0.21 0 * 18 + 20))+>                   0.07+>       ;syn_env = syn * env+>       ;kil = detectSilence (mceChannel 0 syn_env) 0.1 0.2 RemoveSynth}+>   in mrg2 (out o (a * mix (panAz 4 syn_env (mce2 p (p + 1)) 1 2 0.5))) kil++> paudition (ppar [pbind [(K_degree,pseq [0,1,2,4,6,3,4,8] inf)+>                        ,(K_dur,0.5)+>                        ,(K_octave,3)+>                        ,(K_instr,psynth (synthdef "berlinb" berlinb))]+>                 ,pbind [(K_degree,pseq [0,1,2,4,6,3,4,8] inf)+>                        ,(K_dur,0.5)+>                        ,(K_octave,pmce2 2 1)+>                        ,(K_param "pan",pwhite 'a' (-1) 1 inf)+>                        ,(K_instr,psynth (synthdef "berlinb" berlinb))]])++-}+pbind :: [P_Bind] -> P Event+pbind xs =+    let xs' = fmap (\(k,v) -> pzip (undecided k) v) xs+        xs'' = ptranspose_st_repeat xs'+    in fmap e_from_list xs''++-- | Operator to lift 'F_Value' pattern to 'P_Bind' tuple.+--+-- > let {r = True `pcons` preplicate 3 False :: P Bool}+-- > in pbind [K_rest <| r] == pbind [(K_rest,pseq [1,0,0,0] 1)]+(<|) :: F_Value v => Key -> P v -> P_Bind+(<|) k p = (k,fmap toF p)+infixl 3 <|++{- | Pkey.  SC3 pattern to read 'Key' at 'Event' pattern.  Note+-- however that in haskell is usually more appropriate to name the+-- pattern using /let/.++> pkey K_freq (pbind [(K_freq,return 440)]) == toP [440]+> pkey K_amp (pbind [(K_amp,toP [0,1])]) == toP [0,1]++> > Pbind(\degree,Pseq([Pseries(-7,1,14),Pseries(7,-1,14)],inf),+> >       \dur,0.25,+> >       \legato,Pkey(\degree).linexp(-7,7,2.0,0.05)).play++> let {d = pseq [pseries (-7) 1 14,pseries 7 (-1) 14] inf+>     ;l = fmap (Sound.SC3.Lang.Math.linexp (-7) 7 2 0.05) d}+> in paudition (pbind [(K_degree,d)+>                     ,(K_dur,0.25)+>                     ,(K_legato,l)])++-}+pkey :: Key -> P Event -> P Field+pkey k = fmap (fromJust . e_get k)++{- | Pmono.  SC3 pattern that is a variant of 'pbind' for controlling+-- monophonic (persistent) synthesiser nodes.++> let p = [(K_instr,pinstr' (Instr_Ref "default" False))+>         ,(K_id,100)+>         ,(K_degree,pxrand 'α' [0,2,4,5,7,9,11] inf)+>         ,(K_amp,pwrand 'β' [0.05,0.2] [0.7,0.3] inf)+>         ,(K_dur,0.25)]+> in paudition (pmono p)++-}+pmono :: [P_Bind] -> P Event+pmono b =+    let ty = fmap F_String ("s_new" `pcons` prepeat "n_set")+    in pbind ((K_type,ty) : b)++-- | Pmul.  SC3 pattern to multiply an existing key by a value, or set+-- the key if it doesn't exist.+--+-- > let p = pbind [(K_dur,0.15),(K_freq,prand 'α' [440,550,660] 6)]+-- > in paudition (pseq [p,pmul (K_freq,2) p,pmul (K_freq,0.5) p] 2)+pmul :: P_Bind -> P Event -> P Event+pmul (k,p) = pzipWith (\i j -> e_edit k 1 (* i) j) p++{-| Ppar.  Variant of 'ptpar' with zero start times.++The result of `pmerge` can be merged again, `ppar` merges a list of+patterns.++> let {a = pbind [(K_param "a",pseq [1,2,3] inf)]+>     ;b = pbind [(K_param "b",pseq [4,5,6] inf)]+>     ;r = toP [e_from_list [(K_param "a",1),(K_fwd',0)]+>              ,e_from_list [(K_param "b",4),(K_fwd',1)]]}+> in ptake 2 (ppar [a,b]) == r++> let {p = pbind [(K_dur,0.2),(K_midinote,pseq [62,65,69,72] inf)]+>     ;q = pbind [(K_dur,0.4),(K_midinote,pseq [50,45] inf)]+>     ;r = pbind [(K_dur,0.6),(K_midinote,pseq [76,79,81] inf)]}+> in paudition (ppar [p,q,r])++Multiple nested `ppar` patterns.++> let {a u = pbind [(K_dur,0.2),(K_param "pan",0.5),(K_midinote,pseq u 1)]+>     ;b l = pbind [(K_dur,0.4),(K_param "pan",-0.5),(K_midinote,pseq l 1)]+>     ;f u l = ppar [a u,b l]+>     ;h = pbind [(K_dur,prand 'α' [0.2,0.4,0.6] inf)+>                ,(K_midinote,prand 'β' [72,74,76,77,79,81] inf)+>                ,(K_db,-26)+>                ,(K_legato,1.1)]+>     ;m = pseq [pbind [(K_dur,3.2),(K_freq,return nan)]+>               ,prand 'γ' [f [60,64,67,64] [48,43]+>                          ,f [62,65,69,65] [50,45]+>                          ,f [64,67,71,67] [52,47]] 12] inf}+> in paudition (ppar [h,m])++-}+ppar :: [P Event] -> P Event+ppar l = ptpar (zip (repeat 0) l)++-- | Pstretch.  SC3 pattern to do time stretching.  It is equal to+-- 'pmul' at 'K_stretch'.+--+-- > let {d = pseq [pshuf 'α' [-7,-3,0,2,4,7] 2+-- >               ,pseq [0,1,2,3,4,5,6,7] 1] 1+-- >     ;p = pbind [(K_dur,0.15),(K_degree,d)]}+-- > in paudition (pseq [p,pstretch 0.5 p,pstretch 2 p] inf)+pstretch :: P Field -> P Event -> P Event+pstretch p = pmul (K_stretch,p)++{-| Ptpar.  Merge a set of 'Event' patterns each with indicated+-- start 'Time'.++`ptpar` is a variant of `ppar` which allows non-equal start times.++> let {f d p n = pbind [(K_dur,d),(K_param "pan",p),(K_midinote,n)]+>     ;a = f 0.2 (-1) (pseries 60 1 15)+>     ;b = f 0.15 0 (pseries 58 2 15)+>     ;c = f 0.1 1 (pseries 46 3 15)}+> in paudition (ptpar [(0,a),(1,b),(2,c)])++> let {d = pseq [pgeom 0.05 1.1 24,pgeom 0.5 0.909 24] 2+>     ;f n a p = pbind [(K_dur,d)+>                      ,(K_db,a)+>                      ,(K_param "pan",p)+>                      ,(K_midinote,pseq [n,n-4] inf)]}+> in audition (ptpar [(0,f 53 (-20) (-0.9))+>                    ,(2,f 60 (-23) (-0.3))+>                    ,(4,f 67 (-26) 0.3)+>                    ,(6,f 74 (-29) 0.9)])++-}+ptpar :: [(Time,P Event)] -> P Event+ptpar l =+    case l of+      [] -> mempty+      [(_,p)] -> p+      (pt,p):(qt,q):r -> ptpar ((min pt qt,ptmerge (pt,p) (qt,q)) : r)++-- * Instrument Event Patterns++-- | Pattern from 'Instr'.  An 'Instr' is either a 'Synthdef' or a+-- /name/.  In the 'Synthdef' case the instrument is asynchronously+-- sent to the server before processing the event, which has timing+-- implications.  The pattern constructed here uses the 'Synthdef' for+-- the first element, and the subsequently the /name/.+--+-- > paudition (pbind [(K_instr,pinstr' defaultInstr)+-- >                  ,(K_degree,toP [0,2,4,7])+-- >                  ,(K_dur,0.25)])+pinstr' :: Instr -> P Field+pinstr' i = toP (map F_Instr (i_repeat i))++{-| 'Instr' pattern from instrument /name/.  See also `psynth` (where+the /sine/ instrument below is defined).++> let {si = return (F_Instr (Instr_Ref "sine" True))+>     ;di = return (F_Instr (Instr_Ref "default" True))+>     ;i = pseq [si,si,di] inf+>     ;p = pbind [(K_instr,i),(K_degree,pseq [0,2,4,7] inf),(K_dur,0.25)]}+> in paudition p++-}+pinstr :: String -> P Field+pinstr s = pinstr' (Instr_Ref s True)++{-| `Synthdef`s can be used directly as an instrument using `psynth`.+The default synthdef is at 'Data.Default.def'.++> let sineSynth =+>   let {f = control KR "freq" 440+>       ;g = control KR "gate" 1+>       ;a = control KR "amp" 0.1+>       ;d = envASR 0.01 1 1 (EnvNum (-4))+>       ;e = envGen KR g a 0 1 RemoveSynth d+>       ;o = out 0 (sinOsc AR f 0 * e)}+>   in synthdef "sine" o++> paudition (pbind [(K_instr,psynth sineSynth)+>                  ,(K_degree,toP [0,2,4,7])+>                  ,(K_dur,0.25)])++-}+psynth :: Synthdef -> P Field+psynth s = pinstr' (Instr_Def s True)++-- * MCE Patterns++-- | Two-channel MCE for /field/ patterns.+--+-- > pmce2 (toP [1,2]) (toP [3,4]) == toP [f_array [1,3],f_array [2,4]]+--+-- > let p = pmce2 (pseq [1,2] inf) (pseq [3,4] inf)+-- > in ptake 2 p == toP [f_array [1,3],f_array [2,4]]+pmce2 :: P Field -> P Field -> P Field+pmce2 p = pzipWith (\m n -> F_Vector [m,n]) p++-- | Three-channel MCE for /field/ patterns.+pmce3 :: P Field -> P Field -> P Field -> P Field+pmce3 p q = pzipWith3 (\m n o -> F_Vector [m,n,o]) p q++{-|++Remove one layer of MCE expansion at an /event/ pattern.  The+pattern will be expanded only to the width of the initial input.+Holes are filled with rests.++> let {a = pseq [65,69,74] inf+>     ;b = pseq [60,64,67,72,76] inf+>     ;c = pseq [pmce3 72 76 79,pmce2 a b] 1}+> in paudition (p_un_mce (pbind [(K_midinote,c)+>                               ,(K_param "pan",pmce2 (-1) 1)+>                               ,(K_dur,1 `pcons` prepeat 0.15)]))++`p_un_mce` translates via `ppar`.  This allows `dur` related fields to+be MCE values.  The underlying event processor also implements one+layer of MCE expansion.++> paudition (p_un_mce+>            (pbind [(K_dur,pmce2 0.25 0.2525)+>                   ,(K_legato,pmce2 0.25 2.5)+>                   ,(K_freq,pmce2 (pseq [300,400,500] inf)+>                                  (pseq [302,402,502,202] inf))+>                   ,(K_param "pan",pmce2 (-0.5) 0.5)]))++-}+p_un_mce :: P Event -> P Event+p_un_mce p =+    let l' = transpose_fw_def' e_rest (map e_un_mce' (unP p))+    in toP (e_par (zip (repeat 0) l'))++-- * Non-SC3 Event Patterns++-- | Edit 'a' at 'Key' in each element of an 'Event' pattern.+pedit :: Key -> (Field -> Field) -> P Event -> P Event+pedit k f = fmap (e_edit' k f)++-- | Pattern of start times of events at event pattern.+--+-- > p_time (pbind [(K_dur,toP [1,2,3,2,1])]) == toP [0,1,3,6,8,9]+-- > p_time (pbind [(K_dur,pseries 0.5 0.5 5)]) == toP [0,0.5,1.5,3,5,7.5]+p_time :: P Event -> P Time+p_time =  pscanl (+) 0 . fmap (fwd . e_dur Nothing)++-- | Pattern to extract 'a's at 'Key' from an 'Event'+-- pattern.+--+-- > pkey_m K_freq (pbind [(K_freq,return 440)]) == toP [Just 440]+pkey_m :: Key -> P Event -> P (Maybe Field)+pkey_m k = fmap (e_get k)++{-| Variant of 'ptmerge' with zero start times.++`pmerge` merges two event streams, adding /fwd'/ entries as required.++> let {p = pbind [(K_dur,0.2),(K_midinote,pseq [62,65,69,72] inf)]+>     ;q = pbind [(K_dur,0.4),(K_midinote,pseq [50,45] inf)]}+> in paudition (pmerge p q)++-}+pmerge :: P Event -> P Event -> P Event+pmerge p q = ptmerge (0,p) (0,q)++-- | Variant that does not insert key.+pmul' :: P_Bind -> P Event -> P Event+pmul' (k,p) = pzipWith (\i j -> e_edit' k (* i) j) p++-- | Merge two 'Event' patterns with indicated start 'Time's.+ptmerge :: (Time,P Event) -> (Time,P Event) -> P Event+ptmerge (pt,p) (qt,q) =+    toP (e_merge (pt,F.toList p) (qt,F.toList q))++-- | Left-biased union of event patterns.+punion :: P Event -> P Event -> P Event+punion = pzipWith (<>)++-- | 'punion' of 'pbind' of 'return', ie. @p_with (K_Instr,psynth s)@.+p_with :: P_Bind -> P Event -> P Event+p_with = punion . pbind . return++-- * NRT++{-| Transform an /event/ pattern into a /non-real time/ SC3 score.++> let n = pNRT (pbind [(K_freq,prand 'α' [300,500,231.2,399.2] inf)+>                     ,(K_dur,pseq [0.1,0.2] 3)])++> audition n++> mapM_ (putStrLn . bundlePP) (nrt_bundles n)++Infinite 'NRT' scores are productive for 'audition'ing.++> let n' = pNRT (pbind [(K_dur,0.25),(K_freq,pseq [300,600,900] inf)])+> audition n'+> mapM_ (putStrLn . bundlePP) (take 9 (nrt_bundles n'))++-}+pNRT :: P Event -> NRT+pNRT = e_nrt . Event_Seq . unP

@@ -0,0 +1,883 @@+-- | @sclang@ value pattern functions.+--+-- SC3 /value/ patterns: `pbrown` (Pbrown), `pclutch` (Pclutch),+-- `pcollect` (Pcollect), `pconst` (Pconst), `pdegreeToKey`+-- (PdegreeToKey), `pdiff` (Pdiff), `pdrop` (Pdrop), `pdurStutter`+-- (PdurStutter), `pexprand` (Pexprand), `pfinval` (Pfinval), `pfuncn`+-- (Pfuncn), `pgeom` (Pgeom), `pif` (Pif), `place` (Place), `pn` (Pn),+-- `ppatlace` (Ppatlace), `prand` (Prand), `preject` (Preject),+-- `prorate` (Prorate), `pselect` (Pselect), `pseq` (Pseq), `pser`+-- (Pser), `pseries` (Pseries), `pshuf` (Pshuf), `pslide` (Pslide),+-- `pstutter` (Pstutter), `pswitch1` (Pswitch1), `pswitch` (Pswitch),+-- `ptuple` (Ptuple), `pwhite` (Pwhite), `pwrand` (Pwrand), `pwrap`+-- (Pwrap), `pxrand` (Pxrand).+--+-- SC3 variant patterns: `pbrown`', `prand'`, `prorate'`, `pseq1`,+-- `pseqn`, `pser1`, `pseqr`, `pwhite'`, `pwhitei`.+--+-- SC3 collection patterns: `pfold`+module Sound.SC3.Lang.Pattern.P.SC3 where++import Control.Monad {- base -}+import qualified Data.List as L {- base -}+import Data.Monoid {- base -}+import System.Random {- random -}++import Sound.SC3 {- hsc3 -}++import Sound.SC3.Lang.Core+import Sound.SC3.Lang.Pattern.P.Core+import Sound.SC3.Lang.Pattern.P.Base++import qualified Sound.SC3.Lang.Collection as C+import qualified Sound.SC3.Lang.Math as M+import qualified Sound.SC3.Lang.Pattern.List as P+import qualified Sound.SC3.Lang.Pattern.Stream as I+import qualified Sound.SC3.Lang.Random.Gen as R++-- * SC3 Collection Patterns++-- | Variant of 'C.flop'.+--+-- > pflop' [toP [1,2],toP [3,4,5]] == toP [[1,3],[2,4],[1,5]]+-- > pflop' [toP [1,2],3] == toP [[1,3],[2,3]]+-- > pflop' [pseq [1,2] 1,pseq [3,4] inf]+pflop' :: [P a] -> P [a]+pflop' l = toP (C.flop (map unP l))++-- | 'fmap' 'toP' of 'pflop''.+--+-- > C.flop [[1,2],[3,4,5]] == [[1,3],[2,4],[1,5]]+-- > pflop [toP [1,2],toP [3,4,5]] == toP (map toP [[1,3],[2,4],[1,5]])+pflop :: [P a] -> P (P a)+pflop = fmap toP . pflop'++{- | Type specialised 'P.ffold'.++> pfold (toP [10,11,12,-6,-7,-8]) (-7) 11 == toP [10,11,10,-6,-7,-6]++> audition (pbind [(K_degree,pfold (pseries 4 1 inf) (-7) 11)+>                 ,(K_dur,0.0625)])++The underlying primitive is then `fold_` function.++> let f = fmap (\n -> fold_ n (-7) 11)+> in audition (pbind [(K_degree,f (pseries 4 1 inf))+>                    ,(K_dur,0.0625)])++-}+pfold :: (RealFrac n) => P n -> n -> n -> P n+pfold = P.ffold++-- | Pattern variant of 'C.normalizeSum'.+pnormalizeSum :: Fractional n => P n -> P n+pnormalizeSum = liftP C.normalizeSum++-- * SC3 Patterns++{-| Pbrown.  Lifted 'P.brown'.  SC3 pattern to generate+psuedo-brownian motion.++> pbrown 'α' 0 9 1 5 == toP [4,4,5,4,3]++> audition (pbind [(K_dur,0.065)+>                 ,(K_freq,pbrown 'α' 440 880 20 inf)])++-}+pbrown :: (Enum e,Random n,Num n,Ord n) => e -> n -> n -> n -> Int -> P n+pbrown e l r s n = ptake n (toP (P.brown e l r s))++{-| Pclutch.  SC3 sample and hold pattern.  For true values in the+control pattern, step the value pattern, else hold the previous value.++> > c = Pseq([1,0,1,0,0,1,1],inf);+> > p = Pclutch(Pser([1,2,3,4,5],8),c);+> > r = [1,1,2,2,2,3,4,5,5,1,1,1,2,3];+> > p.asStream.all == r++> let {c = pbool (pseq [1,0,1,0,0,1,1] inf)+>     ;p = pclutch (pser [1,2,3,4,5] 8) c+>     ;r = toP [1,1,2,2,2,3,4,5,5,1,1,1,2,3]}+> in p == toP [1,1,2,2,2,3,4,5,5,1,1,1,2,3]++Note the initialization behavior, nothing is generated until the+first true value.++> let {p = pseq [1,2,3,4,5] 1+>     ;q = pbool (pseq [0,0,0,0,0,0,1,0,0,1,0,1] 1)}+> in pclutch p q == toP [1,1,1,2,2,3]++> > Pbind(\degree,Pstutter(Pwhite(3,10,inf),Pwhite(-4,11,inf)),+> >       \dur,Pclutch(Pwhite(0.1,0.4,inf),+> >                    Pdiff(Pkey(\degree)).abs > 0),+> >       \legato,0.3).play;++> let {d = pstutter (pwhite 'α' 3 10 inf) (pwhitei 'β' (-4) 11 inf)+>     ;p = [(K_degree,d)+>          ,(K_dur,pclutch (pwhite 'γ' 0.1 0.4 inf)+>                          (pbool (abs (pdiff d) >* 0)))+>          ,(K_legato,0.3)]}+> in audition (pbind p)++-}+pclutch :: P a -> P Bool -> P a+pclutch p q =+    let r = fmap (+ 1) (pcountpost q)+    in pstutter r p++-- | Pcollect.  SC3 name for 'fmap', ie. patterns are functors.+--+-- > > Pcollect({|i| i * 3},Pseq(#[1,2,3],1)).asStream.all == [3,6,9]+-- > pcollect (* 3) (toP [1,2,3]) == toP [3,6,9]+--+-- > > Pseq(#[1,2,3],1).collect({|i| i * 3}).asStream.all == [3,6,9]+-- > fmap (* 3) (toP [1,2,3]) == toP [3,6,9]+pcollect :: (a -> b) -> P a -> P b+pcollect = fmap++{- | Pconst.  SC3 pattern to constrain the sum of a numerical pattern.+Is equal to /p/ until the accumulated sum is within /t/ of /n/.  At+that point, the difference between the specified sum and the+accumulated sum concludes the pattern.++> > p = Pconst(10,Pseed(Pn(1000,1),Prand([1,2,0.5,0.1],inf),0.001));+> > p.asStream.all == [0.5,0.1,0.5,1,2,2,0.5,1,0.5,1,0.9]++> let p = pconst 10 (prand 'α' [1,2,0.5,0.1] inf) 0.001+> in (p,Data.Foldable.sum p)++> > Pbind(\degree,Pseq([-7,Pwhite(0,11,inf)],1),+> >       \dur,Pconst(4,Pwhite(1,4,inf) * 0.25)).play++> let p = [(K_degree,pcons (-7) (pwhitei 'α' 0 11 inf))+>         ,(K_dur,pconst 4 (pwhite 'β' 1 4 inf * 0.25) 0.001)]+> in audition (pbind p)++-}+pconst :: (Ord a,Num a) => a -> P a -> a -> P a+pconst n p t =+    let f _ [] = []+        f j (i:is) = if i + j < n - t+                     then i : f (j + i) is+                     else [n - j]+    in toP (f 0 (unP p))++{-| PdegreeToKey.  SC3 pattern to derive notes from an index into a+scale.++> let {p = pseq [0,1,2,3,4,3,2,1,0,2,4,7,4,2] 2+>     ;q = pure [0,2,4,5,7,9,11]+>     ;r = [0,2,4,5,7,5,4,2,0,4,7,12,7,4,0,2,4,5,7,5,4,2,0,4,7,12,7,4]}+> in pdegreeToKey p q (pure 12) == toP r++> let {p = pseq [0,1,2,3,4,3,2,1,0,2,4,7,4,2] 2+>     ;q = pseq (map return [[0,2,4,5,7,9,11],[0,2,3,5,7,8,11]]) 1+>     ;r = [0,2,4,5,7,5,4,2,0,4,7,12,7,4,0,2,3,5,7,5,3,2,0,3,7,12,7,3]}+> in pdegreeToKey p (pstutter 14 q) (pure 12) == toP r++This is the pattern variant of 'M.degreeToKey'.++> let s = [0,2,4,5,7,9,11]+> in map (M.degreeToKey s 12) [0,2,4,7,4,2,0] == [0,4,7,12,7,4,0]++> > Pbind(\note,PdegreeToKey(Pseq([1,2,3,2,5,4,3,4,2,1],2),+> >                          #[0,2,3,6,7,9],+> >                          12),\dur,0.25).play++> let {n = pdegreeToKey (pseq [1,2,3,2,5,4,3,4,2,1] 2)+>                       (pure [0,2,3,6,7,9])+>                       12}+> in audition (pbind [(K_note,n),(K_dur,0.25)])++> > s = #[[0,2,3,6,7,9],[0,1,5,6,7,9,11],[0,2,3]];+> > d = [1,2,3,2,5,4,3,4,2,1];+> > Pbind(\note,PdegreeToKey(Pseq(d,4),+> >                          Pstutter(3,Prand(s,inf)),+> >                          12),\dur,0.25).play;++> let {s = map return [[0,2,3,6,7,9],[0,1,5,6,7,9,11],[0,2,3]]+>     ;d = [1,2,3,2,5,4,3,4,2,1]+>     ;k = pdegreeToKey (pseq d 4)+>                       (pstutter 3 (prand 'α' s 14))+>                       (pn 12 40)}+> in audition (pbind [(K_note,k),(K_dur,0.25)])++-}+pdegreeToKey :: (RealFrac a) => P a -> P [a] -> P a -> P a+pdegreeToKey = pzipWith3 (\i j k -> M.degreeToKey j k i)++-- | Pdiff.  SC3 pattern to calculate adjacent element difference.+--+-- > > Pdiff(Pseq([0,2,3,5,6,8,9],1)).asStream.all == [2,1,2,1,2,1]+-- > pdiff (pseq [0,2,3,5,6,8,9] 1) == toP [2,1,2,1,2,1]+pdiff :: Num n => P n -> P n+pdiff p = ptail p - p++-- | Pdrop.  Lifted 'L.drop'.+--+-- > > p = Pseries(1,1,20).drop(5);+-- > > p.asStream.all == [6,7,8,9,10,11,12,13,14,15,16,17,18,19,20]+--+-- > pdrop 5 (pseries 1 1 10) == toP [6,7,8,9,10]+-- > pdrop 1 mempty == mempty+pdrop :: Int -> P a -> P a+pdrop n = liftP (drop n)++{- | PdurStutter.  Lifted 'P.durStutter'.++> > s = Pseq(#[1,1,1,1,1,2,2,2,2,2,0,1,3,4,0],inf);+> > d = Pseq(#[0.5,1,2,0.25,0.25],1);+> > PdurStutter(s,d).asStream.all == [0.5,1,2,0.25,0.25]++> let {s = pseq [1,1,1,1,1,2,2,2,2,2,0,1,3,4,0] inf+>     ;d = pseq [0.5,1,2,0.25,0.25] 1}+> in pdurStutter s d == toP [0.5,1.0,2.0,0.25,0.25]++Applied to duration.++> > d = PdurStutter(Pseq(#[1,1,1,1,1,2,2,2,2,2,3,3,3,3,3,4,4,4,4,4],inf),+> >                 Pseq(#[0.5,1,2,0.25,0.25],inf));+> > Pbind(\freq,440,\dur,d).play++> let {s = pseq [1,1,1,1,1,2,2,2,2,2,3,3,3,3,3,4,4,4,4,4] inf+>     ;d = pseq [0.5,1,2,0.25,0.25] inf}+> in audition (pbind [(K_freq,440),(K_dur,pdurStutter s d)])++Applied to frequency.++> let {s = pseq [1,1,1,1,1,2,2,2,2,2,3,3,3,3,4,4,0,4,4] inf+>     ;d = pseq [0,2,3,5,7,9,10] inf + 80}+> in audition (pbind [(K_midinote,pdurStutter s d),(K_dur,0.15)])++-}+pdurStutter :: Fractional a => P Int -> P a -> P a+pdurStutter = liftP2 P.durStutter++-- | Pexprand.  Lifted 'P.exprand'.+--+-- > > Pexprand(0.0001,1,10).asStream.all+-- > pexprand 'α' 0.0001 1 10+--+-- > > Pbind(\freq,Pexprand(0.0001,1,inf) * 600 + 300,\dur,0.02).play+--+-- > audition (pbind [(K_freq,pexprand 'α' 0.0001 1 inf * 600 + 300)+-- >                 ,(K_dur,0.02)])+pexprand :: (Enum e,Random a,Floating a) => e -> a -> a -> Int -> P a+pexprand e l r = toP . P.exprand e l r++-- | Pfinval.  Alias for 'ptake'+--+-- > > Pfinval(5,Pseq(#[1,2,3],inf)).asStream.all == [1,2,3,1,2]+-- > pfinval 5 (pseq [1,2,3] inf) == toP [1,2,3,1,2]+pfinval :: Int -> P a -> P a+pfinval = ptake++{-|+A variant of the SC3 pattern that evaluates a closure at each+step.  The haskell variant function has a 'StdGen' form.++> > p = Pfuncn({exprand(0.1,0.3) + #[1,2,3,6,7].choose},inf);+> > Pbind(\freq,p * 100 + 300,\dur,0.02).play++> let {exprand = Sound.SC3.Lang.Random.Gen.exprand+>     ;choose = Sound.SC3.Lang.Random.Gen.choose+>     ;p = pfuncn 'α' (exprand 0.1 0.3) inf+>     ;q = pfuncn 'β' (choose [1,2,3,6,7]) inf}+> in audition (pbind [(K_freq,(p + q) * 100 + 300),(K_dur,0.02)])++Of course in this case there is a pattern equivalent.++> let {p = pexprand 'α' 0.1 0.3 inf + prand 'β' [1,2,3,6,7] inf}+> in audition (pbind [(K_freq,p * 100 + 300),(K_dur,0.02)])++-}+pfuncn :: Enum e => e -> (StdGen -> (n,StdGen)) -> Int -> P n+pfuncn e f n = toP (P.funcn e f n)++{- | Pgeom.  SC3 geometric series pattern.++> > Pgeom(3,6,5).asStream.all == [3,18,108,648,3888]+> pgeom 3 6 5 == toP [3,18,108,648,3888]++> > Pgeom(1,2,10).asStream.all == [1,2,4,8,16,32,64,128,256,512]+> pgeom 1 2 10 == toP [1,2,4,8,16,32,64,128,256,512]++Real numbers work as well.++> > p = Pgeom(1.0,1.1,6).collect({|i| (i * 100).floor});+> > p.asStream.all == [100,110,121,133,146,161];++> let p = fmap (floor . (* 100)) (pgeom 1.0 1.1 6)+> in p == toP [100,110,121,133,146,161]++> > Pbind(\degree,Pseries(-7,1,15),+> >       \dur,Pgeom(0.5,0.89140193218427,15)).play;++> audition (pbind [(K_degree,pseries (-7) 1 15)+>                 ,(K_dur,pgeom 0.5 0.89140193218427 15)])++There is a list variant.++> > 5.geom(3,6)+> C.geom 5 3 6 == [3,18,108,648,3888]++-}+pgeom :: (Num a) => a -> a -> Int -> P a+pgeom i s n = toP (C.geom n i s)++-- | Pif.  SC3 /implicitly repeating/ pattern-based conditional expression.+--+-- > > a = Pfunc({0.3.coin});+-- > > b = Pwhite(0,9,3);+-- > > c = Pwhite(10,19,3);+-- > > Pfin(9,Pif(a,b,c)).asStream.all+--+-- > let {a = fmap (< 0.75) (pwhite 'α' 0.0 1.0 inf)+-- >     ;b = pwhite 'β' 0 9 6+-- >     ;c = pwhite 'γ' 10 19 6}+-- > in pif a b c * (-1) == toP [-7,-3,-11,-17,-18,-6,-3,-4,-5]+pif :: P Bool -> P a -> P a -> P a+pif = liftP3_repeat P.if_demand++-- | Place.  SC3 interlaced embedding of subarrays.+--+-- > > Place([0,[1,2],[3,4,5]],3).asStream.all == [0,1,3,0,2,4,0,1,5]+-- > C.lace 9 [[0],[1,2],[3,4,5]] == [0,1,3,0,2,4,0,1,5]+-- > place [[0],[1,2],[3,4,5]] 3 == toP [0,1,3,0,2,4,0,1,5]+--+-- > > Place(#[1,[2,5],[3,6]],2).asStream.all == [1,2,3,1,5,6]+-- > C.lace 6 [[1],[2,5],[3,6]] == [1,2,3,1,5,6]+-- > place [[1],[2,5],[3,6]] 2 == toP [1,2,3,1,5,6]+--+-- > C.lace 12 [[1],[2,5],[3,6..]] == [1,2,3,1,5,6,1,2,9,1,5,12]+-- > place [[1],[2,5],[3,6..]] 4 == toP [1,2,3,1,5,6,1,2,9,1,5,12]+place :: [[a]] -> Int -> P a+place a n =+    let f = toP . concat . take_inf n . L.transpose . map cycle+    in f a++-- | Pn.  SC3 pattern to repeat the enclosed pattern a number of+-- times.+--+-- > pn 1 4 == toP [1,1,1,1]+-- > pn (toP [1,2,3]) 3 == toP [1,2,3,1,2,3,1,2,3]+--+-- This is related to `concat`.`replicate` in standard list processing.+--+-- > concat (replicate 4 [1]) == [1,1,1,1]+-- > concat (replicate 3 [1,2,3]) == [1,2,3,1,2,3,1,2,3]+--+-- There is a `pconcatReplicate` near-alias (reversed argument order).+--+-- > pconcatReplicate 4 1 == toP [1,1,1,1]+-- > pconcatReplicate 3 (toP [1,2]) == toP [1,2,1,2,1,2]+--+-- This is productive over infinite lists.+--+-- > concat (replicate inf [1])+-- > pconcat (replicate inf 1)+-- > pconcatReplicate inf 1+pn :: P a -> Int -> P a+pn p n = mconcat (replicate n p)++{- | Ppatlace.  SC3 /implicitly repeating/ pattern to lace input patterns.++> > p = Ppatlace([1,Pseq([2,3],2),4],5);+> > p.asStream.all == [1,2,4,1,3,4,1,2,4,1,3,4,1,4]++> ppatlace [1,pseq [2,3] 2,4] 5 == toP [1,2,4,1,3,4,1,2,4,1,3,4,1,4]++> > p = Ppatlace([1,Pseed(Pn(1000,1),Prand([2,3],inf))],5);+> > p.asStream.all == [1,3,1,3,1,3,1,2,1,2]++> ppatlace [1,prand 'α' [2,3] inf] 5 == toP [1,3,1,2,1,3,1,2,1,2]++> > Pbind(\degree,Ppatlace([Pseries(0,1,8),Pseries(2,1,7)],inf),+> >       \dur,0.25).play;++> let p = [(K_degree,ppatlace [pseries 0 1 8,pseries 2 1 7] inf)+>         ,(K_dur,0.125)]+> in audition (pbind p)++-}+ppatlace :: [P a] -> Int -> P a+ppatlace a n =+    let a' = L.transpose (map unP_repeat a)+    in toP (L.concat (take_inf n a'))++{-| Prand.  SC3 pattern to make n random selections from a list of+patterns, the resulting pattern is flattened (joined).++> > p = Pseed(Pn(1000,1),Prand([1,Pseq([10,20,30]),2,3,4,5],6));+> > p.asStream.all == [3,5,3,10,20,30,2,2]++> prand 'α' [1,toP [10,20],2,3,4,5] 5 == toP [5,2,10,20,2,1]++> > Pbind(\note,Prand([0,1,5,7],inf),\dur,0.25).play++> audition (pbind [(K_note,prand 'α' [0,1,5,7] inf),(K_dur,0.25)])++Nested sequences of pitches:++> > Pbind(\midinote,Prand([Pseq(#[60,61,63,65,67,63]),+> >                        Prand(#[72,73,75,77,79],6),+> >                        Pshuf(#[48,53,55,58],2)],inf),+> >       \dur,0.25).play++> let {n = prand 'α' [pseq [60,61,63,65,67,63] 1+>                    ,prand 'β' [72,73,75,77,79] 6+>                    ,pshuf 'γ' [48,53,55,58] 2] inf}+> in audition (pbind [(K_midinote,n),(K_dur,0.075)])++The below cannot be written as intended with the list+based pattern library.  This is precisely because the+noise patterns are values, not processes with a state+threaded non-locally.++> do {n0 <- Sound.SC3.Lang.Random.IO.rrand 2 5+>    ;n1 <- Sound.SC3.Lang.Random.IO.rrand 3 9+>    ;let p = pseq [prand 'α' [pempty,pseq [24,31,36,43,48,55] 1] 1+>                  ,pseq [60,prand 'β' [63,65] 1+>                        ,67,prand 'γ' [70,72,74] 1] n0+>                  ,prand 'δ' [74,75,77,79,81] n1] inf+>     in return (ptake 24 p)}++-}+prand :: Enum e => e -> [P a] -> Int -> P a+prand = join .:: prand'++-- | Preject.  SC3 pattern to rejects values for which the predicate+-- is true.  reject f is equal to filter (not . f).+--+-- > preject (== 1) (pseq [1,2,3] 2) == toP [2,3,2,3]+-- > pfilter (not . (== 1)) (pseq [1,2,3] 2) == toP [2,3,2,3]+--+-- > > p = Pseed(Pn(1000,1),Pwhite(0,255,20).reject({|x| x.odd}));+-- > > p.asStream.all == [224,60,88,94,42,32,110,24,122,172]+--+-- > preject odd (pwhite 'α' 0 255 10) == toP [32,158,62,216,240,20]+--+-- > > p = Pseed(Pn(1000,1),Pwhite(0,255,20).select({|x| x.odd}));+-- > > p.asStream.all == [151,157,187,129,45,245,101,79,77,243]+--+-- > pselect odd (pwhite 'α' 0 255 10) == toP [241,187,119,127]+preject :: (a -> Bool) -> P a -> P a+preject f = liftP (filter (not . f))++{- | Prorate.  SC3 /implicitly repeating/ sub-dividing pattern.++> > p = Prorate(Pseq([0.35,0.5,0.8]),1);+> > p.asStream.all == [0.35,0.65,0.5,0.5,0.8,0.2];++> let p = prorate (fmap Left (pseq [0.35,0.5,0.8] 1)) 1+> in fmap roundE (p * 100) == toP [35,65,50,50,80,20]++> > p = Prorate(Pseq([0.35,0.5,0.8]),Pseed(Pn(100,1),Prand([20,1],inf)));+> > p.asStream.all == [7,13,0.5,0.5,16,4]++> let p = prorate (fmap Left (pseq [0.35,0.5,0.8] 1))+>                 (prand 'α' [20,1] 3)+> in fmap roundE (p * 100) == toP [35,65,1000,1000,80,20]++> > l = [[1,2],[5,7],[4,8,9]].collect(_.normalizeSum);+> > Prorate(Pseq(l,1)).asStream.all++> let l = map (Right . C.normalizeSum) [[1,2],[5,7],[4,8,9]]+> in prorate (toP l) 1++> > Pfinval(5,Prorate(0.6,0.5)).asStream.all == [0.3,0.2,0.3,0.2,0.3]++> pfinval 5 (prorate (fmap Left 0.6) 0.5) == toP [0.3,0.2,0.3,0.2,0.3]++> > Pbind(\degree,Pseries(4,1,inf).fold(-7,11),+> >       \dur,Prorate(0.6,0.5)).play++> audition (pbind [(K_degree,pfold (pseries 4 1 inf) (-7) 11)+>                 ,(K_dur,prorate (fmap Left 0.6) 0.25)])++-}+prorate :: Num a => P (Either a [a]) -> P a -> P a+prorate = pjoin_repeat .: pzipWith prorate'++-- | Pselect.  See 'pfilter'.+--+-- > pselect (< 3) (pseq [1,2,3] 2) == toP [1,2,1,2]+pselect :: (a -> Bool) -> P a -> P a+pselect f = liftP (filter f)++{-| Pseq.  SC3 pattern to cycle over a list of patterns. The repeats+pattern gives the number of times to repeat the entire list.++> pseq [return 1,return 2,return 3] 2 == toP [1,2,3,1,2,3]+> pseq [1,2,3] 2 == toP [1,2,3,1,2,3]+> pseq [1,pn 2 2,3] 2 == toP [1,2,2,3,1,2,2,3]++There is an 'inf' value for the repeats variable.++> ptake 3 (pdrop (10^5) (pseq [1,2,3] inf)) == toP [2,3,1]++Unlike the SC3 Pseq, `pseq` does not have an offset argument to give a+starting offset into the list.++> pseq (C.rotate 3 [1,2,3,4]) 3 == toP [2,3,4,1,2,3,4,1,2,3,4,1]++As scale degrees.++> > Pbind(\degree,Pseq(#[0,0,4,4,5,5,4],1),+> >       \dur,Pseq(#[0.5,0.5,0.5,0.5,0.5,0.5,1],1)).play++> audition (pbind [(K_degree,pseq [0,0,4,4,5,5,4] 1)+>                 ,(K_dur,pseq [0.5,0.5,0.5,0.5,0.5,0.5,1] 1)])++> > Pseq(#[60,62,63,65,67,63],inf) + Pseq(#[0,0,0,0,-12],inf)++> let n = pseq [60,62,63,65,67,63] inf + pser [0,0,0,0,-12] 25+> in audition (pbind [(K_midinote,n),(K_dur,0.2)])++Pattern `b` pattern sequences `a` once normally, once transposed up a+fifth and once transposed up a fourth.++> > a = Pseq(#[60,62,63,65,67,63]);+> > b = Pseq([a,a + 7,a + 5],inf);+> > Pbind(\midinote,b,\dur,0.3).play++> let {a = pseq [60,62,63,65,67,63] 1+>     ;b = pseq [a,a + 7,a + 5] inf}+> in audition (pbind [(K_midinote,b),(K_dur,0.13)])++-}+pseq :: [P a] -> Int -> P a+pseq a i =+    let a' = mconcat a+    in if i == inf then pcycle a' else pn a' i++-- | Pser.  SC3 pattern that is like 'pseq', however the repeats+-- variable gives the number of elements in the sequence, not the+-- number of cycles of the pattern.+--+-- > pser [1,2,3] 5 == toP [1,2,3,1,2]+-- > pser [1,pser [10,20] 3,3] 9 == toP [1,10,20,10,3,1,10,20,10]+-- > pser [1,2,3] 5 * 3 == toP [3,6,9,3,6]+pser :: [P a] -> Int -> P a+pser a i = ptake i (pcycle (mconcat a))++-- | Pseries.  SC3 arithmetric series pattern, see also 'pgeom'.+--+-- > pseries 0 2 10 == toP [0,2,4,6,8,10,12,14,16,18]+-- > pseries 9 (-1) 10 == toP [9,8 .. 0]+-- > pseries 1.0 0.2 3 == toP [1.0::Double,1.2,1.4]+pseries :: (Num a) => a -> a -> Int -> P a+pseries i s n = toP (C.series n i s)++{- | Pshuf.  SC3 pattern to return @n@ repetitions of a shuffled+-- sequence.++> > Pshuf([1,2,3,4],2).asStream.all+> pshuf 'α' [1,2,3,4] 2 == toP [2,4,3,1,2,4,3,1]++> > Pbind(\degree,Pshuf([0,1,2,4,5],inf),\dur,0.25).play++> audition (pbind [(K_degree,pshuf 'α' [0,1,2,4,5] inf)+>                 ,(K_dur,0.25)])++-}+pshuf :: Enum e => e -> [a] -> Int -> P a+pshuf e a =+    let (a',_) = R.scramble a (mkStdGen (fromEnum e))+    in pn (toP a')++{- | Pslide.  Lifted 'P.slide'.++> > Pslide([1,2,3,4],inf,3,1,0).asStream.all+> pslide [1,2,3,4] 4 3 1 0 True == toP [1,2,3,2,3,4,3,4,1,4,1,2]+> pslide [1,2,3,4,5] 3 3 (-1) 0 True == toP [1,2,3,5,1,2,4,5,1]++> > Pbind(\degree,Pslide((-6,-4 .. 12),8,3,1,0),+> >       \dur,Pseq(#[0.1,0.1,0.2],inf),+> >       \sustain,0.15).play++> audition (pbind [(K_degree,pslide [-6,-4 .. 12] 8 3 1 0 True)+>                 ,(K_dur,pseq [0.05,0.05,0.1] inf)+>                 ,(K_sustain,0.15)])++-}+pslide :: [a] -> Int -> Int -> Int -> Int -> Bool -> P a+pslide = toP .::::: P.slide++{- | Pstutter.  SC3 /implicitly repeating/ pattern to repeat each+-- element of a pattern /n/ times.++> > Pstutter(2,Pseq([1,2,3],1)).asStream.all == [1,1,2,2,3,3]+> pstutter 2 (pseq [1,2,3] 1) == toP [1,1,2,2,3,3]++The count input may be a pattern.++> let {p = pseq [1,2] inf+>     ;q = pseq [1,2,3] 2}+> in pstutter p q == toP [1,2,2,3,1,1,2,3,3]++> pstutter (toP [1,2,3]) (toP [4,5,6]) == toP [4,5,5,6,6,6]+> pstutter 2 (toP [4,5,6]) == toP [4,4,5,5,6,6]++Stutter scale degree and duration with the same random sequence.++> > Pbind(\n,Pwhite(3,10,inf),+> >       \degree,Pstutter(Pkey(\n),Pwhite(-4,11,inf)),+> >       \dur,Pstutter(Pkey(\n),Pwhite(0.05,0.4,inf)),+> >       \legato,0.3).play++> let {n = pwhite 'α' 3 10 inf+>     ;p = [(K_degree,pstutter n (pwhitei 'β' (-4) 11 inf))+>          ,(K_dur,pstutter n (pwhite 'γ' 0.05 0.4 inf))+>          ,(K_legato,0.3)]}+> in audition (pbind p)++-}+pstutter :: P Int -> P a -> P a+pstutter = liftP2_repeat P.stutter++-- | Pswitch.  Lifted 'P.switch'.+--+-- > let p = pswitch [pseq [1,2,3] 2,pseq [65,76] 1,800] (toP [2,2,0,1])+-- > in p == toP [800,800,1,2,3,1,2,3,65,76]+pswitch :: [P a] -> P Int -> P a+pswitch l = liftP (P.switch (map unP l))++-- | Pswitch1.  Lifted /implicitly repeating/ 'P.switch1'.+--+-- > > l = [Pseq([1,2,3],inf),Pseq([65,76],inf),8];+-- > > p = Pswitch1(l,Pseq([2,2,0,1],3));+-- > > p.asStream.all == [8,8,1,65,8,8,2,76,8,8,3,65];+--+-- > let p = pswitch1 [pseq [1,2,3] inf+-- >                  ,pseq [65,76] inf+-- >                  ,8] (pseq [2,2,0,1] 6)+-- > in p == toP [8,8,1,65,8,8,2,76,8,8,3,65,8,8,1,76,8,8,2,65,8,8,3,76]+pswitch1 :: [P a] -> P Int -> P a+pswitch1 l = liftP (P.switch1 (map unP_repeat l))++-- | Ptuple.  'pseq' of 'ptranspose_st_repeat'.+--+-- > > l = [Pseries(7,-1,8),3,Pseq([9,7,4,2],1),Pseq([4,2,0,0,-3],1)];+-- > > p = Ptuple(l,1);+-- > > p.asStream.all == [[7,3,9,4],[6,3,7,2],[5,3,4,0],[4,3,2,0]]+--+-- > let p = ptuple [pseries 7 (-1) 8+-- >                ,3+-- >                ,pseq [9,7,4,2] 1+-- >                ,pseq [4,2,0,0,-3] 1] 1+-- > in p == toP [[7,3,9,4],[6,3,7,2],[5,3,4,0],[4,3,2,0]]+ptuple :: [P a] -> Int -> P [a]+ptuple p = pseq [ptranspose_st_repeat p]++{- | Pwhite.  Lifted 'P.white'.++> pwhite 'α' 0 9 5 == toP [3,0,1,6,6]+> pwhite 'α' 0 9 5 - pwhite 'α' 0 9 5 == toP [0,0,0,0,0]++The pattern below is alternately lower and higher noise.++> let {l = pseq [0.0,9.0] inf+>     ;h = pseq [1.0,12.0] inf}+> in audition (pbind [(K_freq,pwhite' 'α' l h * 20 + 800)+>                    ,(K_dur,0.25)])++-}+pwhite :: (Random n,Enum e) => e -> n -> n -> Int -> P n+pwhite = toP .::: P.white++{- | Pwrand.  Lifted 'P.wrand'.++> let w = C.normalizeSum [12,6,3]+> in pwrand 'α' [1,2,3] w 6 == toP [2,1,2,3,3,2]++> > r = Pwrand.new([1,2,Pseq([3,4],1)],[1,3,5].normalizeSum,6);+> > p = Pseed(Pn(100,1),r);+> > p.asStream.all == [2,3,4,1,3,4,3,4,2]++> let w = C.normalizeSum [1,3,5]+> in pwrand 'ζ' [1,2,pseq [3,4] 1] w 6 == toP [3,4,2,2,3,4,1,3,4]++> > Pbind(\degree,Pwrand((0..7),[4,1,3,1,3,2,1].normalizeSum,inf),+> >       \dur,0.25).play;++> let {w = C.normalizeSum [4,1,3,1,3,2,1]+>     ;d = pwrand 'α' (C.series 7 0 1) w inf}+> in audition (pbind [(K_degree,d),(K_dur,0.25)])++-}+pwrand :: (Enum e) => e -> [P a] -> [Double] -> Int -> P a+pwrand e a w = toP . P.wrand e (map unP a) w++-- | Pwrap.  Type specialised 'P.fwrap', see also 'pfold'.+--+-- > > p = Pwrap(Pgeom(200,1.25,9),200,1000.0);+-- > > r = p.asStream.all.collect({|n| n.round});+-- > > r == [200,250,313,391,488,610,763,954,392];+--+-- > let p = fmap roundE (pwrap (pgeom 200 1.25 9) 200 1000)+-- > in p == toP [200,250,312,391,488,610,763,954,391]+pwrap :: (Ord a,Num a) => P a -> a -> a -> P a+pwrap = P.fwrap++-- | Pxrand.  Lifted 'P.xrand'.+--+-- > let p = pxrand 'α' [1,toP [2,3],toP [4,5,6]] 9+-- > in p == toP [4,5,6,2,3,4,5,6,1]+--+-- > > Pbind(\note,Pxrand([0,1,5,7],inf),\dur,0.25).play+--+-- > audition (pbind [(K_note,pxrand 'α' [0,1,5,7] inf),(K_dur,0.25)])+pxrand :: Enum e => e -> [P a] -> Int -> P a+pxrand e a n = toP (P.xrand e (map unP a) n)++-- * Variant SC3 Patterns++-- | Lifted /implicitly repeating/ 'P.pbrown''.+--+-- > pbrown' 'α' 1 700 (pseq [1,20] inf) 4 == toP [415,419,420,428]+pbrown' :: (Enum e,Random n,Num n,Ord n) =>+           e -> P n -> P n -> P n -> Int -> P n+pbrown' e l r s n =+    let f = liftP3_repeat (I.brown e)+    in ptake n (f l r s)++-- | Un-joined variant of 'prand'.+--+-- > let p = prand' 'α' [1,toP [2,3],toP [4,5,6]] 5+-- > in p == toP [toP [4,5,6],toP [4,5,6],toP [2,3],toP [4,5,6],1]+prand' :: Enum e => e -> [P a] -> Int -> P (P a)+prand' e a n = toP (P.rand' e a n)++-- | Underlying pattern for 'prorate'.+--+-- > prorate' (Left 0.6) 0.5+prorate' :: Num a => Either a [a] -> a -> P a+prorate' p =+    case p of+      Left p' -> toP . P.rorate_n' p'+      Right p' -> toP . P.rorate_l' p'++{-|+Variant of `pseq` that retrieves only one value from each pattern+on each list traversal.  Compare to `pswitch1`.++> pseq [pseq [1,2] 1,pseq [3,4] 1] 2 == toP [1,2,3,4,1,2,3,4]+> pseq1 [pseq [1,2] 1,pseq [3,4] 1] 2 == toP [1,3,2,4]+> pseq1 [pseq [1,2] inf,pseq [3,4] inf] 3 == toP [1,3,2,4,1,3]++> let {p = prand' 'α' [pempty,toP [24,31,36,43,48,55]] inf+>     ;q = pflop [60,prand 'β' [63,65] inf+>                ,67,prand 'γ' [70,72,74] inf]+>     ;r = psplitPlaces (pwhite 'δ' 3 9 inf)+>                       (toP [74,75,77,79,81])+>     ;n = pjoin (pseq1 [p,q,r] inf)}+> in audition (pbind [(K_midinote,n),(K_dur,0.13)])++-}+pseq1 :: [P a] -> Int -> P a+pseq1 a i = join (ptake i (pflop a))++-- | A variant of 'pseq' to aid translating a common SC3 idiom where a+-- finite random pattern is included in a @Pseq@ list.  In the SC3+-- case, at each iteration a new computation is run.  This idiom does+-- not directly translate to the declarative haskell pattern library.+--+-- > > Pseq([1,Prand([2,3],1)],5).asStream.all+-- > pseq [1,prand 'α' [2,3] 1] 5 == toP [1,3,1,3,1,3,1,3,1,3]+--+-- Although the intended pattern can usually be expressed using an+-- alternate construction:+--+-- > > Pseq([1,Prand([2,3],1)],5).asStream.all+-- > ppatlace [1,prand 'α' [2,3] inf] 5 == toP [1,3,1,2,1,3,1,2,1,2]+--+-- the 'pseqn' variant handles many common cases.+--+-- > > Pseq([Pn(8,2),Pwhite(9,16,1)],5).asStream.all+--+-- > let p = pseqn [2,1] [8,pwhite 'α' 9 16 inf] 5+-- > in p == toP [8,8,10,8,8,9,8,8,12,8,8,15,8,8,15]+pseqn :: [Int] -> [P a] -> Int -> P a+pseqn n q =+    let rec p c = if c == 0+                  then mempty+                  else let (i,j) = unzip (zipWith psplitAt n p)+                       in mconcat i <> rec j (c - 1)+    in rec (map pcycle q)++{-|++A variant of 'pseq' that passes a new seed at each invocation,+see also 'pfuncn'.++> > pseqr (\e -> [pshuf e [1,2,3,4] 1]) 2 == toP [2,3,4,1,4,1,2,3]++> let {d = pseqr (\e -> [pshuf e [-7,-3,0,2,4,7] 4+>                       ,pseq [0,1,2,3,4,5,6,7] 1]) inf}+> in audition (pbind [(K_degree,d),(K_dur,0.15)])++> > Pbind(\dur,0.2,+> >       \midinote,Pseq([Pshuf(#[60,61,62,63,64,65,66,67],3)],inf)).play++> let {m = pseqr (\e -> [pshuf e [60,61,62,63,64,65,66,67] 3]) inf}+> in audition (pbind [(K_dur,0.2),(K_midinote,m)])++-}+pseqr :: (Int -> [P a]) -> Int -> P a+pseqr f n = mconcat (L.concatMap f [1 .. n])++-- | Variant of 'pser' that consumes sub-patterns one element per+-- iteration.+--+-- > pser1 [1,pser [10,20] 3,3] 9 == toP [1,10,3,1,20,3,1,10,3]+pser1 :: [P a] -> Int -> P a+pser1 a i = ptake i (join (pflop a))++-- | Lifted /implicitly repeating/ 'P.pwhite'.+--+-- > pwhite' 'α' 0 (pseq [9,19] 3) == toP [3,0,1,6,6,15]+pwhite' :: (Enum e,Random n) => e -> P n -> P n -> P n+pwhite' e = liftP2_repeat (P.white' e)++-- | Lifted 'P.whitei'.+--+-- > pwhitei 'α' 1 9 5 == toP [5,1,7,7,8]+--+-- > audition (pbind [(K_degree,pwhitei 'α' 0 8 inf),(K_dur,0.15)])+pwhitei :: (RealFracE n,Random n,Enum e) => e -> n -> n -> Int -> P n+pwhitei =  toP .::: P.whitei++-- * UId variants++-- | 'liftUId' of 'pbrown'.+pbrownM :: (UId m,Num n,Ord n,Random n) => n -> n -> n -> Int -> m (P n)+pbrownM = liftUId4 pbrown++-- | 'liftUId' of 'pexprand'.+pexprandM :: (UId m,Random a,Floating a) => a -> a -> Int -> m (P a)+pexprandM = liftUId3 pexprand++-- | 'liftUId' of 'prand'.+prandM :: UId m => [P a] -> Int -> m (P a)+prandM = liftUId2 prand++-- | 'liftUId' of 'pshuf'.+pshufM :: UId m => [a] -> Int -> m (P a)+pshufM = liftUId2 pshuf++-- | 'liftUId' of 'pwhite'.+pwhiteM :: (UId m,Random n) => n -> n -> Int -> m (P n)+pwhiteM = liftUId3 pwhite++-- | 'liftUId' of 'pwhitei'.+pwhiteiM :: (UId m,RealFracE n,Random n) => n -> n -> Int -> m (P n)+pwhiteiM = liftUId3 pwhitei++-- | 'liftUId' of 'pwrand'.+pwrandM :: UId m => [P a] -> [Double] -> Int -> m (P a)+pwrandM = liftUId3 pwrand++-- | 'liftUId' of 'pxrand'.+pxrandM :: UId m => [P a] -> Int -> m (P a)+pxrandM = liftUId2 pxrand

@@ -0,0 +1,5 @@+module Sound.SC3.Lang.Pattern.Plain (module P) where++import Sound.SC3.Lang.Math as P+import Sound.SC3.Lang.Pattern.Bind as P+import Sound.SC3.Lang.Pattern.Stream as P

@@ -0,0 +1,139 @@+-- | Infinte list @SC3@ pattern functions.+module Sound.SC3.Lang.Pattern.Stream where++import Data.List {- base -}+import Data.Maybe {- base -}+import System.Random {- random -}++import qualified Sound.SC3 as S {- hsc3 -}++import Sound.SC3.Lang.Core {- hsc3-lang -}+import qualified Sound.SC3.Lang.Math as M {- hsc3-lang -}+import qualified Sound.SC3.Lang.Random.Gen as R++-- | Remove successive duplicates.+--+-- > rsd [1,2,3,1,2,3] == [1,2,3,1,2,3]+rsd :: (Eq a) => [a] -> [a]+rsd =+    let f (p,_) i = (Just i,if Just i == p then Nothing else Just i)+    in mapMaybe snd . scanl f (Nothing,Nothing)++-- | True if /a/ is initially equal to /b/.+iEq :: Eq a => [a] -> [a] -> Bool+iEq = flip isPrefixOf++-- | Take elements from /l/ until all elements in /s/ have been seen.+-- If /s/ contains duplicate elements these must be seen multiple+-- times.+--+-- > take_until_forms_set "abc" "a random sentence beginning" == "a random sentence b"+take_until_forms_set :: Eq a => [a] -> [a] -> [a]+take_until_forms_set s l =+    if null s+    then []+    else case l of+           [] -> []+           e:l' -> e : take_until_forms_set (delete e s) l'++-- | Underlying 'brown'.+brown_ :: (RandomGen g,Random n,Num n,Ord n) => (n,n,n) -> (n,g) -> (n,g)+brown_ (l,r,s) (n,g) =+    let (i,g') = randomR (-s,s) g+    in (S.foldToRange l r (n + i),g')++-- | Brown noise with list inputs.+--+-- > let l = brown 'α' (repeat 1) (repeat 700) (cycle [1,20])+-- > in l `iEq` [415,419,420,428]+brown :: (Enum e,Random n,Num n,Ord n) => e -> [n] -> [n] -> [n] -> [n]+brown e l_ r_ s_ =+    let i = (randomR (head l_,head r_) (mkStdGen (fromEnum e)))+        rec (n,g) z =+            case z of+              [] -> []+              (l,r,s):z' -> let (n',g') = brown_ (l,r,s) (n,g)+                            in n' : rec (n',g') z'+    in rec i (zip3 l_ r_ s_)++-- | 'M.exprange' of 'white'+exprand :: (Enum e,Random a,Floating a) => e -> a -> a -> [a]+exprand e l r = fmap (M.exprange l r) (white e 0 1)++-- | Geometric series.+--+-- > geom 3 6 `iEq` [3,18,108,648,3888,23328,139968]+geom :: Num a => a -> a -> [a]+geom i s = iterate (* s) i++-- > lace [[0],[1,2],[3,4,5]] `iEq` [0,1,3,0,2,4,0,1,5]+-- > lace [[1],[2,5],[3,6]] `iEq` [1,2,3,1,5,6]+-- > lace [[1],[2,5],[3,6..]] `iEq` [1,2,3,1,5,6,1,2,9,1,5,12]+lace :: [[a]] -> [a]+lace = concat . transpose . map cycle++-- | Random elements from list.+--+-- > take_until_forms_set "string" (rand 'α' "string") == "grtrsiirn"+rand :: Enum e => e -> [a] -> [a]+rand e a =+    let k = length a - 1+    in map (a !!) (white e 0 k)++-- | List section with /wrapped/ indices.+--+-- > segment [0..4] 5 (3,5) == [3,4,0]+segment :: [a] -> Int -> (Int,Int) -> [a]+segment a k (l,r) =+    let i = map (S.genericWrap 0 (k - 1)) [l .. r]+    in map (a !!) i++-- > slide [1,2,3,4] 4 1 0 True `iEq` [[1,2,3,4],[2,3,4,1],[3,4,1,2],[4,1,2,3]]+-- > slide [1,2,3,4,5] 3 (-1) 0 True `iEq` [[1,2,3],[5,1,2],[4,5,1],[3,4,5],[2,3,4]]+slide :: [a] -> Int -> Int -> Int -> Bool -> [[a]]+slide a j s i wr =+    let k = length a+        l = enumFromThen i (i + s)+        r = map (+ (j - 1)) l+    in if wr+       then map (segment a k) (zip l r)+       else error "slide: non-wrap variant not implemented"++-- | 'concat' of 'slide'.+slidec :: [a] -> Int -> Int -> Int -> Bool -> [a]+slidec = concat .:::: slide++-- | White noise.+--+-- > take_until_forms_set [1..5] (white 'α' 1 5) == [4,1,2,2,2,1,2,1,2,5,1,4,3]+white :: (Random n,Enum e) => e -> n -> n -> [n]+white e l r = randomRs (l,r) (mkStdGen (fromEnum e))++-- | Weighted selection of elements from a list.+wrand_generic :: (Enum e,Fractional n,Ord n,Random n) => e -> [a] -> [n] -> [a]+wrand_generic e a w =+    let f g = let (r,g') = R.wchoose a w g+              in r : f g'+    in if length a /= length w+       then error "wrand_generic: a/w must be of equal length"+       else f (mkStdGen (fromEnum e))++-- | Type restricted variant.+--+-- > import qualified Sound.SC3.Lang.Collection as C+--+-- > let {w = C.normalizeSum [1..5]+-- >     ;r = wrand 'ζ' "wrand" w}+-- > in take_until_forms_set "wrand" r == "dnanrdnaddrnrrndrrdw"+wrand :: Enum e => e -> [a] -> [Double] -> [a]+wrand = wrand_generic++-- | Select elements from /l/ in random sequence, but do not immediately repeat an element.+--+-- > take_until_forms_set "string" (xrand 'α' "string") == "grtrsirn"+xrand :: Enum e => e -> [a] -> [a]+xrand e a =+    let g = mkStdGen (fromEnum e)+        k = length a - 1+        r = rsd (randomRs (0,k) g)+    in map (a !!) r

@@ -1,36 +1,71 @@ -- | 'RandomGen' based @sclang@ random number functions. module Sound.SC3.Lang.Random.Gen where +import qualified Data.DList as DL {- dlist -} import Data.Maybe {- base  -} import System.Random {- random -} import System.Random.Shuffle {- random-shuffle -}  import qualified Sound.SC3.Lang.Collection as C+import Sound.SC3.Lang.Core import qualified Sound.SC3.Lang.Math as M  -- | @SimpleNumber.rand@ is 'randomR' in (0,/n/). rand :: (RandomGen g,Random n,Num n) => n -> g -> (n,g) rand n = randomR (0,n) --- | Construct variant of /f/ generating /k/ values.-kvariant :: Int -> (g->(a,g)) -> g->([a],g)-kvariant k f =+-- | State modifying variant of 'iterate'.  Lifts random generator+-- functions to infinte lists.+--+-- > let r = [3,1,7,0,12,1,6,4,12,11,7,4]+-- > in take 12 (r_iterate (rand 12) (mkStdGen 0)) == r+r_iterate :: (t -> (a, t)) -> t -> [a]+r_iterate f g = let (r,g') = f g in r : r_iterate f g'++-- | Function underlying both 'kvariant' and 'kvariant''.+mk_kvariant :: r -> (t -> r -> r) -> (r -> r') -> Int -> (g -> (t,g)) -> g -> (r',g)+mk_kvariant k_nil k_join un_k k f =     let go x i g = case i of-                     0 -> (x,g)+                     0 -> (un_k x,g)                      _ -> let (y,g') = f g-                          in go (y:x) (i - 1) g'-    in go [] k+                          in go (k_join y x) (i - 1) g'+    in go k_nil k +-- | Construct variant of /f/ generating /k/ values.  Note that the+-- result is the reverse of the initial sequence given by 'r_iterate'.+--+-- > let r = [3,1,7,0,12,1,6,4,12,11,7,4]+-- > in fst (kvariant 12 (rand 12) (mkStdGen 0)) == reverse r+kvariant :: Int -> (g->(a,g)) -> g->([a],g)+kvariant = mk_kvariant [] (:) id++-- | Variant of 'kvariant' that generates sequence in the same order+-- as 'r_iterate'.  There is perhaps a slight overhead from using a+-- difference list.+--+-- > let r = [3,1,7,0,12,1,6,4,12,11,7,4]+-- > in fst (kvariant' 12 (rand 12) (mkStdGen 0)) == r+kvariant' :: Int -> (g->(a,g)) -> g->([a],g)+kvariant' = mk_kvariant DL.empty (flip DL.snoc) DL.toList+ -- | Variant of 'rand' generating /k/ values. -- -- > fst (nrand 10 (5::Int) (mkStdGen 246873)) == [0,5,4,0,4,5,3,2,3,1] nrand :: (RandomGen g,Random n,Num n) => Int -> n -> g -> ([n],g) nrand k = kvariant k . rand +-- | Stream variant of 'rand'.+s_rand :: (RandomGen g,Random n,Num n) => n -> g -> [n]+s_rand = r_iterate . rand+ -- | @SimpleNumber.rand2@ is 'randomR' in (-/n/,/n/). rand2 :: (RandomGen g,Random n,Num n) => n -> g -> (n,g) rand2 n = randomR (-n,n) +-- | Stream variant of 'rand2'.+s_rand2 :: (RandomGen g,Random n,Num n) => n -> g -> [n]+s_rand2 = r_iterate . rand2+ -- | Variant of 'rand2' generating /k/ values. nrand2 :: (RandomGen g,Random a,Num a) => Int -> a -> g -> ([a],g) nrand2 k = kvariant k . rand2@@ -41,7 +76,7 @@  -- | Variant of 'rrand' generating /k/ values. nrrand :: (RandomGen g,Random a,Num a) => Int -> a -> a -> g -> ([a],g)-nrrand k l = kvariant k . rrand l+nrrand k = kvariant k .: rrand  -- | @SequenceableCollection.choose@ selects an element at random. choose :: RandomGen g => [a] -> g -> (a,g)@@ -63,7 +98,7 @@ -- | Variant of 'exprand' generating /k/ values. nexprand :: (Floating n,Random n,RandomGen g) =>             Int -> n -> n -> g -> ([n],g)-nexprand k l = kvariant k . exprand l+nexprand k = kvariant k .: exprand  -- | @SimpleNumber.coin@ is 'True' at given probability, which is in -- range (0,1).@@ -88,8 +123,21 @@  -- | @SequenceableCollection.wchoose@ selects an element from a list -- given a list of weights which sum to @1@.+--+-- > kvariant 10 (wchoose "abcd" (C.normalizeSum [8,4,2,1])) (mkStdGen 0) wchoose :: (RandomGen g,Random a,Ord a,Fractional a) => [b] -> [a] -> g -> (b,g) wchoose l w g =   let (i,g') = randomR (0.0,1.0) g       n = fromMaybe (error "wchoose: windex") (C.windex w i)   in (l !! n,g')++-- | Variant that applies 'C.normalizeSum' to weights.+--+-- > let r = "dcbbacaadd"+-- > in r == fst (kvariant 10 (wchoose_N "abcd" [8,4,2,1]) (mkStdGen 0))+wchoose_N :: (Fractional a,Ord a,RandomGen g,Random a) => [b] -> [a] -> g -> (b, g)+wchoose_N l w = wchoose l (C.normalizeSum w)++-- | 'kvariant' of 'wchoose_N'.+nwchoose_N :: (Fractional a,Ord a,RandomGen g,Random a) => Int -> [b] -> [a] -> g -> ([b], g)+nwchoose_N n = kvariant n .: wchoose_N

@@ -0,0 +1,18 @@+-- | 'ID' variants of "Sound.SC3.Lang.Random.Gen".+module Sound.SC3.Lang.Random.ID where++import System.Random {- random -}++import qualified Sound.SC3.Lang.Random.Gen as G++id_rand :: Enum e => e -> (StdGen -> (a,StdGen)) -> a+id_rand e f = fst (f (mkStdGen (fromEnum e)))++nchoose :: Enum e => e -> Int -> [a] -> [a]+nchoose e n l = id_rand e (G.nchoose n l)++rand :: (Random a, Num a, Enum e) => e -> a -> a+rand e n = id_rand e (G.rand n)++rrand :: (Random a, Num a, Enum e) => e -> a -> a -> a+rrand e l r = id_rand e (G.rrand l r)

@@ -4,6 +4,7 @@ import Control.Monad.IO.Class {- transformers -} import System.Random {- random -} +import Sound.SC3.Lang.Core import Sound.SC3.Lang.Random.Gen as R  -- | 'liftIO' of 'randomRIO'.@@ -24,7 +25,7 @@  -- | Variant of 'rand2' generating /k/ values. nrand2 :: (Random a, Num a) => Int -> a -> IO [a]-nrand2 k = randomG . R.nrand2 k+nrand2 = randomG .: R.nrand2  -- | @SimpleNumber.rrand@ is 'curry' 'randomRIO'. rrand :: (MonadIO m,Random n) => n -> n -> m n@@ -32,7 +33,7 @@  -- | Variant of 'rrand' generating /k/ values. nrrand :: (MonadIO m,Random a, Num a) => Int -> a -> a -> m [a]-nrrand k l = randomG . R.nrrand k l+nrrand = randomG .:: R.nrrand  -- | @SequenceableCollection.choose@ selects an element at random. choose :: MonadIO m => [a] -> m a@@ -41,7 +42,7 @@ -- | @SimpleNumber.exprand@ generates exponentially distributed random -- number in the given interval. exprand :: (MonadIO m,Floating n,Random n) => n -> n -> m n-exprand l = randomG . R.exprand l+exprand = randomG .: R.exprand  -- | @SimpleNumber.coin@ is 'True' at given probability, which is in -- range (0,1).@@ -55,5 +56,5 @@ -- | @SequenceableCollection.wchoose@ selects an element from a list -- given a list of weights which sum to @1@. wchoose :: (MonadIO m,Random a,Ord a,Fractional a) => [b] -> [a] -> m b-wchoose l = randomG . R.wchoose l+wchoose = randomG .: R.wchoose 

@@ -24,6 +24,8 @@  -- | §4.3.5 (τ=1) --+-- > h [map (cauchy 1.0) r]+-- -- > import Data.Maybe -- > let narrow z n = if n < -z || n > z then Nothing else Just n -- > h [mapMaybe (narrow 10 . cauchy 1.0) r]@@ -63,10 +65,13 @@ -- | §4.4.2 (Algorithm 15) -- -- > let adj l = case l of {[] -> []; p:q:l' -> (p,q) : adj l'}--- > h [mapMaybe (beta 0.5 0.5) (adj r)]--- > h [mapMaybe (beta 0.25 0.25) (adj r)]--- > h [mapMaybe (beta 0.75 0.5) (adj r)]--- > h [mapMaybe (beta 0.5 0.75) (adj r)]+-- > let r' = adj r+-- > h [mapMaybe (beta 0.45 0.45) r'+-- >   ,mapMaybe (beta 0.65 0.45) r'+-- >   ,mapMaybe (beta 0.45 0.65) r']+--+-- > h [mapMaybe (beta 0.35 0.5) r'+-- >   ,mapMaybe (beta 0.5 0.65) r'] beta :: (Floating a,Ord a) => a -> a -> (a,a) -> Maybe a beta a b (u1,u2) =     let ea = 1.0 / a

@@ -3,7 +3,10 @@  import Control.Monad {- base -} import Control.Monad.Random {- MonadRandom -}+import Data.Maybe {- base  -} +import qualified Sound.SC3.Lang.Collection as C+import Sound.SC3.Lang.Core import qualified Sound.SC3.Lang.Math as M  -- | @SimpleNumber.rand@ is 'getRandomR' in (0,/n/).@@ -41,7 +44,7 @@ -- -- > evalRand (nrrand 4 3 9) (mkStdGen 1) == [5,8,9,6] nrrand :: (RandomGen g,Random n,Num n) => Int -> n -> n -> Rand g [n]-nrrand k l = replicateM k . rrand l+nrrand k = replicateM k .: rrand  -- | @SequenceableCollection.choose@ selects an element at random. --@@ -51,6 +54,15 @@   i <- rand (length l - 1)   return (l !! i) +wchoose :: (RandomGen g,Fractional t,Ord t,Random t) => [a] -> [t] -> Rand g a+wchoose l w = do+  i <- rrand 0.0 1.0+  let n = fromMaybe (error "wchoose: windex") (C.windex w i)+  return (l !! n)++wchoose_N :: (RandomGen g,Fractional t,Ord t,Random t) => [a] -> [t] -> Rand g a+wchoose_N l w = wchoose l (C.normalizeSum w)+ -- | Variant of 'choose' generating /k/ values. -- -- > evalRand (nchoose 4 [3..9]) (mkStdGen 1) == [5,8,9,6]@@ -72,4 +84,5 @@ -- > let r = nexprand 3 10 100 >>= return . map floor -- > in evalRand r (mkStdGen 1) == [22,21,13] nexprand :: (Floating n,Random n,RandomGen g) => Int -> n -> n -> Rand g [n]-nexprand k l = replicateM k . exprand l+nexprand k = replicateM k .: exprand+

@@ -1,16 +1,16 @@ Name:              hsc3-lang-Version:           0.14+Version:           0.15 Synopsis:          Haskell SuperCollider Language Description:       Haskell library defining operations from the                    SuperCollider language class library License:           GPL Category:          Sound-Copyright:         (c) Rohan Drape, 2007-2013+Copyright:         (c) Rohan Drape, 2007-2014 Author:            Rohan Drape Maintainer:        rd@slavepianos.org Stability:         Experimental-Homepage:          http://rd.slavepianos.org/?t=hsc3-lang-Tested-With:       GHC == 7.6.1+Homepage:          http://rd.slavepianos.org/t/hsc3-lang+Tested-With:       GHC == 7.8.2 Build-Type:        Simple Cabal-Version:     >= 1.8 @@ -23,37 +23,54 @@                    bytestring,                    containers,                    data-default,+                   data-ordlist,+                   dlist,+                   hashable,                    hmatrix-special,-                   hosc == 0.14.*,-                   hsc3 == 0.14.*,+                   hosc == 0.15.*,+                   hsc3 == 0.15.*,                    MonadRandom,                    transformers,                    split,                    random,                    random-shuffle,-                   transformers+                   transformers,+                   vector   GHC-Options:     -Wall -fwarn-tabs   Exposed-modules: Sound.SC3.Lang.Collection+                   Sound.SC3.Lang.Collection.Array                    Sound.SC3.Lang.Collection.Extension                    Sound.SC3.Lang.Collection.Numerical.Extending                    Sound.SC3.Lang.Collection.Numerical.Truncating                    Sound.SC3.Lang.Collection.Universal.Datum+                   Sound.SC3.Lang.Collection.Vector                    Sound.SC3.Lang.Control.Duration                    Sound.SC3.Lang.Control.Event                    Sound.SC3.Lang.Control.Instrument                    Sound.SC3.Lang.Control.Midi+                   Sound.SC3.Lang.Control.Midi.ST                    Sound.SC3.Lang.Control.Pitch                    Sound.SC3.Lang.Control.OverlapTexture+                   Sound.SC3.Lang.Core+                   Sound.SC3.Lang.Data.CMUdict                    Sound.SC3.Lang.Data.Modal                    Sound.SC3.Lang.Data.Vowel                    Sound.SC3.Lang.Math                    Sound.SC3.Lang.Math.Warp                    Sound.SC3.Lang.Math.Window                    Sound.SC3.Lang.Pattern-                   Sound.SC3.Lang.Pattern.ID+                   Sound.SC3.Lang.Pattern.Bind                    Sound.SC3.Lang.Pattern.List+                   Sound.SC3.Lang.Pattern.P+                   Sound.SC3.Lang.Pattern.P.Base+                   Sound.SC3.Lang.Pattern.P.Core+                   Sound.SC3.Lang.Pattern.P.Event+                   Sound.SC3.Lang.Pattern.P.SC3+                   Sound.SC3.Lang.Pattern.Plain+                   Sound.SC3.Lang.Pattern.Stream                    Sound.SC3.Lang.Random.Lorrain_1980                    Sound.SC3.Lang.Random.Gen+                   Sound.SC3.Lang.Random.ID                    Sound.SC3.Lang.Random.IO                    Sound.SC3.Lang.Random.Monad