hsc3-lang 0.13 → 0.14

raw patch · 20 files changed

+3910/−2028 lines, 20 filesdep +bifunctorsdep −mtldep ~hoscdep ~hsc3PVP ok

version bump matches the API change (PVP)

Dependencies added: bifunctors

Dependencies removed: mtl

Dependency ranges changed: hosc, hsc3

API changes (from Hackage documentation)

Files

• README +1/−1
• Sound/SC3/Lang/Collection.hs +161/−152
• Sound/SC3/Lang/Collection/Universal/Datum.hs +271/−142
• Sound/SC3/Lang/Control/Duration.hs +69/−54
• Sound/SC3/Lang/Control/Event.hs +698/−236
• Sound/SC3/Lang/Control/Instrument.hs +31/−20
• Sound/SC3/Lang/Control/Midi.hs +31/−21
• Sound/SC3/Lang/Control/OverlapTexture.hs +28/−20
• Sound/SC3/Lang/Control/Pitch.hs +91/−85
• Sound/SC3/Lang/Math.hs +63/−39
• Sound/SC3/Lang/Math/Warp.hs +8/−8
• Sound/SC3/Lang/Math/Window.hs +9/−8
• Sound/SC3/Lang/Pattern.hs +9/−0
• Sound/SC3/Lang/Pattern/ID.hs +1957/−1115
• Sound/SC3/Lang/Pattern/List.hs +411/−103
• Sound/SC3/Lang/Random/Gen.hs +5/−4
• Sound/SC3/Lang/Random/IO.hs +5/−2
• Sound/SC3/Lang/Random/Lorrain_1980.hs +52/−11
• Sound/SC3/Lang/Random/Monad.hs +3/−2
• hsc3-lang.cabal +7/−5

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

@@ -3,23 +3,23 @@ -- becomes @m i j c@. module Sound.SC3.Lang.Collection where -import Data.List.Split {- split -}-import Data.List as L-import Data.Maybe+import qualified Data.List.Split as S {- split -}+import Data.List as L {- base -}+import Data.Maybe {- base -}  -- * Collection  -- | @Collection.*fill@ is 'map' over indices to /n/. -- -- > fill 4 (* 2) == [0,2,4,6]-fill :: Int -> (Int -> a) -> [a]+fill :: (Enum n,Num n) => n -> (n -> a) -> [a] fill n f = map f [0 .. n - 1]  -- | @Collection.size@ is 'length'. -- -- > size [1,2,3,4] == 4-size :: [a] -> Int-size = length+size :: Integral n => [a] -> n+size = genericLength  -- | @Collection.isEmpty@ is 'null'. --@@ -30,40 +30,40 @@ -- | Function equal to 'const' of /f/ of /e/. -- -- > select (ignoringIndex even) [1,2,3,4] == [2,4]-ignoringIndex :: (a -> b) -> a -> Int -> b+ignoringIndex :: (a -> b) -> a -> z -> b ignoringIndex f e = const (f e)  -- | @Collection.collect@ is 'map' with element indices. -- -- > collect (\i _ -> i + 10) [1,2,3,4] == [11,12,13,14] -- > collect (\_ j -> j + 11) [1,2,3,4] == [11,12,13,14]-collect :: (a -> Int -> b) -> [a] -> [b]+collect :: Integral i => (a -> i -> b) -> [a] -> [b] collect f l = zipWith f l [0..]  -- | @Collection.select@ is 'filter' with element indices. -- -- > select (\i _ -> even i) [1,2,3,4] == [2,4] -- > select (\_ j -> even j) [1,2,3,4] == [1,3]-select :: (a -> Int -> Bool) -> [a] -> [a]+select :: Integral i => (a -> i -> Bool) -> [a] -> [a] select f l = map fst (filter (uncurry f) (zip l [0..]))  -- | @Collection.reject@ is negated 'filter' with element indices. -- -- > reject (\i _ -> even i) [1,2,3,4] == [1,3] -- > reject (\_ j -> even j) [1,2,3,4] == [2,4]-reject :: (a -> Int -> Bool) -> [a] -> [a]+reject :: Integral i => (a -> i -> Bool) -> [a] -> [a] reject f l = map fst (filter (not . uncurry f) (zip l [0..]))  -- | @Collection.detect@ is 'first' '.' 'select'. -- -- > detect (\i _ -> even i) [1,2,3,4] == Just 2-detect :: (a -> Int -> Bool) -> [a] -> Maybe a+detect :: Integral i => (a -> i -> Bool) -> [a] -> Maybe a detect f l = fmap fst (find (uncurry f) (zip l [0..]))  -- | @Collection.detectIndex@ is the index locating variant of 'detect'. -- -- > detectIndex (\i _ -> even i) [1,2,3,4] == Just 1-detectIndex :: (a -> Int -> Bool) -> [a] -> Maybe Int+detectIndex :: Integral i => (a -> i -> Bool) -> [a] -> Maybe i detectIndex f l = fmap snd (find (uncurry f) (zip l [0..]))  -- | @Collection.inject@ is a variant on 'foldl'.@@ -76,13 +76,13 @@ -- | @Collection.any@ is 'True' if 'detect' is not 'Nothing'. -- -- > any' (\i _ -> even i) [1,2,3,4] == True-any' :: (a -> Int -> Bool) -> [a] -> Bool+any' :: Integral i => (a -> i -> Bool) -> [a] -> Bool any' f = isJust . detect f  -- | @Collection.every@ is 'True' if /f/ applies at all elements. -- -- > every (\i _ -> even i) [1,2,3,4] == False-every :: (a -> Int -> Bool) -> [a] -> Bool+every :: Integral i => (a -> i -> Bool) -> [a] -> Bool every f =     let g e = not . f e     in not . any' g@@ -90,32 +90,32 @@ -- | @Collection.count@ is 'length' '.' 'select'. -- -- > count (\i _ -> even i) [1,2,3,4] == 2-count :: (a -> Int -> Bool) -> [a] -> Int-count f = length . select f+count :: Integral i => (a -> i -> Bool) -> [a] -> i+count f = genericLength . select f  -- | @Collection.occurencesOf@ is an '==' variant of 'count'. -- -- > occurencesOf 2 [1,2,3,4] == 1 -- > occurencesOf 't' "test" == 2-occurencesOf :: (Eq a) => a -> [a] -> Int+occurencesOf :: (Integral i,Eq a) => a -> [a] -> i occurencesOf k = count (\e _ -> e == k)  -- | @Collection.sum@ is 'sum' '.' 'collect'. -- -- > sum' (ignoringIndex (* 2)) [1,2,3,4] == 20-sum' :: (Num a) => (b -> Int -> a) -> [b] -> a+sum' :: (Num a,Integral i) => (b -> i -> a) -> [b] -> a sum' f = sum . collect f  -- | @Collection.maxItem@ is 'maximum' '.' 'collect'. -- -- > maxItem (ignoringIndex (* 2)) [1,2,3,4] == 8-maxItem :: (Ord b) => (a -> Int -> b) -> [a] -> b+maxItem :: (Ord b,Integral i) => (a -> i -> b) -> [a] -> b maxItem f = maximum . collect f  -- | @Collection.minItem@ is 'maximum' '.' 'collect'. -- -- > minItem (ignoringIndex (* 2)) [1,2,3,4] == 2-minItem :: (Ord b) => (a -> Int -> b) -> [a] -> b+minItem :: (Integral i,Ord b) => (a -> i -> b) -> [a] -> b minItem f = minimum . collect f  -- | Variant of 'zipWith' that cycles the shorter input.@@ -129,7 +129,7 @@         g (a0 : aN) (b0 : bN) e = f a0 b0 : g aN bN e     in g a b (False,False) --- | 'zipWith_c' base variant of 'zip'.+-- | 'zipWith_c' variant of 'zip'. -- -- > zip_c [1,2] [3,4,5] == [(1,3),(2,4),(1,5)] zip_c :: [a] -> [b] -> [(a,b)]@@ -162,15 +162,15 @@ -- | @SequenceableCollection.*series@ is an arithmetic series with -- arguments /size/, /start/ and /step/. ----- > Array.series(5,10,2) == [10,12,14,16,18]+-- > > Array.series(5,10,2) == [10,12,14,16,18] -- > series 5 10 2 == [10,12 .. 18] -- -- Note that this is quite different from the SimpleNumber.series -- method, which is equal to 'enumFromThenTo'. ----- > 5.series(7,10) == [5,7,9]+-- > > 5.series(7,10) == [5,7,9] -- > enumFromThenTo 5 7 10 == [5,7,9]-series :: (Num a) => Int -> a -> a -> [a]+series :: (Num a,Integral i) => i -> a -> a -> [a] series n i j =     case n of       0 -> []@@ -179,9 +179,9 @@ -- | @SequenceableCollection.*geom@ is a geometric series with arguments -- /size/, /start/ and /grow/. ----- > Array.geom(5,3,6) == [3,18,108,648,3888]+-- > > Array.geom(5,3,6) == [3,18,108,648,3888] -- > geom 5 3 6 == [3,18,108,648,3888]-geom :: (Num a) => Int -> a -> a -> [a]+geom :: (Integral i,Num a) => i -> a -> a -> [a] geom n i j =     case n of       0 -> []@@ -191,9 +191,9 @@ -- is number of elements, /i/ is the initial step and /j/ the initial -- value. ----- > Array.fib(5,2,32) == [32,34,66,100,166]+-- > > Array.fib(5,2,32) == [32,34,66,100,166] -- > fib 5 2 32 == [32,34,66,100,166]-fib :: (Num a) => Int -> a -> a -> [a]+fib :: (Integral i,Num a) => i -> a -> a -> [a] fib n i j =     case n of       0 -> []@@ -201,11 +201,11 @@  -- | @SequenceableCollection.first@ is a total variant of 'L.head'. ----- > [3,4,5].first == 3+-- > > [3,4,5].first == 3 -- > first [3,4,5] == Just 3 -- > first' [3,4,5] == 3 ----- > [].first == nil+-- > > [].first == nil -- > first [] == Nothing first :: [t] -> Maybe t first xs =@@ -219,11 +219,11 @@  -- | Total variant of 'L.last'. ----- > (1..5).last == 5+-- > > (1..5).last == 5 -- > lastM [1..5] == Just 5 -- > L.last [1..5] == 5 ----- > [].last == nil+-- > > [].last == nil -- > lastM [] == Nothing lastM :: [t] -> Maybe t lastM xs =@@ -243,7 +243,7 @@ -- | @SequenceableCollection.indexOf@ is a variant of 'elemIndex' with -- reversed arguments. ----- > [3,4,100,5].indexOf(100) == 2+-- > > [3,4,100,5].indexOf(100) == 2 -- > indexOf [3,4,100,5] 100 == Just 2 indexOf :: Eq a => [a] -> a -> Maybe Int indexOf = flip elemIndex@@ -287,43 +287,43 @@                   b = l !! j                   d = b - a               in if d == 0 then i else ((e - a) / d) + i - 1-    in maybe (fromIntegral (size l) - 1) f (indexOfGreaterThan e l)+    in maybe (fromInteger (size l) - 1) f (indexOfGreaterThan e l)  -- | @SequenceableCollection.keep@ is, for positive /n/ a synonym for--- 'take', and for negative /n/ a variant on 'L.drop' based on the+-- 'L.take', and for negative /n/ a variant on 'L.drop' based on the -- 'length' of /l/. ----- > [1,2,3,4,5].keep(3) == [1,2,3]+-- > > [1,2,3,4,5].keep(3) == [1,2,3] -- > keep 3 [1,2,3,4,5] == [1,2,3] ----- > [1,2,3,4,5].keep(-3) == [3,4,5]+-- > > [1,2,3,4,5].keep(-3) == [3,4,5] -- > keep (-3) [1,2,3,4,5] == [3,4,5] ----- > [1,2].keep(-4) == [1,2]+-- > > [1,2].keep(-4) == [1,2] -- > keep (-4) [1,2] == [1,2]-keep :: Int -> [a] -> [a]+keep :: Integral i => i -> [a] -> [a] keep n l =     if n < 0-    then L.drop (length l + n) l-    else take n l+    then L.genericDrop (genericLength l + n) l+    else genericTake n l  -- | @SequenceableCollection.drop@ is, for positive /n/ a synonym for--- 'L.drop', for negative /n/ a variant on 'take' based on the--- 'length' of /l/.+-- 'L.drop', for negative /n/ a variant on 'L.take' based on the+-- 'L.length' of /l/. ----- > [1,2,3,4,5].drop(3) == [4,5]--- > drop 3 [1,2,3,4,5] == [4,5]+-- > > [1,2,3,4,5].drop(3) == [4,5]+-- > L.drop 3 [1,2,3,4,5] == [4,5] ----- > [1,2,3,4,5].drop(-3) == [1,2]--- > drop (-3) [1,2,3,4,5] == [1,2]+-- > > [1,2,3,4,5].drop(-3) == [1,2]+-- > Sound.SC3.Lang.Collection.drop (-3) [1,2,3,4,5] == [1,2] ----- > [1,2].drop(-4) == []--- > drop (-4) [1,2] == []-drop :: Int -> [a] -> [a]+-- > > [1,2].drop(-4) == []+-- > Sound.SC3.Lang.Collection.drop (-4) [1,2] == []+drop :: Integral i => i -> [a] -> [a] drop n l =     if n < 0-    then take (length l + n) l-    else L.drop n l+    then L.genericTake (L.genericLength l + n) l+    else L.genericDrop n l  -- | Function to calculate a list equal in length to the longest input -- list, therefore being productive over infinite lists.@@ -340,15 +340,15 @@ -- | @SequenceableCollection.flop@ is a variant of 'transpose' that -- cycles input sequences and extends rather than truncates. ----- > [(1..3),(4..5),(6..9)].flop == [[1,4,6],[2,5,7],[3,4,8],[1,5,9]]+-- > > [(1..3),(4..5),(6..9)].flop == [[1,4,6],[2,5,7],[3,4,8],[1,5,9]] -- > flop [[1..3],[4..5],[6..9]] == [[1,4,6],[2,5,7],[3,4,8],[1,5,9]] ----- > [[1,2,3],[4,5,6],[7,8]].flop == [[1,4,7],[2,5,8],[3,6,7]]+-- > > [[1,2,3],[4,5,6],[7,8]].flop == [[1,4,7],[2,5,8],[3,6,7]] -- > flop [[1,2,3],[4,5,6],[7,8]] == [[1,4,7],[2,5,8],[3,6,7]] -- -- The null case at 'flop' is not handled equivalently to SC3 ----- > [].flop == [[]]+-- > > [].flop == [[]] -- > flop [] /= [[]] -- > flop [] == [] --@@ -362,56 +362,24 @@     let l' = map cycle l     in zipWith (\_ x -> x) (extension l) (transpose l') --- * List and Array---- | @List.lace@ is a concatenated transposition of cycled--- subsequences.------ > [[1,2,3],[6],[8,9]].lace(12) == [1,6,8,2,6,9,3,6,8,1,6,9]--- > lace 12 [[1,2,3],[6],[8,9]] == [1,6,8,2,6,9,3,6,8,1,6,9]-lace :: Int -> [[a]] -> [a]-lace n = take n . concat . transpose . map cycle---- | @List.wrapExtend@ extends a sequence by--- /cycling/.  'wrapExtend' is in terms of 'take' and 'cycle'.+-- | @SequenceableCollection.integrate@ is the incremental sum of+-- elements. ----- > [1,2,3,4,5].wrapExtend(9) == [1,2,3,4,5,1,2,3,4]--- > wrapExtend 9 [1,2,3,4,5] == [1,2,3,4,5,1,2,3,4]-wrapExtend :: Int -> [a] -> [a]-wrapExtend n = take n . cycle---- | Infinite variant of 'foldExtend'.-cycleFold :: [a] -> [a]-cycleFold = cycle . mirror1+-- > > [3,4,1,1].integrate == [3,7,8,9]+-- > integrate [3,4,1,1] == [3,7,8,9]+integrate :: (Num a) => [a] -> [a]+integrate = scanl1 (+) --- | @List.foldExtend@ extends sequence by /folding/ backwards at end.--- 'foldExtend' is in terms of 'cycleFold', which is in terms of--- 'mirror1'.+-- | @SequenceableCollection.differentiate@ is the pairwise difference+-- between elements, with an implicit @0@ at the start. ----- > [1,2,3,4,5].foldExtend(10)--- > foldExtend 10 [1,2,3,4,5] == [1,2,3,4,5,4,3,2,1,2]-foldExtend :: Int -> [a] -> [a]-foldExtend n = take n . cycleFold---- | @Array.clipExtend@ extends sequence by repeating last element.+-- > > [3,4,1,1].differentiate == [3,1,-3,0]+-- > differentiate [3,4,1,1] == [3,1,-3,0] ----- > [1,2,3,4,5].clipExtend(9) == [1,2,3,4,5,5,5,5,5]--- > clipExtend 9 [1,2,3,4,5] == [1,2,3,4,5,5,5,5,5]-clipExtend :: Int -> [a] -> [a]-clipExtend n = take n . cycleClip---- | Infinite variant of 'clipExtend'.-cycleClip :: [a] -> [a]-cycleClip l =-    case lastM l of-      Nothing -> []-      Just e -> l ++ repeat e---- | Cycle input sequences to 'extension' of input.-extendSequences :: [[a]] -> [[a]]-extendSequences l =-    let f = zipWith (\_ x -> x) (extension l) . cycle-    in map f l+-- > > [0,3,1].differentiate == [0,3,-2]+-- > differentiate [0,3,1] == [0,3,-2]+differentiate :: (Num a) => [a] -> [a]+differentiate l = zipWith (-) l (0:l)  -- | Variant of 'separate' that performs initial separation. separateAt :: (a -> a -> Bool) -> [a] -> ([a],[a])@@ -428,10 +396,10 @@ -- each adjacent pair of elements at /l/. If the predicate is 'True', -- then a separation is made between the elements. ----- > [3,2,1,2,3,2].separate({|a,b| a<b}) == [[3,2,1],[2],[3,2]]+-- > > [3,2,1,2,3,2].separate({|a,b| a<b}) == [[3,2,1],[2],[3,2]] -- > separate (<) [3,2,1,2,3,2] == [[3,2,1],[2],[3,2]] ----- > [1,2,3,5,6,8].separate({|a,b| (b - a) > 1}) == [[1,2,3],[5,6],[8]]+-- > > [1,2,3,5,6,8].separate({|a,b| (b - a) > 1}) == [[1,2,3],[5,6],[8]] -- > separate (\a b -> (b - a) > 1) [1,2,3,5,6,8] == [[1,2,3],[5,6],[8]] separate :: (a -> a -> Bool) -> [a] -> [[a]] separate f l =@@ -439,17 +407,17 @@     in if null r then [e] else e : separate f r  -- | @SequenceableCollection.clump@ is a synonym for--- 'Data.List.Split.splitEvery'.+-- 'Data.List.Split.chunksOf'. ----- > [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(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 = chunksOf+clump = S.chunksOf  -- | @SequenceableCollection.clumps@ is a synonym for -- 'Data.List.Split.splitPlaces'. ----- > [1,2,3,4,5,6,7,8].clumps([1,2]) == [[1],[2,3],[4],[5,6],[7],[8]]+-- > > [1,2,3,4,5,6,7,8].clumps([1,2]) == [[1],[2,3],[4],[5,6],[7],[8]] -- > clumps [1,2] [1,2,3,4,5,6,7,8] == [[1],[2,3],[4],[5,6],[7],[8]] clumps :: [Int] -> [a] -> [[a]] clumps m s =@@ -460,39 +428,62 @@          [] -> []          _ -> f (cycle m) s --- | @SequenceableCollection.integrate@ is the incremental sum of--- elements.+-- * List and Array++-- | @List.lace@ is a concatenated transposition of cycled+-- subsequences. ----- > integrate [3,4,1,1] == [3,7,8,9]-integrate :: (Num a) => [a] -> [a]-integrate = scanl1 (+)+-- > > [[1,2,3],[6],[8,9]].lace(12) == [1,6,8,2,6,9,3,6,8,1,6,9]+-- > lace 12 [[1,2,3],[6],[8,9]] == [1,6,8,2,6,9,3,6,8,1,6,9]+lace :: Integral i => i -> [[a]] -> [a]+lace n = genericTake n . concat . transpose . map cycle --- | @SequenceableCollection.differentiate@ is the pairwise difference--- between elements.+-- | @List.wrapExtend@ extends a sequence by+-- /cycling/.  'wrapExtend' is in terms of 'take' and 'cycle'. ----- > differentiate [3,4,1,1] == [3,1,-3,0]-differentiate :: (Num a) => [a] -> [a]-differentiate l = zipWith (-) l (0:l)+-- > > [1,2,3,4,5].wrapExtend(9) == [1,2,3,4,5,1,2,3,4]+-- > wrapExtend 9 [1,2,3,4,5] == [1,2,3,4,5,1,2,3,4]+wrapExtend :: Integral i => i -> [a] -> [a]+wrapExtend n = genericTake n . cycle --- | Rotate /n/ places to the left.+-- | Infinite variant of 'foldExtend'.+cycleFold :: [a] -> [a]+cycleFold = cycle . mirror1++-- | @List.foldExtend@ extends sequence by /folding/ backwards at end.+-- 'foldExtend' is in terms of 'cycleFold', which is in terms of+-- 'mirror1'. ----- > rotateLeft 3 [1..7] == [4,5,6,7,1,2,3]-rotateLeft :: Int -> [a] -> [a]-rotateLeft n p =-    let (b,a) = splitAt n p-    in a ++ b+-- > > [1,2,3,4,5].foldExtend(10)+-- > foldExtend 10 [1,2,3,4,5] == [1,2,3,4,5,4,3,2,1,2]+foldExtend :: Integral i => i -> [a] -> [a]+foldExtend n = genericTake n . cycleFold --- | Rotate /n/ places to the right.+-- | @Array.clipExtend@ extends sequence by repeating last element. ----- > rotateRight 3 [1..7] == [5,6,7,1,2,3,4]-rotateRight :: Int -> [a] -> [a]-rotateRight n p =-    let k = length p-        (b,a) = splitAt (k - n) p-    in a ++ b+-- > > [1,2,3,4,5].clipExtend(9) == [1,2,3,4,5,5,5,5,5]+-- > clipExtend 9 [1,2,3,4,5] == [1,2,3,4,5,5,5,5,5]+clipExtend :: Integral i => i -> [a] -> [a]+clipExtend n = genericTake n . cycleClip +-- | Infinite variant of 'clipExtend'.+cycleClip :: [a] -> [a]+cycleClip l =+    case lastM l of+      Nothing -> []+      Just e -> l ++ repeat e++-- | Cycle input sequences to 'extension' of input.+--+-- > extendSequences [[1],[2,3],[4,5,6]] == [[1,1,1],[2,3,2],[4,5,6]]+extendSequences :: [[a]] -> [[a]]+extendSequences l =+    let f = zipWith (\_ x -> x) (extension l) . cycle+    in map f l+ -- | @ArrayedCollection.normalizeSum@ ensures sum of elements is one. --+-- > > [1,2,3].normalizeSum == [1/6,1/3,0.5] -- > normalizeSum [1,2,3] == [1/6,2/6,3/6] normalizeSum :: (Fractional a) => [a] -> [a] normalizeSum l =@@ -502,30 +493,30 @@ -- | @List.slide@ is an identity window function with subsequences of -- length /w/ and stride of /n/. ----- > [1,2,3,4,5,6].slide(3,1)+-- > > [1,2,3,4,5,6].slide(3,1) -- > slide 3 1 [1,2,3,4,5,6] == [1,2,3,2,3,4,3,4,5,4,5,6] ----- > [1,2,3,4,5,6].slide(3,2)+-- > > [1,2,3,4,5,6].slide(3,2) -- > slide 3 2 [1,2,3,4,5,6] == [1,2,3,3,4,5] ----- > [1,2,3,4,5,6].slide(4,2)+-- > > [1,2,3,4,5,6].slide(4,2) -- > slide 4 2 [1,2,3,4,5,6] == [1,2,3,4,3,4,5,6]-slide :: Int -> Int -> [a] -> [a]+slide :: Integral i => i -> i -> [a] -> [a] slide w n l =-    let k = length l-    in concatMap (\i -> take w (L.drop i l)) [0,n .. k-w]+    let k = genericLength l+    in concatMap (\i -> genericTake w (L.genericDrop i l)) [0,n .. k-w]  -- | @List.mirror@ concatentates with 'tail' of 'reverse' to make a -- palindrome. ----- > [1,2,3,4].mirror == [1,2,3,4,3,2,1]+-- > > [1,2,3,4].mirror == [1,2,3,4,3,2,1] -- > mirror [1,2,3,4] == [1,2,3,4,3,2,1] mirror :: [a] -> [a] mirror l = l ++ tail (reverse l)  -- | @List.mirror1@ is as 'mirror' but with last element removed. ----- > [1,2,3,4].mirror1 == [1,2,3,4,3,2]+-- > > [1,2,3,4].mirror1 == [1,2,3,4,3,2] -- > mirror1 [1,2,3,4] == [1,2,3,4,3,2] mirror1 :: [a] -> [a] mirror1 l =@@ -537,31 +528,50 @@ -- | @List.mirror2@ concatenate with 'reverse' to make a palindrome, -- as 'mirror' does, but with the center element duplicated. ----- > [1,2,3,4].mirror2 == [1,2,3,4,4,3,2,1]+-- > > [1,2,3,4].mirror2 == [1,2,3,4,4,3,2,1] -- > mirror2 [1,2,3,4] == [1,2,3,4,4,3,2,1] mirror2 :: [a] -> [a] mirror2 l = l ++ reverse l  -- | @List.stutter@ repeats each element /n/ times. ----- > [1,2,3].stutter(2) == [1,1,2,2,3,3]+-- > > [1,2,3].stutter(2) == [1,1,2,2,3,3] -- > stutter 2 [1,2,3] == [1,1,2,2,3,3]-stutter :: Int -> [a] -> [a]-stutter n = concatMap (replicate n)+stutter :: Integral i => i -> [a] -> [a]+stutter n = concatMap (genericReplicate n) +-- | Rotate /n/ places to the left.+--+-- > rotateLeft 1 [1..5] == [2,3,4,5,1]+-- > rotateLeft 3 [1..7] == [4,5,6,7,1,2,3]+rotateLeft :: Integral i => i -> [a] -> [a]+rotateLeft n p =+    let (b,a) = genericSplitAt n p+    in a ++ b++-- | Rotate /n/ places to the right.+--+-- > rotateRight 1 [1..5] == [5,1,2,3,4]+-- > rotateRight 3 [1..7] == [5,6,7,1,2,3,4]+rotateRight :: Integral i => i -> [a] -> [a]+rotateRight n p =+    let k = genericLength p+        (b,a) = genericSplitAt (k - n) p+    in a ++ b+ -- | @Array.rotate@ is in terms of 'rotateLeft' and 'rotateRight', -- where negative /n/ rotates left and positive /n/ rotates right. ----- > (1..5).rotate(1) == [5,1,2,3,4]+-- > > (1..5).rotate(1) == [5,1,2,3,4] -- > rotate 1 [1..5] == [5,1,2,3,4] ----- > (1..5).rotate(-1) == [2,3,4,5,1]+-- > > (1..5).rotate(-1) == [2,3,4,5,1] -- > rotate (-1) [1..5] == [2,3,4,5,1] ----- > (1..5).rotate(3) == [3,4,5,1,2]+-- > > (1..5).rotate(3) == [3,4,5,1,2] -- > rotate 3 [1..5] == [3,4,5,1,2]-rotate :: Int -> [a] -> [a]-rotate n = if n < 0 then rotateLeft n else rotateRight n+rotate :: Integral i => i -> [a] -> [a]+rotate n = if n < 0 then rotateLeft (- n) else rotateRight n  -- | @ArrayedCollection.windex@ takes a list of probabilities, which -- should sum to /n/, and returns the an index value given a (0,/n/)@@ -576,19 +586,18 @@ -- | List of 2-tuples of elements at distance (stride) /n/. -- -- > t2_window 3 [1..9] == [(1,2),(4,5),(7,8)]-t2_window :: Int -> [t] -> [(t,t)]+t2_window :: Integral i => i -> [t] -> [(t,t)] t2_window n x =     case x of-      i:j:_ -> (i,j) : t2_window n (L.drop n x)+      i:j:_ -> (i,j) : t2_window n (L.genericDrop n x)       _ -> [] - -- | List of 2-tuples of adjacent elements. -- -- > t2_adjacent [1..6] == [(1,2),(3,4),(5,6)] -- > t2_adjacent [1..5] == [(1,2),(3,4)] t2_adjacent :: [t] -> [(t,t)]-t2_adjacent = t2_window 2+t2_adjacent = t2_window (2::Int)  -- | List of 2-tuples of overlapping elements. --@@ -620,7 +629,7 @@ -- element, or zero at the final element.  Properly wavetables are -- only of power of two element signals. ----- > Signal[0,0.5,1,0.5].asWavetable == Wavetable[-0.5,0.5,0,0.5,1.5,-0.5,1,-0.5]+-- > > Signal[0,0.5,1,0.5].asWavetable == Wavetable[-0.5,0.5,0,0.5,1.5,-0.5,1,-0.5] -- -- > to_wavetable [0,0.5,1,0.5] == [-0.5,0.5,0,0.5,1.5,-0.5,1,-0.5] to_wavetable :: Num a => [a] -> [a]

@@ -1,196 +1,325 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Functions to allow using the "Sound.OpenSoundControl" 'Datum' as -- a /universal/ data type.  In addition to the functions defined--- below it provides instances for 'IsString', 'Num', 'Fractional',--- 'Floating', 'Real', 'RealFrac', 'Ord', 'Enum' and 'Random'.+-- below it provides instances for:+--+-- 'Datum' are 'IsString'+--+-- > :set -XOverloadedStrings+-- > "string" :: Datum+--+-- 'Datum' are 'EqE'+--+-- > Int32 5 /=* Int32 6 == Int32 1+-- > Double 5 ==* Double 5 == Double 1+--+-- 'Datum' are 'Num'+--+-- > 5 :: Datum+-- > 5 + 4 :: Datum+-- > negate 5 :: Datum+--+-- 'Datum' are 'Fractional'+--+-- > 5.0 :: Datum+-- > (5 / 4) :: Datum+--+-- 'Datum' are 'Floating'+--+-- > pi :: Datum+-- > sqrt (Int32 4) == Double 2+-- > (2.0 ** 3.0) :: Datum+--+-- 'Datum' are 'Real'+--+-- > toRational (Double 1.5) == (3/2 :: Rational)+-- > (realToFrac (1.5 :: Double) :: Datum) == Double 1.5+-- > (realToFrac (Double 1.5) :: Datum) == Double 1.5+-- > (realToFrac (Double 1.5) :: Double) == 1.5+--+-- 'Datum' are 'RealFrac'+--+-- > round (Double 1.4) == 1+--+-- 'Datum' are 'RealFracE'+--+-- > roundE (Double 1.4) == Double 1+-- > ceilingE (Double 1.4) == Double 2+--+-- 'Datum' are 'RealFloat'+--+-- > isNaN (sqrt (negate (Int32 1))) == True+--+-- 'Datum' are 'Ord'+--+-- > Double 7.5 > Int32 7+-- > string "because" > string "again"+--+-- 'Datum' are 'OrdE'+--+-- > Int32 7 >* Int32 7 == Int32 0+-- > Double 7.5 >* Int32 7 == Double 1+--+-- 'Datum' are 'Enum'+--+-- > [Int32 0 .. Int32 4] == [Int32 0,Int32 1,Int32 2,Int32 3,Int32 4]+-- > [Double 1 .. Double 3] == [Double 1,Double 2,Double 3]+--+-- 'Datum' are 'Random'+--+-- > System.Random.randomRIO (Int32 0,Int32 9):: IO Datum+-- > System.Random.randomRIO (Float 0,Float 1):: IO Datum module Sound.SC3.Lang.Collection.Universal.Datum where -import Data.Ratio-import GHC.Exts (IsString(..))-import Sound.OpenSoundControl.Type-import System.Random+import qualified Data.ByteString.Char8 as C {- bytestring -}+import Data.Int {- base -}+import Data.Ratio {- base -}+import Data.String {- base -}+import Sound.OSC {- hosc -}+import Sound.SC3 {- hsc3 -}+import System.Random {- random -} -instance IsString Datum where-    fromString = String+-- * Lifting --- | Lift an equivalent set of 'Int' and 'Double' unary functions to--- 'Datum'.------ > map (datum_lift negate negate) [Int 5,Float 5] == [Int (-5),Float (-5)]-datum_lift :: (Int -> Int) -> (Double -> Double) -> Datum -> Datum-datum_lift fi fd d =-    case d of-      Int n -> Int (fi n)-      Float n -> Float (fd n)-      Double n -> Double (fd n)-      _ -> error "datum_lift"+-- | Unary operator.+type UOp n = (n -> n) --- | Promote 'Int' and 'Float' 'Datum' to 'Double' 'Datum'.+-- | Lift an equivalent set of 'Int32', 'Int64', 'Float' and 'Double' unary+-- functions to 'Datum'. ----- > map datum_promote [Int 5,Float 5] == [Double 5,Double 5]-datum_promote :: Datum -> Datum-datum_promote d =+-- > map (liftD abs abs abs abs) [Int32 5,Float (-5)] == [Int32 5,Float 5]+liftD :: UOp Int32 -> UOp Int64 -> UOp Float -> UOp Double -> UOp Datum+liftD fi fh ff fd d =     case d of-      Int n -> Double (fromIntegral n)-      Float n -> Double n-      _ -> d+      Int32 n -> Int32 (fi n)+      Int64 n -> Int64 (fh n)+      Float n -> Float (ff n)+      Double n -> Double (fd n)+      _ -> error "liftD: NaN"  -- | Lift a 'Double' unary operator to 'Datum' via 'datum_promote'. ----- > datum_lift' negate (Int 5) == Double (-5)-datum_lift' :: (Double -> Double) -> Datum -> Datum-datum_lift' f = datum_lift (error "datum_lift:non integral") f .-                datum_promote---- | An 'Int' binary operator.-type I_Binop = Int -> Int -> Int+-- > liftD' negate (Int 5) == Double (-5)+liftD' :: UOp Double -> UOp Datum+liftD' fd =+    liftD (error "liftD'") (error "liftD'") (error "liftD'") fd .+    datum_promote --- | A 'Double' binary operator.-type F_Binop = Double -> Double -> Double+-- | A binary operator.+type BinOp n = (n -> n -> n) --- | Given 'Int' and 'Double' binary operators generate 'Datum'--- operator.  If 'Datum' are of equal type result type is equal, else--- result type is 'Double'.+-- | Given 'Int32', 'Int64', 'Float' and 'Double' binary operators+-- generate 'Datum' operator.  If 'Datum' are of equal type result+-- type is equal, else result type is 'Double'. ----- > datum_lift2 (+) (+) (Float 1) (Float 2) == Float 3--- > datum_lift2 (*) (*) (Int 3) (Float 4) == Double 12-datum_lift2 :: I_Binop -> F_Binop -> Datum -> Datum -> Datum-datum_lift2 fi fd d1 d2 =+-- > liftD2 (+) (+) (+) (+) (Float 1) (Float 2) == Float 3+-- > liftD2 (*) (*) (*) (*) (Int32 3) (Float 4) == Double 12+liftD2 :: BinOp Int32 -> BinOp Int64 ->+          BinOp Float -> BinOp Double ->+          BinOp Datum+liftD2 fi fh ff fd d1 d2 =     case (d1,d2) of-      (Int n1,Int n2) -> Int (fi n1 n2)-      (Float n1,Float n2) -> Float (fd n1 n2)+      (Int32 n1,Int32 n2) -> Int32 (fi n1 n2)+      (Int64 n1,Int64 n2) -> Int64 (fh n1 n2)+      (Float n1,Float n2) -> Float (ff n1 n2)       (Double n1,Double n2) -> Double (fd n1 n2)-      _ -> case (datum_real d1,datum_real d2) of+      _ -> case (datum_floating d1,datum_floating d2) of              (Just n1,Just n2) -> Double (fd n1 n2)-             _ -> error "datum_lift2"+             _ -> error "liftD2: NaN" --- | A 'datum_promote' variant of 'datum_lift2'.+-- | A 'datum_promote' variant of 'liftD2'. ----- > datum_lift2' (+) (Float 1) (Float 2) == Double 3-datum_lift2' :: F_Binop -> Datum -> Datum -> Datum-datum_lift2' f d1 =+-- > liftD2' (+) (Float 1) (Float 2) == Double 3+liftD2' :: BinOp Double -> BinOp Datum+liftD2' f d1 =     let d1' = datum_promote d1-    in datum_lift2 (error "datum_lift2:non integral") f d1' .+    in liftD2 (error "liftD2'") (error "liftD2'") (error "liftD2'") f d1' .        datum_promote +-- * At++-- | Direct unary 'Int32', 'Int64', 'Float' and 'Double' functions at+-- 'Datum' fields, or 'error'.+--+-- > atD show show show show (Int 5) == "5"+atD :: (Int32 -> a) -> (Int64 -> a) ->+       (Float -> a) -> (Double -> a) ->+       Datum -> a+atD fi fh ff fd d =+    case d of+      Int32 n -> fi n+      Int64 n -> fh n+      Float n -> ff n+      Double n -> fd n+      _ -> error "atD: NaN"++-- | Lift a 'Double' /at/ operator to 'Datum' via 'datum_promote'.+--+-- > atD' floatRadix (Int 5) == 2+atD' :: (Double -> a) -> Datum -> a+atD' f = f . d_double . datum_promote++-- | Binary /at/ function.+type BinAt n a = (n -> n -> a)++-- | Direct binary 'Int', 'Float' and 'Double' functions at 'Datum'+-- fields, or 'error'.+atD2 :: BinAt Int32 a -> BinAt Int64 a ->+        BinAt Float a -> BinAt Double a ->+        BinAt Datum a+atD2 fi fh ff fd d1 d2 =+    case (d1,d2) of+      (Int32 n1,Int32 n2) -> fi n1 n2+      (Int64 n1,Int64 n2) -> fh n1 n2+      (Float n1,Float n2) -> ff n1 n2+      (Double n1,Double n2) -> fd n1 n2+      _ -> error "atD2: NaN"++-- | Ternary /at/ function.+type TriAt n a = (n -> n -> n -> a)++-- | Direct ternary 'Int', 'Float' and 'Double' functions at 'Datum'+-- fields, or 'error'.+atD3 :: TriAt Int32 a -> TriAt Int64 a ->+        TriAt Float a -> TriAt Double a ->+        TriAt Datum a+atD3 fi fh ff fd d1 d2 d3 =+    case (d1,d2,d3) of+      (Int32 n1,Int32 n2,Int32 n3) -> fi n1 n2 n3+      (Int64 n1,Int64 n2,Int64 n3) -> fh n1 n2 n3+      (Float n1,Float n2,Float n3) -> ff n1 n2 n3+      (Double n1,Double n2,Double n3) -> fd n1 n2 n3+      _ -> error "atD3: NaN"++instance IsString Datum where+    fromString = ASCII_String . C.pack++instance EqE Datum where+    (==*) = liftD2 (==*) (==*) (==*) (==*)+    (/=*) = liftD2 (/=*) (/=*) (/=*) (/=*)+ instance Num Datum where-    negate = datum_lift negate negate-    (+) = datum_lift2 (+) (+)-    (-) = datum_lift2 (-) (-)-    (*) = datum_lift2 (*) (*)-    abs = datum_lift abs abs-    signum = datum_lift signum signum-    fromInteger n = Int (fromInteger n)+    negate = liftD negate negate negate negate+    (+) = liftD2 (+) (+) (+) (+)+    (-) = liftD2 (-) (-) (-) (-)+    (*) = liftD2 (*) (*) (*) (*)+    abs = liftD abs abs abs abs+    signum = liftD signum signum signum signum+    fromInteger n = Int64 (fromInteger n)  instance Fractional Datum where-    recip = datum_lift' recip-    (/) = datum_lift2' (/)+    recip = liftD' recip+    (/) = liftD2' (/)     fromRational n = Double (fromRational n)  instance Floating Datum where     pi = Double pi-    exp = datum_lift' exp-    log = datum_lift' log-    sqrt = datum_lift' sqrt-    (**) = datum_lift2' (**)-    logBase = datum_lift2' logBase-    sin = datum_lift' sin-    cos = datum_lift' cos-    tan = datum_lift' tan-    asin = datum_lift' asin-    acos = datum_lift' acos-    atan = datum_lift' atan-    sinh = datum_lift' sinh-    cosh = datum_lift' cosh-    tanh = datum_lift' tanh-    asinh = datum_lift' asinh-    acosh = datum_lift' acosh-    atanh = datum_lift' atanh+    exp = liftD' exp+    log = liftD' log+    sqrt = liftD' sqrt+    (**) = liftD2' (**)+    logBase = liftD2' logBase+    sin = liftD' sin+    cos = liftD' cos+    tan = liftD' tan+    asin = liftD' asin+    acos = liftD' acos+    atan = liftD' atan+    sinh = liftD' sinh+    cosh = liftD' cosh+    tanh = liftD' tanh+    asinh = liftD' asinh+    acosh = liftD' acosh+    atanh = liftD' atanh  instance Real Datum where     toRational d =         case d of-          Int n -> fromIntegral n % 1+          Int32 n -> fromIntegral n % 1+          Int64 n -> fromIntegral n % 1           Float n -> toRational n           Double n -> toRational n-          _ -> error "datum,real,partial"+          _ -> error "Datum.toRational: NaN"  instance RealFrac Datum where   properFraction d =-      let (i,j) = properFraction (datum_real_err d)+      let (i,j) = properFraction (d_double d)       in (i,Double j)-  truncate = truncate . datum_real_err-  round = round . datum_real_err-  ceiling = ceiling . datum_real_err-  floor = floor . datum_real_err+  truncate = atD' truncate+  round = atD' round+  ceiling = atD' ceiling+  floor = atD' floor -instance Ord Datum where-    p < q = case (datum_real p,datum_real q) of-              (Just i,Just j) -> i < j-              _ -> error "datum,ord,partial"+instance RealFracE Datum where+  truncateE = liftD undefined undefined truncateE truncateE+  roundE = liftD undefined undefined roundE roundE+  ceilingE = liftD undefined undefined ceilingE ceilingE+  floorE = liftD undefined undefined floorE floorE --- | Direct unary 'Int' and 'Double' functions at 'Datum' fields, or--- 'error'.------ > at_d1 show show (Int 5) == "5"-at_d1 :: (Int -> a) -> (Double -> a) -> Datum -> a-at_d1 fi fr d =-    case d of-      Int n -> fi n-      Float n -> fr n-      Double n -> fr n-      _ -> error "at_d1,partial"+instance RealFloat Datum where+    floatRadix = atD' floatRadix+    floatDigits = atD' floatDigits+    floatRange = atD' floatRange+    decodeFloat = atD' decodeFloat+    encodeFloat i = Double . encodeFloat i+    exponent = atD' exponent+    significand = liftD' significand+    scaleFloat i = liftD' (scaleFloat i)+    isNaN = atD' isNaN+    isInfinite = atD' isInfinite+    isDenormalized = atD' isDenormalized+    isNegativeZero = atD' isNegativeZero+    isIEEE = atD' isIEEE+    atan2 = liftD2' atan2 --- | Direct binary 'Int' and 'Double' functions at 'Datum' fields, or--- 'error'.-at_d2 :: (Int -> Int -> a) ->-         (Double -> Double -> a) ->-         Datum -> Datum -> a-at_d2 fi fr d1 d2 =-    case (d1,d2) of-      (Int n1,Int n2) -> fi n1 n2-      (Float n1,Float n2) -> fr n1 n2-      (Double n1,Double n2) -> fr n1 n2-      _ -> error "at_d2,partial"+instance Ord Datum where+    compare p q =+        case (datum_promote p,datum_promote q) of+          (Double i, Double j) -> compare i j+          (ASCII_String i,ASCII_String j) -> compare i j+          (TimeStamp i,TimeStamp j) -> compare i j+          _ -> error "Datum.compare" --- | Direct ternary 'Int' and 'Double' functions at 'Datum' fields, or--- 'error'.-at_d3 :: (Int -> Int -> Int -> a) ->-         (Double -> Double -> Double -> a) ->-         Datum -> Datum -> Datum -> a-at_d3 fi fr d1 d2 d3 =-    case (d1,d2,d3) of-      (Int n1,Int n2,Int n3) -> fi n1 n2 n3-      (Float n1,Float n2,Float n3) -> fr n1 n2 n3-      (Double n1,Double n2,Double n3) -> fr n1 n2 n3-      _ -> error "at_d3,partial"+instance OrdE Datum where+    (>*) = liftD2 (>*) (>*) (>*) (>*)+    (>=*) = liftD2 (>=*) (>=*) (>=*) (>=*)+    (<*) = liftD2 (<*) (<*) (<*) (<*)+    (<=*) = liftD2 (<=*) (<=*) (<=*) (<=*)  instance Enum Datum where-    fromEnum = at_d1 fromEnum fromEnum-    enumFrom = at_d1 (map Int . enumFrom) (map Double . enumFrom)-    enumFromThen = at_d2 (\a -> map Int . enumFromThen a)-                         (\a -> map Double . enumFromThen a)-    enumFromTo = at_d2 (\a -> map Int . enumFromTo a)-                       (\a -> map Double . enumFromTo a)-    enumFromThenTo = at_d3 (\a b ->  map Int . enumFromThenTo a b)-                           (\a b ->  map Double . enumFromThenTo a b)-    toEnum = Int+    fromEnum = atD fromEnum fromEnum fromEnum fromEnum+    enumFrom =+        atD+        (map Int32 . enumFrom)+        (map Int64 . enumFrom)+        (map Float . enumFrom)+        (map Double . enumFrom)+    enumFromThen =+        atD2+        (\a -> map Int32 . enumFromThen a)+        (\a -> map Int64 . enumFromThen a)+        (\a -> map Float . enumFromThen a)+        (\a -> map Double . enumFromThen a)+    enumFromTo =+        atD2+        (\a -> map Int32 . enumFromTo a)+        (\a -> map Int64 . enumFromTo a)+        (\a -> map Float . enumFromTo a)+        (\a -> map Double . enumFromTo a)+    enumFromThenTo =+        atD3+        (\a b ->  map Int32 . enumFromThenTo a b)+        (\a b ->  map Int64 . enumFromThenTo a b)+        (\a b ->  map Float . enumFromThenTo a b)+        (\a b ->  map Double . enumFromThenTo a b)+    toEnum = Int64 . fromIntegral  instance Random Datum where   randomR i g =       case i of-        (Int l,Int r) -> let (n,g') = randomR (l,r) g in (Int n,g')+        (Int32 l,Int32 r) -> let (n,g') = randomR (l,r) g in (Int32 n,g')+        (Int64 l,Int64 r) -> let (n,g') = randomR (l,r) g in (Int64 n,g')         (Float l,Float r) -> let (n,g') = randomR (l,r) g in (Float n,g')         (Double l,Double r) -> let (n,g') = randomR (l,r) g in (Double n,g')-        _ -> error "randomR,datum,partial"+        _ -> error "Datum.randomR: NaN"   random g = let (n,g') = randomR (0::Double,1::Double) g in (Double n,g')--{--5 :: Datum-(5 + 4) :: Datum-(2.0 ** 3.0) :: Datum-(negate 5) :: Datum-(negate 5.0) :: Datum-:set -XOverloadedStrings-"string" :: Datum--}

@@ -1,66 +1,81 @@ -- | The @SC3@ duration model. module Sound.SC3.Lang.Control.Duration where --- | The @SC3@ 'Duration' model.-data Duration a =-    Duration {tempo :: a -- ^ Tempo (in pulses per minute)-             ,dur :: a -- ^ Duration (in pulses)-             ,stretch :: a -- ^ Stretch multiplier-             ,legato :: a -- ^ Legato multipler-             ,sustain_f :: Duration a -> a -- ^ Sustain time calculation-             ,delta_f :: Duration a -> a -- ^ Delta time calculation-             ,lag :: a -- ^ Lag value-             ,fwd' :: Maybe a -- ^ Possible non-sequential delta time field-             }+import Data.Maybe {- base -} --- | Run 'delta_f' for 'Duration'.  This is the interval from the--- start of the current event to the start of the next event.------ > delta (defaultDuration {dur = 2,stretch = 2}) == 4-delta :: Duration a -> a-delta d = delta_f d d+-- * Durational --- | Run 'sustain_f' for 'Duration'.  This is the /sounding/ duration--- of the event.+-- | Values that have duration. ----- > sustain defaultDuration == 0.8-sustain :: Duration a -> a-sustain d = sustain_f d d---- | If 'fwd'' field is set at 'Duration' extract value and multiply--- by 'stretch', else calculate 'delta'.+-- @occ@ is the interval from the start through to the end of the+-- current event, ie. the time span the event /occupies/. ----- > fwd (defaultDuration {fwd' = Just 0}) == 0-fwd :: Num a => Duration a -> a-fwd d =-    case fwd' d of-      Nothing -> delta d-      Just n -> n * stretch d---- | The default 'delta_f' field for 'Duration'.  Equal to 'dur' '*'--- 'stretch' '*' (@60@ '/' 'tempo').+-- @delta@ is the interval from the start of the current event to the+-- start of the next /sequential/ event. ----- > default_delta_f (defaultDuration {legato = 1.2}) == 1.0-default_delta_f :: (Num a,Fractional a) => Duration a -> a-default_delta_f d = dur d * stretch d * (60 / tempo d)+-- @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+    delta :: d -> Double+    delta = occ+    fwd :: d -> Double+    fwd = occ --- | The default 'sustain_f' field for 'Duration'.  This is equal to--- 'delta' '*' 'legato'.+-- * Dur++-- | Variant of the @SC3@ 'Duration' model. ----- > default_sustain_f (defaultDuration {legato = 1.2}) == 1.2-default_sustain_f :: (Num a,Fractional a) => Duration a -> a-default_sustain_f d = delta d * legato d+-- > delta (defaultDur {dur = 2,stretch = 2}) == 4+-- > occ defaultDur == 0.8+-- > let d = defaultDur {fwd' = Just 0} in (delta d,fwd d) == (1,0)+data Dur =+    Dur {tempo :: Double -- ^ Tempo (in pulses per minute)+        ,dur :: Double -- ^ Duration (in pulses)+        ,stretch :: Double -- ^ Stretch multiplier+        ,legato :: Double -- ^ Legato multipler+        ,sustain' :: Maybe Double -- ^ Sustain time+        ,delta' :: Maybe Double -- ^ Delta time+        ,lag :: Double -- ^ Lag value+        ,fwd' :: Maybe Double -- ^ Possible non-sequential delta time field+        }+    deriving (Eq,Show) --- | Default 'Duration' value, equal to one second.+instance Durational Dur where+    occ d = fromMaybe (delta d * legato d) (sustain' d)+    delta d = fromMaybe (dur d * stretch d * (60 / tempo d)) (delta' d)+    fwd d = maybe (delta d) (* stretch d) (fwd' d)++-- | Default 'Dur' value, equal to one second. ----- > delta defaultDuration == 1-defaultDuration :: (Num a,Fractional a) => Duration a-defaultDuration =-    Duration {tempo = 60-             ,dur = 1-             ,stretch = 1-             ,legato = 0.8-             ,sustain_f = default_sustain_f-             ,delta_f = default_delta_f-             ,lag = 0.1-             ,fwd' = Nothing}+-- > delta defaultDur == 1+defaultDur :: Dur+defaultDur =+    Dur {tempo = 60+        ,dur = 1+        ,stretch = 1+        ,legato = 0.8+        ,sustain' = Nothing+        ,delta' = Nothing+        ,lag = 0.1+        ,fwd' = Nothing}++-- * OptDur++-- | Eight tuple.+type T8 n = (n,n,n,n,n,n,n,n)++-- | 'Dur' represented as an eight-tuple of optional values.+type OptDur = T8 (Maybe Double)++-- | Translate 'OptDur' to 'Dur'.+optDur :: OptDur -> Dur+optDur (t,d,s,l,s',d',l',f) =+    Dur {tempo = fromMaybe 60 t+        ,dur = fromMaybe 1 d+        ,stretch = fromMaybe 1 s+        ,legato = fromMaybe 0.8 l+        ,sustain' = s'+        ,delta' = d'+        ,lag = fromMaybe 0.1 l'+        ,fwd' = f}

@@ -1,301 +1,763 @@--- | An 'Event' is a ('Key','Value') map.+-- | An 'Event' is a ('Key','Field') map. module Sound.SC3.Lang.Control.Event where -import qualified Data.Map as M-import Data.Maybe-import qualified Sound.OpenSoundControl as O-import qualified Sound.SC3.Server as S+import Data.List {- base -}+import qualified Data.Map as Map {- containers -}+import Data.Maybe {- base -}+import Data.Monoid {- base -}+import Data.String {- base -}+import Sound.OSC {- hosc -}+import Sound.SC3 {- hsc3 -}+import System.Random {- base -}++import qualified Sound.SC3.Lang.Collection as C 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+import qualified Sound.SC3.Lang.Math as M --- | The type of the /key/ at an 'Event'.-type Key = String+-- * Field --- | The type of the /value/ at an 'Event'.-type Value = Double+-- | Event field.+--+-- 'Field's are 'Num'.+--+-- > 5 :: Field+-- > 4 + 5 :: Field+-- > negate 5 :: Field+-- > f_array [2,3] + f_array [4,5] == f_array [6,8]+-- > f_array [1,2,3] + f_array [4,5] == f_array [5,7,7]+-- > 4 + f_array [5,6] == f_array [9,10]+data Field = F_Double {f_double :: Double}+           | F_Vector {f_vector :: [Field]}+           | F_String {f_string :: String}+           | F_Instr {f_instr :: I.Instr}+             deriving (Eq,Show) --- | The /type/ of an 'Event'.-data Type = E_s_new | E_n_set | E_rest deriving (Eq,Show)+-- | Set of types that can be lifted to 'Field'.+class F_Value a where toF :: a -> Field+instance F_Value Bool where toF = F_Double . fromIntegral . fromEnum+instance F_Value Int where toF = F_Double . fromIntegral+instance F_Value Double where toF = F_Double+instance F_Value I.Instr where toF = F_Instr+instance F_Value Field where toF = id --- | An 'Event' has a 'Type', possibly an integer identifier, possibly--- an 'I.Instrument' and a map of ('Key','Value') pairs.-data Event = Event {e_type :: Type-                   ,e_id :: Maybe Int-                   ,e_instrument :: Maybe I.Instrument-                   ,e_map :: M.Map Key Value}-                  deriving (Eq,Show)+-- | Numeric 'F_Value' types.+class F_Value a => F_Num a where+instance F_Num Int+instance F_Num Double+instance F_Num Field --- | The /default/ empty event.-defaultEvent :: Event-defaultEvent =-    Event {e_type = E_s_new-          ,e_id = Nothing-          ,e_instrument = Nothing-          ,e_map = M.empty}+-- | Maybe variant of 'f_double'.+f_double_m :: Field -> Maybe Double+f_double_m f = case f of {F_Double n -> Just n;_ -> Nothing;} --- | Lookup /k/ in /e/.+-- | Variant of /reader/ with specified error message.+f_reader_err :: String -> String -> (Field -> Maybe a) -> Field -> a+f_reader_err nm err f x =+    let s = nm ++ ": " ++ err ++ " (" ++ show x ++ ")"+    in fromMaybe (error s) (f x)++-- | Variant of 'f_double' with specified error message.+f_double_err :: String -> Field -> Double+f_double_err err = f_reader_err "f_double" err f_double_m++-- | Run '>' @0@ at 'f_double'.+f_bool_err :: String -> Field -> Bool+f_bool_err err = (> 0) . f_reader_err "f_bool" err f_double_m++-- | Run 'round' at 'f_double'.+f_int_err :: String -> Field -> Int+f_int_err err = round . f_reader_err "f_int" err f_double_m++-- | Single element 'F_Vector' constructor. ----- > lookup_m "k" defaultEvent == Nothing-lookup_m :: Key -> Event -> Maybe Value-lookup_m k e = M.lookup k (e_map e)+-- > f_ref 1 == f_array [1]+f_ref :: Field -> Field+f_ref = F_Vector . return --- | Variant of 'lookup_m' with a default value /v/.+-- | Uniform vector constructor. ----- > lookup_v 1 "k" defaultEvent == 1-lookup_v :: Value -> Key -> Event -> Value-lookup_v v k e = fromMaybe v (lookup_m k e)+-- > f_array [1,2] == F_Vector [F_Double 1,F_Double 2]+f_array :: [Double] -> Field+f_array = F_Vector . map F_Double --- | Variant of 'lookup_v' with a transformation function.+-- | Maybe variant of 'f_vector'.+f_vector_m :: Field -> Maybe [Field]+f_vector_m f = case f of {F_Vector v -> Just v;_ -> Nothing;}++-- | 'length' of 'f_vector_m'. ----- > lookup_t 1 negate "k" defaultEvent == 1--- > lookup_t 1 negate "k" (insert "k" 1 defaultEvent) == -1-lookup_t :: t -> (Value -> t) -> Key -> Event -> t-lookup_t v f k e =-    case lookup_m k e of-      Nothing -> v-      Just v' -> f v'+-- > f_vector_length (f_array [1..5]) == Just 5+f_vector_length :: Field -> Maybe Int+f_vector_length = fmap length . f_vector_m --- | Lookup 'Pitch' model parameters at /e/ and construct a 'Pitch'--- value.-pitch :: Event -> P.Pitch Double-pitch e =-    let get_r v k = lookup_v v k e-        get_m v k = lookup_t v const k e-    in P.Pitch {P.mtranspose = get_r 0 "mtranspose"-               ,P.gtranspose = get_r 0 "gtranspose"-               ,P.ctranspose = get_r 0 "ctranspose"-               ,P.octave = get_r 5 "octave"-               ,P.root = get_r 0 "root"-               ,P.degree = get_r 0 "degree"-               ,P.scale = [0, 2, 4, 5, 7, 9, 11]-               ,P.stepsPerOctave = get_r 12 "stepsPerOctave"-               ,P.detune = get_r 0 "detune"-               ,P.harmonic = get_r 1 "harmonic"-               ,P.freq_f = get_m P.default_freq_f "freq"-               ,P.midinote_f = get_m P.default_midinote_f "midinote"-               ,P.note_f = get_m P.default_note_f "note"}+-- | Indexed variant of 'f_double_err'.+--+-- > f_double_err_ix "" Nothing 1 == 1+-- > f_double_err_ix "" (Just 1) (f_array [0,1]) == 1+f_double_err_ix :: String -> Maybe Int -> Field -> Double+f_double_err_ix err n =+    case n of+      Nothing -> f_double_err err+      Just i -> f_double_err err . (!! i) . f_vector --- | Lookup 'D.Duration' model parameters at an 'Event' and construct a--- 'D.Duration' value.-duration :: Event -> D.Duration Double-duration e =-    let get_r v k = lookup_v v k e-        get_m v k = lookup_t v const k e-        get_o k = lookup_m k e-    in D.Duration {D.tempo = get_r 60 "tempo"-                  ,D.dur = get_r 1 "dur"-                  ,D.stretch = get_r 1 "stretch"-                  ,D.legato = get_r 0.8 "legato"-                  ,D.sustain_f = get_m D.default_sustain_f "sustain"-                  ,D.delta_f = get_m D.default_delta_f "delta"-                  ,D.lag = get_r 0.1 "lag"-                  ,D.fwd' = get_o "fwd'"}+-- | Maybe variant of 'f_instr'.+f_instr_m :: Field -> Maybe I.Instr+f_instr_m f = case f of {F_Instr n -> Just n;_ -> Nothing;} --- | Insert (/k/,/v/) into /e/.+-- | Variant of 'f_instr' with specified error message.+f_instr_err :: String -> Field -> I.Instr+f_instr_err err = fromMaybe (error ("f_instr: " ++ err)) . f_instr_m++-- | Map /fn/ over vector elements at /f/. ----- > lookup_m "k" (insert "k" 1 defaultEvent) == Just 1-insert :: Key -> Value -> Event -> Event-insert k v e = e {e_map = M.insert k v (e_map e)}+-- > f_map negate (f_array [0,1]) == f_array [0,-1]+f_map :: (Field -> Field) -> Field -> Field+f_map fn f =+    case f of+      F_Vector l -> F_Vector (map fn l)+      _ -> error ("f_map: " ++ show f) --- | Lookup /db/ field of 'Event', the default value is @-20db@.-db :: Event -> Value-db = lookup_v (-20) "db"+-- | Numerical unary operator.+--+-- > f_uop negate (F_Double 1) == F_Double (-1)+-- > f_uop negate (F_Vector [F_Double 0,F_Double 1]) == f_array [0,-1]+f_uop :: (Double -> Double) -> Field -> Field+f_uop f p =+    case p of+      F_Double n -> F_Double (f n)+      F_Vector v -> F_Vector (map (f_uop f) v)+      _ -> error ("f_uop: " ++ show p) --- | Function to convert from decibels to linear amplitude.-dbAmp' :: Floating a => a -> a-dbAmp' a = 10 ** (a * 0.05)+-- | Numerical binary operator.+--+-- > f_binop (+) (F_Double 1) (F_Double 2) == F_Double 3+-- > f_binop (*) (f_array [1,2,3]) (f_array [3,4,5]) == f_array [3,8,15]+-- > f_binop (/) (F_Double 9) (F_Double 3) == F_Double 3+f_binop :: (Double -> Double -> Double) -> Field -> Field -> Field+f_binop f p q =+    case (p,q) of+      (F_Double m,F_Double n) -> F_Double (f m n)+      (F_Vector v,F_Vector w) -> F_Vector (C.zipWith_c (f_binop f) v w)+      (F_Double _,F_Vector w) -> F_Vector (C.zipWith_c (f_binop f) [p] w)+      (F_Vector v,F_Double _) -> F_Vector (C.zipWith_c (f_binop f) v [q])+      _ -> error ("f_binop: " ++ show (p,q)) --- | The linear amplitude of the amplitude model at /e/.+-- | At floating branch of 'Field'.+f_atf :: (Double -> a) -> Field -> a+f_atf f = f . f_double++-- | At floating branches of 'Field's.+f_atf2 :: (Double -> Double -> a) -> Field -> Field -> a+f_atf2 f p q =+    case (p,q) of+      (F_Double n1,F_Double n2) -> f n1 n2+      _ -> error ("f_atf2: " ++ show (p,q))++-- | At floating branches of 'Field's.+f_atf3 :: (Double -> Double -> Double -> a) -> Field -> Field -> Field -> a+f_atf3 f p q r =+    case (p,q,r) of+      (F_Double n1,F_Double n2,F_Double n3) -> f n1 n2 n3+      _ -> error ("f_atf3: " ++ show (p,q,r))++-- | Extend to 'Field' to /n/. ----- > amp (event [("db",-20)]) == 0.1-amp :: Event -> Value-amp e = lookup_v (dbAmp' (db e)) "amp" e+-- > f_mce_extend 3 (f_array [1,2]) == f_array [1,2,1]+-- > f_mce_extend 3 1 == f_array [1,1,1]+f_mce_extend :: Int -> Field -> Field+f_mce_extend n f =+    case f of+      F_Vector v -> F_Vector (take n (cycle v))+      _ -> F_Vector (replicate n f) --- | The /fwd/ value of the duration model at /e/.+instance IsString Field where+    fromString = F_String++instance Num Field where+    (+) = f_binop (+)+    (*) = f_binop (*)+    negate = f_uop negate+    abs = f_uop abs+    signum = f_uop signum+    fromInteger = F_Double . fromInteger++instance Fractional Field where+    recip = f_uop recip+    (/) = f_binop (/)+    fromRational n = F_Double (fromRational n)++instance Floating Field where+    pi = F_Double pi+    exp = f_uop exp+    log = f_uop log+    sqrt = f_uop sqrt+    (**) = f_binop (**)+    logBase = f_binop logBase+    sin = f_uop sin+    cos = f_uop cos+    tan = f_uop tan+    asin = f_uop asin+    acos = f_uop acos+    atan = f_uop atan+    sinh = f_uop sinh+    cosh = f_uop cosh+    tanh = f_uop tanh+    asinh = f_uop asinh+    acosh = f_uop acosh+    atanh = f_uop atanh++instance Real Field where+    toRational d =+        case d of+          F_Double n -> toRational n+          _ -> error ("Field.toRational: " ++ show d)++instance RealFrac Field where+  properFraction d =+      let (i,j) = properFraction (f_double d)+      in (i,F_Double j)+  truncate = f_atf truncate+  round = f_atf round+  ceiling = f_atf ceiling+  floor = f_atf floor++instance RealFloat Field where+    floatRadix = f_atf floatRadix+    floatDigits = f_atf floatDigits+    floatRange = f_atf floatRange+    decodeFloat = f_atf decodeFloat+    encodeFloat i = F_Double . encodeFloat i+    exponent = f_atf exponent+    significand = f_uop significand+    scaleFloat i = f_uop (scaleFloat i)+    isNaN = f_atf isNaN+    isInfinite = f_atf isInfinite+    isDenormalized = f_atf isDenormalized+    isNegativeZero = f_atf isNegativeZero+    isIEEE = f_atf isIEEE+    atan2 = f_binop atan2++instance Ord Field where+    compare p q =+        case (p,q) of+          (F_Double m,F_Double n) -> compare m n+          _ -> error ("Field.compare: " ++ show (p,q))++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)+    toEnum = F_Double . fromIntegral++instance Random Field where+  randomR i g =+      case i of+        (F_Double l,F_Double r) ->+            let (n,g') = randomR (l,r) g+            in (F_Double n,g')+        _ -> error ("Field.randomR: " ++ show i)+  random g = let (n,g') = randomR (0::Double,1::Double) g+             in (F_Double n,g')++instance EqE Field+instance OrdE Field+instance RealFracE Field+instance UnaryOp Field+instance BinaryOp Field++-- * Key++-- | The type of the /key/ at an 'Event'. ----- > fwd (event [("dur",1),("stretch",2)]) == 2-fwd :: Event -> Double-fwd = D.fwd . duration+-- > :set -XOverloadedStrings+-- > [K_dur,"pan"] == [K_dur,K_param "pan"]+data Key = K_degree | K_mtranspose | K_scale | K_stepsPerOctave+         | K_gtranspose | K_note | K_octave | K_root+         | K_ctranspose | K_harmonic | K_midinote+         | K_detune | K_freq+         | K_delta | K_dur | K_lag | K_legato | K_fwd' | K_stretch | K_sustain | K_tempo+         | K_db | K_amp+         | K_rest+         | K_instr | K_id | K_type | K_latency+         | K_param String+           deriving (Eq,Ord,Show) --- | The /latency/ to compensate for when sending messages based on--- the event.  Defaults to @0.1@.-latency :: Event -> Double-latency = lookup_v 0.1 "latency"+instance IsString Key where+    fromString = K_param --- | List of 'Key's used in pitch, duration and amplitude models.+-- | SC3 name of 'Key'. ----- > ("degree" `elem` model_keys) == True-model_keys :: [Key]-model_keys =-    ["amp","db"-    ,"delta","dur","legato","fwd'","stretch","sustain","tempo"-    ,"ctranspose","degree","freq","midinote","mtranspose","note","octave"-    ,"rest"]+-- > map k_name [K_freq,K_dur,K_param "pan"] == ["freq","dur","pan"]+k_name :: Key -> String+k_name k =+    case k of+      K_param nm -> nm+      _ -> drop 2 (show k)  -- | List of reserved 'Key's used in pitch, duration and amplitude -- models.  These are keys that may be provided explicitly, but if not -- will be calculated implicitly. ----- > ("freq" `elem` reserved) == True-reserved :: [Key]-reserved = ["freq","midinote","note"-           ,"delta","sustain"-           ,"amp"]+-- > (K_freq `elem` k_reserved) == True+k_reserved :: [Key]+k_reserved = [K_freq,K_midinote,K_note+             ,K_delta,K_sustain+             ,K_amp+             ,K_instr,K_id,K_type,K_latency,K_rest] --- | If 'Key' is 'reserved' then 'Nothing', else 'id'.-parameters' :: (Key,Value) -> Maybe (Key,Value)-parameters' (k,v) =-    if k `elem` reserved-    then Nothing-    else Just (k,v)+k_vector :: [Key]+k_vector = [K_scale] --- | Extract non-'reserved' 'Keys' from 'Event'.-parameters :: Event -> [(Key,Value)]-parameters = mapMaybe parameters' . M.toList . e_map+-- | Is 'Key' /not/ 'k_reserved', and /not/ 'k_vector'.+--+-- > k_is_parameter (K_param "pan",0) == True+k_is_parameter :: (Key,a) -> Bool+k_is_parameter (k,_) = k `notElem` (k_reserved ++ k_vector) --- | 'Value' editor for 'Key' at 'Event', with default value in case--- 'Key' is not present.-edit_v :: Key -> Value -> (Value -> Value) -> Event -> Event-edit_v k v f e =-    case lookup_m k e of-      Just n -> insert k (f n) e-      Nothing -> insert k (f v) e+-- * Event --- | Variant of 'edit_v' with no default value.-edit :: Key -> (Value -> Value) -> Event -> Event-edit k f e =-    case lookup_m k e of-      Just n -> insert k (f n) e-      Nothing -> e+-- | An 'Event' is a ('Key','Field') map.+type Event = Map.Map Key Field --- | Basic 'Event' constructor function with 'e_map' given as a list.-from_list :: Type -> Maybe Int -> Maybe I.Instrument -> [(Key,Value)] -> Event-from_list t n i l =-    Event {e_type = t-          ,e_id = n-          ,e_instrument = i-          ,e_map = M.fromList l}+-- | Insert (/k/,/v/) into /e/.+--+-- > e_get K_id (e_insert K_id 1 mempty) == Just 1+e_insert :: Key -> Field -> Event -> Event+e_insert k v = Map.insert k v --- | Construct an 'Event' from a list of (/key/,/value/) pairs.+-- | Event from association list. ----- > lookup_m "k" (event [("k",1)]) == Just 1-event :: [(Key,Value)] -> Event-event l =-    Event {e_type = E_s_new-          ,e_id = Nothing-          ,e_instrument = Nothing-          ,e_map = M.fromList l}+-- > e_get K_id (e_from_list [(K_id,1)]) == Just 1+e_from_list :: [(Key,Field)] -> Event+e_from_list = Map.fromList --- | Extract 'I.Instrument' name from 'Event', or @default@.-instrument_name :: Event -> String-instrument_name e =-    case e_instrument e of-      Nothing -> "default"-      Just (I.InstrumentDef s _) -> S.synthdefName s-      Just (I.InstrumentName s _) -> s+-- | Event from association list.+--+-- > let a = [(K_id,1)] in e_to_list (e_from_list a) == a+e_to_list :: Event -> [(Key,Field)]+e_to_list = Map.toList --- | Extract 'I.Instrument' definition from 'Event' if present.-instrument_def :: Event -> Maybe S.Synthdef-instrument_def e =-    case e_instrument e of-      Nothing -> Nothing-      Just (I.InstrumentDef s _) -> Just s-      Just (I.InstrumentName _ _) -> Nothing+-- | Lookup /k/ in /e/.+--+-- > e_get K_id mempty == Nothing+e_get :: Key -> Event -> Maybe Field+e_get k = Map.lookup k --- | 'I.send_release' of 'I.Instrument' at 'Event'.-instrument_send_release :: Event -> Bool-instrument_send_release e =-    case e_instrument e of-      Nothing -> True-      Just i -> I.send_release i+-- | Immediate or vector element lookup.+--+-- > e_get_ix Nothing K_id (e_from_list [(K_id,1)]) == Just 1+--+-- > let n = f_array [0,1,2]+-- > in e_get_ix Nothing K_id (e_from_list [(K_id,n)]) == Just n+--+-- > let n = f_array [0..9]+-- > in e_get_ix (Just 5) K_id (e_from_list [(K_id,n)]) == Just 5+e_get_ix :: Maybe Int -> Key -> Event -> Maybe Field+e_get_ix n k =+    case n of+      Nothing -> e_get k+      Just i -> fmap ((!! i) . f_vector) . e_get k --- | Merge two sorted sequence of (/location/,/value/) pairs.+-- | Type specialised 'e_get'.+e_get_double :: Key -> Event -> Maybe Double+e_get_double k = fmap (f_double_err (k_name k)) . e_get k++-- | Type specialised 'e_get_ix'.+e_get_double_ix :: Maybe Int -> Key -> Event -> Maybe Double+e_get_double_ix n k = fmap (f_double_err (k_name k)) . e_get_ix n k++-- | Type specialised 'e_get'.+e_get_bool :: Key -> Event -> Maybe Bool+e_get_bool k = fmap (f_bool_err (k_name k)) . e_get k++-- | Type specialised 'e_get'.+e_get_int :: Key -> Event -> Maybe Int+e_get_int k = fmap (f_int_err (k_name k)) . e_get k++-- | Type specialised 'e_get_ix'.+e_get_int_ix :: Maybe Int -> Key -> Event -> Maybe Int+e_get_int_ix n k = fmap (f_int_err (k_name k)) . e_get_ix n k++-- | Type specialised 'e_get'.+e_get_instr :: Key -> Event -> Maybe I.Instr+e_get_instr k = fmap (f_instr_err (k_name k)) . e_get k++-- | Type specialised 'e_get_ix'.+e_get_instr_ix :: Maybe Int -> Key -> Event -> Maybe I.Instr+e_get_instr_ix n k = fmap (f_instr_err (k_name k)) . e_get_ix n k++-- | Type specialised 'e_get'.+e_get_array :: Key -> Event -> Maybe [Double]+e_get_array k = fmap (map (f_double_err (k_name k)) . f_vector) . e_get k++-- | Type specialised 'e_get_ix'. ----- > let m = f_merge (zip [0,2..6] ['a'..]) (zip [0,3,6] ['A'..])--- > in m == [(0,'a'),(0,'A'),(2,'b'),(3,'B'),(4,'c'),(6,'d'),(6,'C')]-f_merge :: Ord a => [(a,t)] -> [(a,t)] -> [(a,t)]-f_merge p q =-    case (p,q) of-      ([],_) -> q-      (_,[]) -> p-      ((t0,e0):r0,(t1,e1):r1) ->-            if t0 <= t1-            then (t0,e0) : f_merge r0 q-            else (t1,e1) : f_merge p r1+-- > let e = e_from_list [(K_scale,f_array [0,2])]+-- > in e_get_array_ix Nothing K_scale e == Just [0,2]+--+-- > let e = e_from_list [(K_scale,f_ref (f_array [0,2]))]+-- > in e_get_array_ix (Just 0) K_scale e == Just [0,2]+e_get_array_ix :: Maybe Int -> Key -> Event -> Maybe [Double]+e_get_array_ix n k =+    fmap (map (f_double_err (k_name k)) . f_vector) .+    e_get_ix n k --- | Times are /hosc/ (NTP) times.-type Time = O.Time+-- | 'Event' /type/.+--+-- > e_type mempty == "s_new"+e_type :: Event -> String+e_type = fromMaybe "s_new" . fmap f_string . e_get K_type +-- | Match on event types, in sequence: s_new, n_set, rest.+e_type_match :: Event -> T3 (Event -> t) -> t+e_type_match e (f,g,h) =+    case e_type e of+      "s_new" -> f e+      "n_set" -> g e+      "rest" -> h e+      _ -> error ("Event.type: " ++ show e)++-- | 'const' variant of 'e_type_match'.+e_type_match' :: Event -> T3 t -> t+e_type_match' e (f,g,h) = e_type_match e (const f,const g,const h)++-- | Generate 'D.Dur' from 'Event'.+--+-- > D.delta (e_dur Nothing mempty) == 1+-- > D.fwd (e_dur Nothing (e_from_list [(K_dur,1),(K_stretch,2)])) == 2+--+-- > let e = e_from_list [(K_dur,1),(K_legato,0.5)]+-- > in D.occ (e_dur Nothing e) == 0.5+e_dur :: Maybe Int -> Event -> D.Dur+e_dur n e =+    let f k = e_get_double_ix n k e+    in D.optDur (f K_tempo+                ,f K_dur+                ,f K_stretch+                ,f K_legato+                ,f K_sustain+                ,f K_delta+                ,f K_lag+                ,f K_fwd')++-- | Generate 'Pitch' from 'Event'.+--+-- > P.midinote (e_pitch Nothing mempty) == 60+-- > P.freq (e_pitch Nothing (e_from_list [(K_degree,5)])) == 440+--+-- > let e = e_from_list [(K_degree,5),(K_scale,f_array [0,2,3,5,7,8,10])]+-- > in P.midinote (e_pitch Nothing e) == 68+--+-- > let e = e_from_list [(K_degree,5),(K_scale,f_ref (f_array [0,2,3,5,7,8,10]))]+-- > in P.midinote (e_pitch (Just 0) (e_mce_expand e)) == 68+--+-- > P.freq (e_pitch Nothing (e_from_list [(K_midinote,69)])) == 440+e_pitch :: Maybe Int -> Event -> P.Pitch+e_pitch n e =+    let f k = e_get_double_ix n k e+    in P.optPitch (f K_mtranspose+                  ,f K_gtranspose+                  ,f K_ctranspose+                  ,f K_octave+                  ,f K_root+                  ,f K_degree+                  ,e_get_array_ix n K_scale e+                  ,f K_stepsPerOctave+                  ,f K_detune+                  ,f K_harmonic+                  ,f K_freq+                  ,f K_midinote+                  ,f K_note)++-- | 'Event' identifier.+e_id :: Maybe Int -> Event -> Maybe Int+e_id n = e_get_int_ix n K_id++-- | Lookup /db/ field of 'Event'.+--+-- > e_db Nothing mempty == (-20)+e_db :: Maybe Int -> Event -> Double+e_db n = fromMaybe (-20) . e_get_double_ix n K_db++-- | The linear amplitude of the amplitude model at /e/.+--+-- > e_amp Nothing (e_from_list [(K_db,-60)]) == 0.001+-- > e_amp Nothing (e_from_list [(K_amp,0.01)]) == 0.01+-- > e_amp Nothing mempty == 0.1+e_amp :: Maybe Int -> Event -> Double+e_amp n e = fromMaybe (M.dbamp (e_db n e)) (e_get_double_ix n K_amp e)++-- | Message /latency/ of event.+--+-- > e_latency mempty == 0.1+e_latency :: Event -> Double+e_latency = fromMaybe 0.1 . e_get_double K_latency++-- | Extract non-'reserved' 'Keys' from 'Event'.+--+-- > let e = e_from_list [(K_freq,1),(K_param "p",1),(K_scale,f_ref (f_array [0,3,7]))]+-- > in e_parameters Nothing e == [("p",1)]+e_parameters :: Maybe Int -> Event -> [(String,Double)]+e_parameters n =+    map (\(k,v) -> (k_name k,f_double_err_ix (k_name k) n v)) .+    filter k_is_parameter .+    Map.toList++-- | 'Value' editor for 'Key' at 'Event', with default value in case+-- 'Key' is not present.+e_edit :: Key -> Field -> (Field -> Field) -> Event -> Event+e_edit k v f e =+    case e_get k e of+      Just n -> e_insert k (f n) e+      Nothing -> e_insert k (f v) e++-- | Variant of 'edit_v' with no default value.+e_edit' :: Key -> (Field -> Field) -> Event -> Event+e_edit' k f e =+    case e_get k e of+      Just n -> e_insert k (f n) e+      Nothing -> e++-- * Event temporal+ -- | Merge two time-stamped 'Event' sequences.  Note that this uses--- 'fwd' to calculate start times.-merge' :: (Time,[Event]) -> (Time,[Event]) -> [(Time,Event)]-merge' (pt,p) (qt,q) =-    let p_st = map (+ pt) (0 : scanl1 (+) (map fwd p))-        q_st = map (+ qt) (0 : scanl1 (+) (map fwd q))-    in f_merge (zip p_st p) (zip q_st q)+-- 'D.fwd' to calculate start times.+e_merge' :: (Time,[Event]) -> (Time,[Event]) -> [(Time,Event)]+e_merge' (pt,p) (qt,q) =+    let f = D.fwd . e_dur Nothing+        p_st = map (+ pt) (0 : scanl1 (+) (map f p))+        q_st = map (+ qt) (0 : scanl1 (+) (map f q))+    in t_merge (zip p_st p) (zip q_st q)  -- | Insert /fwd/ 'Key's into a time-stamped 'Event' sequence.-add_fwd :: [(Time,Event)] -> [Event]-add_fwd e =+e_add_fwd :: [(Time,Event)] -> [Event]+e_add_fwd e =     case e of       (t0,e0):(t1,e1):e' ->-          insert "fwd'" (t1 - t0) e0 : add_fwd ((t1,e1):e')+          e_insert K_fwd' (F_Double (t1 - t0)) e0 : e_add_fwd ((t1,e1):e')       _ -> map snd e  -- | Composition of 'add_fwd' and 'merge''.-merge :: (Time,[Event]) -> (Time,[Event]) -> [Event]-merge p q = add_fwd (merge' p q)+e_merge :: (Time,[Event]) -> (Time,[Event]) -> [Event]+e_merge p q = e_add_fwd (e_merge' p q) --- | Does 'Event' have a non-zero @rest@ key.-is_rest :: Event -> Bool-is_rest e =-    case lookup_m "rest" e of-      Just r -> r > 0-      Nothing -> False+-- | N-ary variant of 'e_merge'.+--+-- > e_par [(0,repeat (e_from_list [(K_id,1)]))+-- >       ,(0,repeat (e_from_list [(K_param "b",2)]))+-- >       ,(0,repeat (e_from_list [(K_param "c",3)]))]+e_par :: [(Time,[Event])] -> [Event]+e_par l =+    case l of+      [] -> []+      [(_,p)] -> p+      (pt,p):(qt,q):r -> e_par ((min pt qt,e_merge (pt,p) (qt,q)) : r) --- | Generate @SC3@ 'O.Bundle' messages describing 'Event'.  Consults the--- 'instrument_send_release' in relation to gate command.-to_sc3_bundle :: Time -> Int -> Event -> Maybe (O.Bundle,O.Bundle)-to_sc3_bundle t j e =-    let s = instrument_name e-        sr = instrument_send_release e-        p = pitch e-        d = duration e-        rt = D.sustain d {- rt = release time -}-        f = P.detunedFreq p-        pr = ("freq",f) : ("midinote",P.midinote p) : ("note",P.note p) :-             ("delta",D.delta d) : ("sustain",rt) :-             ("amp",amp e) :-             parameters e-        i = fromMaybe j (e_id e)-        t' = t + latency e-    in if is_rest e || isNaN f+-- | 'mempty' with /rest/.+e_rest :: Event+e_rest = e_from_list [(K_rest,1)]++-- | Does 'Event' have a 'True' @rest@ key.+--+-- > e_is_rest mempty == False+-- > e_is_rest (e_from_list [(K_rest,1)]) == True+e_is_rest :: Event -> Bool+e_is_rest = fromMaybe False . e_get_bool K_rest++-- * MCE++-- | Maximum vector length at 'Event'.+--+-- > e_mce_depth (e_from_list [(K_id,1)]) == Nothing+-- > e_mce_depth (e_from_list [(K_id,1),(K_param "b",f_array [2,3])]) == Just 2+e_mce_depth :: Event -> Maybe Int+e_mce_depth e =+    let f = map snd (e_to_list e)+    in case mapMaybe f_vector_length f of+         [] -> Nothing+         l -> Just (maximum l)++-- | Extend vectors at 'Event' if required, returning 'e_mce_depth'.+--+-- > let {e = e_from_list [(K_id,f_array [1,2]),(K_param "b",f_array [2,3,4])]+-- >     ;r = e_from_list [(K_id,f_array [1,2,1]),(K_param "b",f_array [2,3,4])]}+-- > in e_mce_extend e == Just (3,r)+--+-- > let e = e_from_list [(K_id,1)]+-- > in e_mce_extend e == Nothing+e_mce_extend :: Event -> Maybe (Int,Event)+e_mce_extend e =+    let e' = e_to_list e+        flds = map snd e'+        f n = let flds' = map (f_mce_extend n) flds+              in (n,e_from_list (zip (map fst e') flds'))+    in fmap f (e_mce_depth e)++-- | 'e_mce_extend' variant.+e_mce_expand :: Event -> Event+e_mce_expand e = maybe e snd (e_mce_extend e)++-- | Parallel 'Event's, if required.+--+-- > let {e = e_from_list [(K_id,1),(K_param "b",f_array [2,3])]+-- >     ;r = [e_from_list [(K_id,1),(K_param "b",2)],e_from_list [(K_id,1),(K_param "b",3)]]}+-- > in e_un_mce e == Just r+--+-- > let {e = e_from_list [(K_id,f_array [1,2]),(K_param "b",f_array [3,4,5])]+-- >     ;r = e_from_list [(K_id,1),(K_param "b",5)]}+-- > in fmap (!! 2) (e_un_mce e) == Just r+--+-- > e_un_mce (e_from_list [(K_id,1)]) == Nothing+e_un_mce :: Event -> Maybe [Event]+e_un_mce e =+    let e' = e_to_list e+        flds = map snd e'+        f n = let flds' = transpose (map (f_vector . f_mce_extend n) flds)+              in map (e_from_list . zip (map fst e')) flds'+    in fmap f (e_mce_depth e)++-- | 'e_un_mce' variant.+e_un_mce' :: Event -> [Event]+e_un_mce' e = fromMaybe [e] (e_un_mce e)++-- * SC3++-- | Generate @SC3@ /(on,off)/ 'Message' sets describing 'Event'.+e_messages :: D.Dur -> Event -> Int -> Maybe Int -> Maybe (T2 [Message])+e_messages d e n_id n =+    let e_i = e_get_instr_ix n K_instr e+        s = maybe "default" I.i_name e_i+        sr = maybe True I.i_send_release e_i+        p = e_pitch n e+        rt = D.occ d {- rt = release time -}+        f = P.freq p+        pr = ("freq",f)+             : ("midinote",P.midinote p)+             : ("delta",D.delta d)+             : ("sustain",rt)+             : ("amp",e_amp n e)+             : e_parameters n e+        n_id' = fromMaybe n_id (e_id n e)+    in if e_is_rest e || isNaN f        then Nothing-       else let m_on = case e_type e of-                         E_s_new -> [S.s_new s i S.AddToTail 1 pr]-                         E_n_set -> [S.n_set i pr]-                         E_rest -> []+       else let m_on = e_type_match' e ([s_new s n_id' AddToTail 1 pr]+                                       ,[n_set n_id' pr]+                                       ,[])                 m_off = if not sr                         then []-                        else case e_type e of-                               E_s_new -> [S.n_set i [("gate",0)]]-                               E_n_set -> [S.n_set i [("gate",0)]]-                               E_rest -> []-            in Just (O.Bundle t' m_on-                    ,O.Bundle (t' + rt) m_off)+                        else e_type_match' e ([n_set n_id' [("gate",0)]]+                                             ,[n_set n_id' [("gate",0)]]+                                             ,[])+                m_on' = case I.i_synthdef =<< e_i of+                          Just sy -> d_recv sy : m_on+                          Nothing -> m_on+            in Just (m_on',m_off) -{---- | The frequency of the 'pitch' of /e/.+-- | MCE variant of 'e_messages'.+e_messages_mce :: D.Dur -> Event -> Int -> (Maybe (T2 [Message]),Int)+e_messages_mce d e n_id =+    let (r,n) = case e_mce_extend e of+                  Just (m,e') -> (zipWith (e_messages d e') [n_id ..] (map Just [0 .. m - 1]),m)+                  Nothing -> ([e_messages d e n_id Nothing],1)+    in case unzip (catMaybes r) of+         ([],[]) -> (Nothing,n_id)+         (m_on,m_off) -> (Just (concat m_on,concat m_off),n_id + n)++-- | Generate @SC3@ /(on,off)/ 'Bundle's describing 'Event'.+e_bundles :: Time -> Int -> D.Dur -> Event-> (Maybe (T2 Bundle),Int)+e_bundles t n_id d e =+    let rt = D.occ d {- rt = release time -}+        t' = t + realToFrac (e_latency e)+        t'' = t' + realToFrac rt+    in case e_messages_mce d e n_id of+         (Nothing,n_id') -> (Nothing,n_id')+         (Just (m_on,m_off),n_id') -> (Just (Bundle t' m_on,Bundle t'' m_off),n_id')++-- | Ordered sequence of 'Event'.+newtype Event_Seq = Event_Seq {e_seq_events :: [Event]}++-- | Transform 'Event_Seq' into a sequence of @SC3@ /(on,off)/ 'Bundles'. ----- > freq (event [("degree",5)]) == 440--- > freq (event [("midinote",69)]) == 440-freq :: Event -> Double-freq = P.detunedFreq . pitch+-- > e_bundle_seq 0 (Event_Seq (replicate 5 mempty))+e_bundle_seq :: Time -> Event_Seq -> [T2 Bundle]+e_bundle_seq st =+    let rec t i l =+            case l of+              [] -> []+              e:l' -> let d = e_dur Nothing e+                          t' = t + D.fwd d+                          (b,i') = e_bundles t i d e+                      in b `mcons` rec t' i' l'+    in rec st 1000 . e_seq_events --- | The /sustain/ value of the duration model at /e/.+-- | Transform (productively) an 'Event_Seq' into an 'NRT' score. ----- > sustain (event [("dur",1),("legato",0.5)]) == 0.5-sustain :: Event -> Double-sustain = D.sustain . duration--}+-- > let {n1 = nrt_bundles (e_nrt (Event_Seq (replicate 5 mempty)))+-- >     ;n2 = take 10 (nrt_bundles (e_nrt (Event_Seq (repeat mempty))))}+-- > in n1 == n2+e_nrt :: Event_Seq -> NRT+e_nrt =+    let rec r l =+            case l of+              [] -> 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++-- | 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)++instance Audible Event_Seq where play = e_play++-- * Aliases++-- | Type-specialised 'mempty'.+e_empty :: Event+e_empty = mempty++-- | Type-specialised 'mappend'.+--+-- > let {l = [(K_id,0)];r = [(K_degree,1)]}+-- > in e_from_list l <> e_from_list r == e_from_list (l <> r)+e_union :: Event -> Event -> Event+e_union = mappend++-- * Temporal++-- | Left-biased merge of two sorted sequence of temporal values.+--+-- > let m = t_merge (zip [0,2,4,6] ['a'..]) (zip [0,3,6] ['A'..])+-- > in m == [(0,'a'),(0,'A'),(2,'b'),(3,'B'),(4,'c'),(6,'d'),(6,'C')]+t_merge :: Ord t => [(t,a)] -> [(t,a)] -> [(t,a)]+t_merge p q =+    case (p,q) of+      ([],_) -> q+      (_,[]) -> p+      ((t0,e0):r0,(t1,e1):r1) ->+            if t0 <= t1+            then (t0,e0) : t_merge r0 q+            else (t1,e1) : t_merge p r1++-- * Tuple++-- | Two tuple of /n/.+type T2 n = (n,n)++-- | Three tuple of /n/.+type T3 n = (n,n,n)++-- * List++-- | 'Maybe' variant of ':'.+mcons :: Maybe a -> [a] -> [a]+mcons e l = case e of {Just e' -> e' : l;Nothing -> l}

@@ -1,29 +1,40 @@ -- | An instrument abstraction and a /default/ instrument for patterns. module Sound.SC3.Lang.Control.Instrument where -import Sound.SC3.ID+import Data.Default {- data-default -}+import Sound.SC3.ID {- hsc3 -} --- | An 'Instrument' is either a 'Synthdef' or the 'String' naming a+-- | An 'Instr' is either a 'Synthdef' or the 'String' naming a -- 'Synthdef'.-data Instrument = InstrumentDef {instrument_def :: Synthdef-                                ,send_release :: Bool}-                | InstrumentName {instrument_name :: String-                                 ,send_release :: Bool}-                  deriving (Eq,Show)+data Instr = Instr_Def {i_def :: Synthdef,i_send_release :: Bool}+           | Instr_Ref {i_ref :: String,i_send_release :: Bool}+             deriving (Eq,Show) --- | The SC3 /default/ instrument 'Synthdef'.-defaultInstrument :: Synthdef-defaultInstrument =-    let f = control KR "freq" 440-        a = control KR "amp" 0.1-        p = control KR "pan" 0-        g = control KR "gate" 1-        e = linen g 0.01 0.7 0.3 RemoveSynth-        f3 = mce [f,f + rand 'a' (-0.4) 0,f + rand 'b' 0 0.4]-        l = xLine KR (rand 'c' 4000 5000) (rand 'd' 2500 3200) 1 DoNothing-        z = lpf (mix (varSaw AR f3 0 0.3 * 0.3)) l * e-    in synthdef "default" (out 0 (pan2 z p a))+-- | All 'Instr' have a name.+i_name :: Instr -> String+i_name i =+    case i of+      Instr_Def s _ -> synthdefName s+      Instr_Ref nm _ -> nm +-- | All 'Instr' may have a 'Synthdef'.+i_synthdef :: Instr -> Maybe Synthdef+i_synthdef i =+    case i of+      Instr_Def s _ -> Just s+      Instr_Ref _ _ -> Nothing++-- | If 'I_Def' subsequent are 'I_Ref', else all 'I_Ref'.+i_repeat :: Instr -> [Instr]+i_repeat i =+    case i of+      Instr_Def d sr -> i : repeat (Instr_Ref (synthdefName d) sr)+      Instr_Ref _ _ -> repeat i++-- | 'Instr' of 'defaultSynthdef', ie. 'def' of 'Synthdef'.+defaultInstr :: Instr+defaultInstr = Instr_Def def True+ {--withSC3 (\fd -> async fd (d_recv defaultInstrument))+withSC3 (send (d_recv defaultSynthdef)) -}

@@ -1,18 +1,34 @@-{-# LANGUAGE PackageImports #-} -- | For a single input controller, key events always arrive in--- sequence (ie. on->off), ie. for any key on message can allocate an--- ID and associate it with the key, an off message can retrieve the--- ID given the key.+-- 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. module Sound.SC3.Lang.Control.Midi where -import qualified Control.Exception as E-import Control.Monad-import "mtl" Control.Monad.State-import Data.Bits+import qualified Control.Exception as E {- base -}+import Control.Monad {- base -}+import Control.Monad.IO.Class {- transformers -}+import Control.Monad.Trans.State {- transformers -}+import Data.Bits {- base -} import qualified Data.ByteString.Lazy as B {- bytestring -} import qualified Data.Map as M {- containers -} import Sound.OSC.FD {- hosc -} +-- * Bits++-- | Join two 7-bit values into a 14-bit value.+--+-- > map (uncurry b_join) [(0,0),(0,64),(127,127)] == [0,8192,16383]+b_join :: Bits a => a -> a -> a+b_join p q = p .|. shiftL q 7++-- | Inverse of 'b_join'.+--+-- > map b_sep [0,8192,16383] == [(0,0),(0,64),(127,127)]+b_sep :: (Num t,Bits t) => t -> (t, t)+b_sep n = (0x7f .&. n,0xff .&. shiftR n 7)++-- * Types+ -- | <http://www.midi.org/techspecs/midimessages.php> data Midi_Message a = Chanel_Aftertouch a a                     | Control_Change a a a@@ -78,23 +94,13 @@       127 -> Poly_Mode_On i       _ -> Undefined --- | Join two 7-bit values into a 14-bit value.------ > map (uncurry b_join) [(0,0),(0,64),(127,127)] == [0,8192,16383]-b_join :: Bits a => a -> a -> a-b_join p q = p .|. shiftL q 7---- | Inverse of 'b_join'.------ > map b_sep [0,8192,16383] == [(0,0),(0,64),(127,127)]-b_sep :: (Num t,Bits t) => t -> (t, t)-b_sep n = (0x7f .&. n,0xff .&. shiftR n 7)+-- * OSC  -- | Parse @midi-osc@ @/midi/@ message. parse_b :: Integral n => Message -> [n] parse_b m =     case m of-      Message "/midi" [Int _,Blob b] -> map fromIntegral (B.unpack b)+      Message "/midi" [Int32 _,Blob b] -> map fromIntegral (B.unpack b)       _ -> []  -- | Variant of 'parse_b' that give status byte as low and high.@@ -118,6 +124,8 @@       [0xe,i,j,k] -> Pitch_Bend i (b_join j k)       x -> Unknown x +-- * SC3+ -- | @SC3@ node identifiers are integers. type Node_Id = Int @@ -144,6 +152,8 @@   (K m _) <- get   return (m M.! n) +-- * IO+ -- | 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@.@@ -165,7 +175,7 @@ start_midi receiver = do   s_fd <- openUDP "127.0.0.1" 57110 -- midi-osc   m_fd <- openUDP "127.0.0.1" 57150 -- midi-osc-  sendMessage m_fd (Message "/receive" [Int 0xffff])+  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)) >>

@@ -7,10 +7,12 @@ -- post-processing stage. module Sound.SC3.Lang.Control.OverlapTexture where -import Data.List+import Control.Applicative {- base -}+import Data.List {- base -} import Sound.OSC {- hosc -} import Sound.SC3 {- hsc3 -}-import Sound.SC3.Lang.Control.Event as E {- hsc3-lang -}++import Sound.SC3.Lang.Control.Event import Sound.SC3.Lang.Control.Instrument import Sound.SC3.Lang.Pattern.ID @@ -36,6 +38,7 @@ -- overlaping (simultaneous) nodes and 4. number of nodes altogether. type OverlapTexture = (Double,Double,Double,Int) +-- | Record of 'OverlapTexture'. data OverlapTexture_ =     OverlapTexture {sustain_time :: Double                    ,transition_time :: Double@@ -81,15 +84,16 @@       g' = with_env k g   in synthdef n g' --- | Generate an 'Event' pattern from 'OverlapTexture' control+-- | 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-        i = return (InstrumentDef s False)-    in pinstr i (pbind [("dur",pn (return d) c),("legato", return l)])+    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 'overlapTextureP'. --@@ -111,12 +115,12 @@         nm = show (hashUGen u)     in synthdef nm u --- | Audition 'Event' pattern with specified post-processing function.-post_process_a :: Transport m => P Event -> Int -> (UGen -> UGen) -> m ()+-- | 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   _ <- async (d_recv s)-  send (s_new (synthdefName s) (-1) AddToTail 2 [])+  send (s_new0 (synthdefName s) (-1) AddToTail 2)   play p  -- | Post processing function.@@ -128,15 +132,16 @@   let p = overlapTextureP k u   withSC3 (post_process_a p nc f) --- | Generate an 'Event' pattern from 'XFadeTexture' control+-- | 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-        i = return (InstrumentDef s False)-    in pinstr i (pbind [("dur",pn (return d) c),("legato", return l)])+    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'. --@@ -155,17 +160,19 @@ -- | UGen generating state transform function. type USTF st = (st -> (UGen,st)) --- | Variant of 'overlapTextureP' where the continuous signal for--- each 'Event' is derived from a state transform function seeded with+-- | Variant of 'overlapTextureP' 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         (_,_,_,c) = k         g = take c (unfoldr (Just . u) i_st)-        i = flip InstrumentDef False-        s = map (i . gen_synth (overlapTexture_env k)) g-    in pinstr (fromList s) (pbind [("dur",prepeat d),("legato",prepeat l)])+        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))]  -- | Audition pattern given by 'overlapTextureP_st'. overlapTextureS :: OverlapTexture -> USTF st -> st -> IO ()@@ -181,9 +188,9 @@ type MSTF st m = (st -> m (Maybe st))  -- | Run a monadic state transforming function /f/ that operates with--- a delta 'E.Time' indicating the duration to pause before re-running+-- a delta 'Time' indicating the duration to pause before re-running -- the function.-dt_rescheduler_m :: MonadIO m => MSTF (st,E.Time) m -> (st,E.Time) -> m ()+dt_rescheduler_m :: MonadIO m => MSTF (st,Time) m -> (st,Time) -> m () dt_rescheduler_m f =     let rec (st,t) = do           pauseThreadUntil t@@ -194,7 +201,8 @@     in rec  -- | Underlying function of 'overlapTextureM' with explicit 'Transport'.-overlapTextureR :: Transport m => OverlapTexture -> IO UGen -> MSTF (Int,E.Time) m+overlapTextureR :: Transport m =>+                   OverlapTexture -> IO UGen -> MSTF (Int,Time) m overlapTextureR k uf =   let nm = "ot_" ++ show k       (_,dt) = overlapTexture_dt k@@ -202,7 +210,7 @@         u <- liftIO uf         let g = with_env (overlapTexture_env k) u         _ <- async (d_recv (synthdef nm g))-        send (s_new nm (-1) AddToTail 1 [])+        send (s_new0 nm (-1) AddToTail 1)         case st of           0 -> return Nothing           _ -> return (Just (st-1,dt))

@@ -1,6 +1,22 @@ -- | @SC3@ pitch model implementation. module Sound.SC3.Lang.Control.Pitch where +import Data.Maybe {- base -}+import Sound.SC3.Lang.Math++-- * Pitched++-- | 'Pitched' values, minimal definition is 'midinote'.+--+-- > midinote (defaultPitch {degree = 5}) == 69+-- > freq (defaultPitch {degree = 5,detune = 10}) == 440 + 10+class Pitched p where+    midinote :: p -> Double+    freq :: p -> Double+    freq = midicps . midinote++-- * Pitch+ -- | The supercollider language pitch model is organised as a tree -- with three separate layers, and is designed to allow separate -- processes to manipulate aspects of the model independently.@@ -14,7 +30,7 @@ -- a scale interpreted relative to an equally tempered octave divided -- into the indicated number of steps. ----- The midinote is derived from the note by adding the inidicated+-- The midinote is derived from the note by adding the indicated -- root, octave and gamut transpositions. -- -- The frequency is derived by a chromatic transposition of the@@ -38,99 +54,89 @@ -- -- > let {edit_mtranspose p d = p {mtranspose = mtranspose p + d} -- >     ;edit_octave p o = p {octave = octave p + o}--- >     ;p = repeat defaultPitch--- >     ;q = zipWith edit_mtranspose p [0,2,4,3,5]--- >     ;r = zipWith edit_octave q [0,-1,0,1,0]}--- > in (map midinote q,map midinote r)-data Pitch a = Pitch { mtranspose :: a-                     , gtranspose :: a-                     , ctranspose :: a-                     , octave :: a-                     , root :: a-                     , scale :: [a]-                     , degree :: a-                     , stepsPerOctave :: a-                     , detune :: a-                     , harmonic :: a-                     , freq_f :: Pitch a -> a-                     , midinote_f :: Pitch a -> a-                     , note_f :: Pitch a -> a }---- | Midi note number to cycles per second.------ > midi_cps 69 == 440-midi_cps :: (Floating a) => a -> a-midi_cps a = 440.0 * (2.0 ** ((a - 69.0) * (1.0 / 12.0)))+-- >     ;p' = repeat defaultPitch+-- >     ;q = zipWith edit_mtranspose p' [0,2,4,3,5]+-- >     ;r = zipWith edit_octave q [0,-1,0,1,0]+-- >     ;f = map midinote}+-- > in (f q,f r) == ([60,64,67,65,69],[60,52,67,77,69])+data Pitch = Pitch {mtranspose :: Double+                   ,gtranspose :: Double+                   ,ctranspose :: Double+                   ,octave :: Double+                   ,root :: Double+                   ,scale :: [Double]+                   ,degree :: Double+                   ,stepsPerOctave :: Double+                   ,detune :: Double+                   ,harmonic :: Double+                   ,freq' :: Maybe Double+                   ,midinote' :: Maybe Double+                   ,note' :: Maybe Double+                   }+           deriving (Eq,Show)  -- | A default 'Pitch' value of middle C given as degree @0@ of a C -- major scale. ----- > degree defaultPitch == 0--- > scale defaultPitch == [0,2,4,5,7,9,11]--- > stepsPerOctave defaultPitch == 12-defaultPitch :: (Floating a, RealFrac a) => Pitch a+-- > let {p = defaultPitch+-- >     ;r = ([0,2,4,5,7,9,11],12,0,5,0)}+-- > in (scale p,stepsPerOctave p,root p,octave p,degree p) == r+defaultPitch :: Pitch defaultPitch =-    Pitch { mtranspose = 0-          , gtranspose = 0-          , ctranspose = 0-          , octave = 5-          , root = 0-          , degree = 0-          , scale = [0,2,4,5,7,9,11]-          , stepsPerOctave = 12-          , detune = 0-          , harmonic = 1-          , freq_f = default_freq_f-          , midinote_f = default_midinote_f-          , note_f = default_note_f+    Pitch {mtranspose = 0+          ,gtranspose = 0+          ,ctranspose = 0+          ,octave = 5+          ,root = 0+          ,degree = 0+          ,scale = [0,2,4,5,7,9,11]+          ,stepsPerOctave = 12+          ,detune = 0+          ,harmonic = 1+          ,freq' = Nothing+          ,midinote' = Nothing+          ,note' = Nothing           } --- | The 'freq_f' function for 'defaultPitch'.-default_freq_f :: (Floating a) => Pitch a -> a-default_freq_f e = midi_cps (midinote e + ctranspose e) * harmonic e---- | The 'midinote_f' function for 'defaultPitch'.-default_midinote_f :: (Fractional a) => Pitch a -> a-default_midinote_f e =-    let n = note e + gtranspose e + root e-    in (n / stepsPerOctave e + octave e) * 12---- | The 'note_f' function for 'defaultPitch'.-default_note_f :: (RealFrac a) => Pitch a -> a-default_note_f e =-    let d = degree e + mtranspose e-    in degree_to_key (scale e) (stepsPerOctave e) d---- | Translate degree, scale and steps per octave to key.------ > degree_to_key [0,2,4,5,7,9,11] 12 5 == 9-degree_to_key :: (RealFrac a) => [a] -> a -> a -> a-degree_to_key s n d =-    let l = length s-        d' = round d-        a = (d - fromIntegral d') * 10.0 * (n / 12.0)-    in (n * fromIntegral (d' `div` l)) + (s !! (d' `mod` l)) + a---- | The note value of the pitch model.+-- | Calculate /note/ field. -- -- > note (defaultPitch {degree = 5}) == 9-note :: Pitch a -> a-note e = note_f e e+note :: Pitch -> Double+note p =+    let f e = let d = degree e + mtranspose e+              in degreeToKey (scale e) (stepsPerOctave e) d+    in fromMaybe (f p) (note' p) --- | The midi note value of the pitch model.------ > midinote (defaultPitch {degree = 5}) == 69-midinote :: Pitch a -> a-midinote e = midinote_f e e+instance Pitched Pitch where+    midinote p =+        let f e = let n = note e + gtranspose e + root e+                  in (n / stepsPerOctave e + octave e) * 12+        in fromMaybe (f p) (midinote' p)+    freq p =+        let f e = midicps (midinote e + ctranspose e) * harmonic e+        in fromMaybe (f p) (freq' p) + detune p --- | The frequency value of the pitch model, excluding 'detune'.------ > freq (defaultPitch {degree = 5,detune = 10}) == 440-freq :: Pitch a -> a-freq e = freq_f e e+-- * Optional --- | The frequency value of the complete pitch model, including 'detune'.------ > detunedFreq (defaultPitch {degree = 5}) == 440-detunedFreq :: (Num a) => Pitch a -> a-detunedFreq e = freq e + detune e+-- | Tuple in 6-1-6 arrangement.+type T616 a b c = (a,a,a,a,a,a,b,c,c,c,c,c,c)++-- | 'Pitch' represented as tuple of optional values.+type OptPitch = T616 (Maybe Double) (Maybe [Double]) (Maybe Double)++-- | Transform 'OptPitch' to 'Pitch'.+optPitch :: OptPitch -> Pitch+optPitch (mt,gt,ct,o,r,d,s,s',d',h,f,m,n) =+    Pitch {mtranspose = fromMaybe 0 mt+          ,gtranspose = fromMaybe 0 gt+          ,ctranspose = fromMaybe 0 ct+          ,octave = fromMaybe 5 o+          ,root = fromMaybe 0 r+          ,degree = fromMaybe 0 d+          ,scale = fromMaybe [0,2,4,5,7,9,11] s+          ,stepsPerOctave = fromMaybe 12 s'+          ,detune = fromMaybe 0 d'+          ,harmonic = fromMaybe 1 h+          ,freq' = f+          ,midinote' = m+          ,note' = n}

@@ -1,37 +1,40 @@ -- | @sclang@ math functions. module Sound.SC3.Lang.Math where -import Data.Bits+import Data.Bits {- base -} --- * Binary+-- * SimpleNumber --- | @0@ is false, @1@ is True, else error.+-- | @SimpleNumber.ampdb@ converts linear amplitude to decibels. ----- > map bitChar "01" == [False,True]-bitChar :: Char -> Bool-bitChar c =-    case c of-      '0' -> False-      '1' -> True-      _ -> error "bitChar"---- | Parse a sequence of 0 and 1 characters as a BE bit sequence+-- > > [1,0.5,0.25,0.13,6e-2].collect({|i| i.ampdb.round}) == [0,-6,-12,-18,-24]+-- > map (round . ampdb) [1,0.5,0.25,0.13,6e-2] == [0,-6,-12,-18,-24] ----- > parseBits "101" == 5--- > parseBits "00001111" == 15-parseBits :: (Num a,Bits a) => String -> a-parseBits x =-    let x' = filter (id . bitChar . snd) (zip [0..] (reverse x))-    in foldr ((.|.) . bit . fst) 0 x'+-- > > [1,0.7,0.5,0.35,0.25].collect({|i| i.ampdb.round}) == [0,-3,-6,-9,-12]+-- > map (round . ampdb) [1,0.7,0.5,0.35,0.25] == [0,-3,-6,-9,-12]+ampdb :: Floating a => a -> a+ampdb = (* 20) . log10 --- * SimpleNumber+-- | @SimpleNumber.dbamp@ converts decibels to a linear amplitude.+--+-- > > [0,-3,-6,-9,-12].collect({|i| (i.dbamp * 100).floor}) == [100,70,50,35,25]+-- > map (floor . (* 100) . dbamp) [0,-3,-6,-9,-12] == [100,70,50,35,25]+dbamp :: Floating a => a -> a+dbamp = (10 **) .  (* 0.05) --- | Variant of @SimpleNumber.exprand@ that shifts a linear (0,1)--- value to an exponential distribution.+-- | @SimpleNumber.degreeToKey@ translates degree, scale and steps per+-- octave to key. ----- > map (floor . exprandrng 10 100) [0,0.5,1] == [10,31,100]-exprandrng :: (Floating b) => b -> b -> b -> b-exprandrng l r i = l * exp (log (r / l) * i)+-- > > (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+degreeToKey :: (RealFrac a) => [a] -> a -> a -> a+degreeToKey s n d =+    let l = length s+        d' = round d+        a = (d - fromIntegral d') * 10.0 * (n / 12.0)+    in (n * fromIntegral (d' `div` l)) + (s !! (d' `mod` l)) + a  -- | Psuedo-inifite bounded value. --@@ -47,6 +50,7 @@  -- | @SimpleNumber.linexp@ shifts from linear to exponential ranges. --+-- > > [1,1.5,2].collect({|i| i.linexp(1,2,10,100).floor}) == [10,31,100] -- > map (floor . linexp 1 2 10 100) [1,1.5,2] == [10,31,100] linexp :: (Ord a, Floating a) => a -> a -> a -> a -> a -> a linexp l r l' r' n =@@ -56,24 +60,44 @@          then r'          else ((r'/l') ** ((n-l)/(r-l))) * l' --- * Gain---- | Synonym for 'logBase' @10@.+-- | @SimpleNumber.log10@ is the base 10 logarithm. log10 :: Floating a => a -> a log10 = logBase 10 --- > map rmsToDb [1,0.75,0.5,0.25,0]-rmsToDb :: Floating a => a -> a-rmsToDb rms = log10 rms * 20+-- | @SimpleNumber.midicps@ translates from midi note number to cycles+-- per second.+--+-- > > [57,69].collect({|i| i.midicps}) == [220,440]+-- > map midicps [57,69] == [220,440]+midicps :: (Floating a) => a -> a+midicps a = 440.0 * (2.0 ** ((a - 69.0) * (1.0 / 12.0))) --- > map dbToRms [0,-3,-6,-9,-12]-dbToRms :: Floating a => a -> a-dbToRms db  = 10 ** (db  * 0.05)+-- * UGen --- > map powToDb [1,0.75,0.5,0.25,0]-powToDb :: Floating a => a -> a-powToDb pow = 10 * log10 pow+-- | @UGen.exprand@ shifts a linear (0,1) value to an exponential+-- range.+--+-- > map (floor . exprange 10 100) [0,0.5,1] == [10,31,100]+exprange :: (Floating b) => b -> b -> b -> b+exprange l r i = l * exp (log (r / l) * i) --- > map dbToPow [0,-3,-6,-9,-12]-dbToPow :: Floating a => a -> a-dbToPow db  = 10 ** (db * 0.1)+-- * Binary++-- | @0@ is false, @1@ is True, else error.+--+-- > map bitChar "01" == [False,True]+bitChar :: Char -> Bool+bitChar c =+    case c of+      '0' -> False+      '1' -> True+      _ -> error "bitChar"++-- | Parse a sequence of 0 and 1 characters as a BE bit sequence+--+-- > parseBits "101" == 5+-- > parseBits "00001111" == 15+parseBits :: (Num a,Bits a) => String -> a+parseBits x =+    let x' = filter (id . bitChar . snd) (zip [0..] (reverse x))+    in foldr ((.|.) . bit . fst) 0 x'

@@ -21,8 +21,8 @@  -- | A linear real value map. ----- > w = LinearWarp(ControlSpec(1,2))--- > [0,0.5,1].collect{|n| w.map(n)} == [1,1.5,2]+-- > > w = LinearWarp(ControlSpec(1,2))+-- > > [0,0.5,1].collect{|n| w.map(n)} == [1,1.5,2] -- -- > map (w_map (warpLinear 1 2)) [0,1/2,1] == [1,3/2,2] -- > map (warpLinear (-1) 1 W_Map) [0,1/2,1] == [-1,0,1]@@ -35,8 +35,8 @@  -- | The left and right must both be non zero and have the same sign. ----- > w = ExponentialWarp(ControlSpec(1,2))--- > [0,0.5,1].collect{|n| w.map(n)} == [1,pow(2,0.5),2]+-- > > w = ExponentialWarp(ControlSpec(1,2))+-- > > [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] warpExponential :: (Floating a) => a -> a -> Warp a@@ -48,8 +48,8 @@  -- | Cosine warp ----- > w = CosineWarp(ControlSpec(1,2))--- > [0,0.25,0.5,0.75,1].collect{|n| w.map(n)}+-- > > w = CosineWarp(ControlSpec(1,2))+-- > > [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] warpCosine :: (Floating a) => a -> a -> Warp a@@ -82,8 +82,8 @@ warpDbFader :: (Eq a,Floating a) => Warp a warpDbFader d n =     if d == W_Map-    then if n == 0 then -180 else rmsToDb (n * n)-    else sqrt (dbToRms n)+    then if n == 0 then -180 else ampdb (n * n)+    else sqrt (dbamp n)  -- | A curve warp given by a real /n/. --

@@ -2,7 +2,7 @@ module Sound.SC3.Lang.Math.Window where  import qualified Numeric.GSL.Special.Bessel as M {- hmatrix-special -}-import qualified Numeric.GSL.Special.Trig as M+import qualified Numeric.GSL.Special.Trig as M {- hmatrix-special -}  -- * Type and conversion @@ -69,42 +69,43 @@  -- | 'window_table' . 'gaussian'. ----- > plot [gaussian_table 1024 0.25,gaussian_table 1024 0.5]+-- > import Sound.SC3.Plot+-- > plotTable [gaussian_table 1024 0.25,gaussian_table 1024 0.5] gaussian_table :: (Integral n, Floating b, Enum b) => n -> b -> [b] gaussian_table n = window_table n . gaussian  -- | 'window_table' . 'hamming'. ----- plot [hann 128,hamming 128]+-- plotTable [hann_table 128,hamming_table 128] hamming_table :: Int -> [Double] hamming_table n = window_table n hamming  -- | 'window_table' . 'hann'. ----- plot [hann_table 128]+-- plotTable [hann_table 128] hann_table :: Int -> [Double] hann_table n = window_table n hann  -- | 'window_table' . 'kaiser'. ----- plot [kaiser_table 128 1,kaiser_table 128 2,kaiser_table 128 8]+-- let k = kaiser_table 128 in plotTable [k 1,k 2,k 8] kaiser_table :: Int -> Double -> [Double] kaiser_table n = window_table n . kaiser  -- | 'window_table' . 'lanczos'. ----- plot [lanczos (2^9)]+-- plotTable [lanczos_table (2^9)] lanczos_table :: Integral n => n -> [Double] lanczos_table n = window_table n lanczos  -- | 'window_table' . 'sine'. ----- plot [sine 128]+-- plotTable [sine_table 128] sine_table :: (Integral n, Floating b, Enum b) => n -> [b] sine_table n = window_table n sine  -- | 'window_table' . 'triangular'. ----- plot [triangular (2^9)]+-- plotTable [triangular_table (2^9)] triangular_table :: (Integral n, Fractional b, Enum b) => n -> [b] triangular_table n = window_table n triangular

@@ -0,0 +1,9 @@+-- | Composite module.+module Sound.SC3.Lang.Pattern (module P) where++import Sound.SC3.Lang.Control.Duration as P+import Sound.SC3.Lang.Control.Event as P+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

@@ -1,1118 +1,1960 @@ {-# Language FlexibleInstances #-} -- | @sclang@ pattern library functions. -- See <http://rd.slavepianos.org/?t=hsc3-texts> for tutorial.-module Sound.SC3.Lang.Pattern.ID where--import Control.Applicative hiding ((<*))-import Control.Monad-import qualified Data.Foldable as F-import qualified Data.List as L-import qualified Data.List.Split as S-import Data.Maybe-import Data.Monoid-import Data.Traversable-import Sound.OSC-import Sound.SC3-import qualified Sound.SC3.Lang.Collection as C-import qualified Sound.SC3.Lang.Control.Event as E-import qualified Sound.SC3.Lang.Control.Instrument as I-import qualified Sound.SC3.Lang.Control.Pitch as P-import qualified Sound.SC3.Lang.Math as M-import Sound.SC3.Lang.Pattern.List-import qualified Sound.SC3.Lang.Random.Gen as R-import System.Random---- * P type and instances---- | Pattern continuation mode-data M = Stop-       | Continue-         deriving (Eq,Show)---- | Pattern data type (opaque)-data P a = P {unP :: [a]-             ,stP :: M}-    deriving (Eq,Show)---- | A variant of 'pappend' that preserves the continuation mode but--- is strict in the right argument.-pappend' :: P a -> P a -> P a-pappend' (P xs _) (P ys st) = P (xs ++ ys) st---- | 'Data.Monoid.mappend' variant to sequence two patterns.------ Note that in order for 'Data.Monoid.mappend' to be productive in--- 'Data.Monoid.mconcat' on an infinite list it cannot store the--- right-hand stop/continue mode, see 'pappend''------ > toP [1,2] `pappend` toP [2,3] == toP [1,2,2,3]--- > ptake 3 (prepeat 3 `pappend` prepeat 4) == toP' [3,3,3]--- > ptake 3 (pconcat (cycle [prepeat 3])) == toP' [3,3,3]--- > pempty `pappend` pempty == pempty-pappend :: P a -> P a -> P a-pappend p q = fromList (unP p ++ unP q)--instance Monoid (P a) where-    mappend = pappend-    mempty = P [] Continue---- | A '>>=' variant using the continuation maintaining 'pappend'' function.-(>>=*) ::P a -> (a -> P b) -> P b-m >>=* k = F.foldr (pappend' . k) mempty m--instance Monad P where-    m >>= k = F.foldr (mappend . k) mempty m-    return x = P [x] Continue--instance Functor P where-    fmap f (P xs st) = P (map f xs) st--instance F.Foldable P where-    foldr f i (P xs _) = L.foldr f i xs--instance Applicative P where-    pure x = P [x] Continue-    f <*> e = fmap (\(f',e') -> f' e') (pzip f e)--instance Traversable P where-    traverse f (P xs st) = pure P <*> traverse f xs <*> pure st--instance (Num a) => Num (P a) where-    (+) = pzipWith (+)-    (-) = pzipWith (-)-    (*) = pzipWith (*)-    abs = fmap abs-    signum = fmap signum-    fromInteger = return . fromInteger-    negate = fmap negate--instance (Fractional a) => Fractional (P a) where-    (/) = pzipWith (/)-    recip = fmap recip-    fromRational = return . fromRational--instance (OrdE a) => OrdE (P a) where-    (>*) = pzipWith (>*)-    (>=*) = pzipWith (>=*)-    (<*) = pzipWith (<*)-    (<=*) = pzipWith (<=*)---- | Pseudo-/infinite/ value for use at repeat counts.-inf :: Int-inf = maxBound---- | Constant /NaN/ (not a number) value for use as a rest indicator--- at a frequency model input (not at a @rest@ key).-nan :: (Monad m,Floating a) => m a-nan = return (sqrt (-1))---- * Extension---- | Join a set of 'M' values, if any are 'Stop' then 'Stop' else--- 'Continue'.-stP_join :: [M] -> M-stP_join m = if Stop `elem` m then Stop else Continue---- | Extension of a set of patterns.  If any patterns are stopping,--- the longest such pattern, else the longest of the continuing--- patterns.------ > pextension [toP [1,2],toP [3,4,5]] == [(),(),()]--- > pextension [toP' [1,2],toP [3,4,5]] == [(),()]-pextension :: [P a] -> [()]-pextension x =-    let x' = filter ((== Stop) . stP) x-    in C.extension (map F.toList (if null x' then x else x'))---- | Extend a set of patterns following 'pextension' rule.------ > pextend [toP [1,2],toP [3,4,5]] == [toP' [1,2,1],toP' [3,4,5]]------ > pextend [toP' [1,2],toP [3,4,5]] == [toP' [1,2],toP' [3,4]]-pextend :: [P a] -> [P a]-pextend l =-    let f = pzipWith (\_ x -> x) (P (pextension l) Stop) . pcycle-    in map f l---- | Variant of 'transpose'.------ > ptranspose [toP [1,2],toP [3,4,5]] == toP [[1,3],[2,4],[5]]-ptranspose :: [P a] -> P [a]-ptranspose l =-    let d = L.transpose (map unP l)-        s = stP_join (map stP l)-    in P d s---- | Variant of 'pflop'.------ > pflop' [toP [1,2],toP [3,4,5]] == toP' [[1,3],[2,4],[1,5]]-pflop' :: [P a] -> P [a]-pflop' l =-    let l' = map pcycle l-    in pzipWith (\_ x -> x) (P (pextension l) Stop) (ptranspose l')---- | Variant of 'ptranspose' transforming the input patterns by--- 'pextension'.------ > 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 fromList . pflop'---- | Composition of 'pjoin' and 'pflop'.-pflopJoin :: [P a] -> P a-pflopJoin = pjoin . pflop---- * P lifting---- | Lift unary list function to 'P'.-liftP :: ([a] -> [b]) -> P a -> P b-liftP f (P xs st) = P (f xs) st---- | Lift binary list function to 'P'.-liftP2 :: ([a] -> [b] -> [c]) -> P a -> P b -> P c-liftP2 f p q =-    let P l st = pzip p q-        (a,b) = unzip l-    in P (f a b) st---- | Lift ternary list function to 'P'.-liftP3 :: ([a] -> [b] -> [c] -> [d]) -> P a -> P b -> P c -> P d-liftP3 f p q r =-    let P l st = pzip3 p q r-        (a,b,c) = unzip3 l-    in P (f a b c) st---- | Lift quaternary list function to 'P'.-liftP4 :: ([a] -> [b] -> [c] -> [d] -> [e]) -> P a -> P b -> P c -> P d -> P e-liftP4 f p q r s =-    let P l st = pzip4 p q r s-        (a,b,c,d) = L.unzip4 l-    in P (f a b c d) st---- * P functions---- | Variant of 'null'.-pnull :: P a -> Bool-pnull = null . F.toList---- | Select 'M' according to repeat count, see 'inf'.-stp :: Int -> M-stp n = if n == inf then Continue else Stop---- | Set pattern mode to 'Stop'.-stopping :: P a -> P a-stopping (P xs _) = P xs Stop---- | Set pattern mode according to repeat count, see 'inf'.-stoppingN :: Int -> P a -> P a-stoppingN n (P xs _) = P xs (stp n)---- | Set pattern mode to 'Continue'.-continuing :: P a -> P a-continuing (P xs _) = P xs Continue---- | The basic list to pattern function.  The pattern is continuing.------ > continuing (pseq [1,2,3] 1) == toP [1,2,3]-fromList :: [a] -> P a-fromList xs = P xs Continue---- | Alias for 'fromList'.-toP :: [a] -> P a-toP = fromList---- | A variant from 'fromList' to make stopping patterns.------ > pseq [1,2,3] 1 == toP' [1,2,3]-fromList' :: [a] -> P a-fromList' xs = P xs Stop---- | Alias for 'fromList''.-toP' :: [a] -> P a-toP' = fromList'---- | Pattern variant of 'repeat'. See also 'pure' and 'pcycle'.------ > ptake 5 (prepeat 3) == toP' [3,3,3,3,3]--- > ptake 5 (Control.Applicative.pure 3) == toP' [3]--- > take 5 (Control.Applicative.pure 3) == [3]-prepeat :: a -> P a-prepeat = fromList . repeat---- | Pattern variant of 'zipWith'.  Note that 'zipWith' is truncating,--- whereas the numerical instances are extending.------ > zipWith (*) [1,2,3] [5,6] == [5,12]--- > pzipWith (*) (toP [1,2,3]) (toP [5,6]) == toP [5,12,15]--- > toP [1,2,3] * toP [5,6] == toP [5,12,15]------ Note that the list instance of applicative is combinatorial--- (ie. Monadic).------ > (pure (*) <*> [1,2,3] <*> [5,6]) == [5,6,10,12,15,18]--- > (pure (*) <*> toP [1,2] <*> toP [5]) == toP [5,10]-pzipWith :: (a -> b -> c) -> P a -> P b -> P c-pzipWith f p q =-    let u = void-        x = pextension [u p,u q]-        c = cycle . unP-        l = zipWith3 (\_ i j -> f i j) x (c p) (c q)-    in P l (stP_join [stP p,stP q])---- | Pattern variant of 'zipWith3'.-pzipWith3 :: (a -> b -> c -> d) -> P a -> P b -> P c -> P d-pzipWith3 f p q r =-    let u = void-        x = pextension [u p,u q,u r]-        c = cycle . unP-        z = L.zipWith4 (\_ i j k -> f i j k) x (c p) (c q) (c r)-    in P z (stP_join [stP p,stP q,stP r])---- | Pattern variant of 'zipWith4'.-pzipWith4 :: (a -> b -> c -> d -> e) -> P a -> P b -> P c -> P d -> P e-pzipWith4 f p q r s =-    let u = void-        x = pextension [u p,u q,u r,u s]-        c = cycle . unP-        z = L.zipWith5 (\_ i j k l -> f i j k l) x (c p) (c q) (c r) (c s)-    in P z (stP_join [stP p,stP q,stP r,stP s])---- | Pattern variant of 'zip'.------ > ptake 2 (pzip (prepeat 3) (prepeat 4)) == toP' [(3,4),(3,4)]------ Note that haskell 'zip' is truncating wheras 'pzip' is extending.------ > zip [1 .. 2] [0] == [(1,0)]--- > pzip (toP [1..2]) (toP [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 (,,)---- | Tupling variant of 'pzipWith4'.-pzip4 :: P a -> P b -> P c -> P d -> P (a,b,c,d)-pzip4 = pzipWith4 (,,,)---- | Pattern variant on 'unzip'.-punzip :: P (a,b) -> (P a,P b)-punzip (P p st) = let (i,j) = unzip p in (P i st,P j st)---- * SC3 patterns---- | Add a value to an existing key, or set the key if it doesn't exist.------ > Padd(\freq,801,Pbind(\freq,100)).asStream.next(())--- > padd "freq" 801 (pbind [("freq",100)]) == pbind [("freq",901)]-padd :: E.Key -> P E.Value -> P E.Event -> P E.Event-padd k = pzipWith (\i j -> E.edit_v k 0 (+ i) j)---- | A primitive form of the SC3 'pbind' pattern, with explicit type--- and identifier inputs.-pbind' :: [E.Type] -> [Maybe Int] -> [Maybe I.Instrument] -> [(E.Key,P E.Value)] -> P E.Event-pbind' ty is ss xs =-    let xs' =  pflop' (fmap (\(k,v) -> pzip (return k) v) xs)-        p = fromList-    in pure E.from_list <*> p ty <*> p is <*> p ss <*> xs'---- | SC3 pattern to assign keys to a set of value patterns making an--- 'E.Event' pattern. A finite binding stops the 'E.Event' pattern.------ > Pbind(\x,Pseq([1,2,3]),--- >       \y,Prand([100,300,200],inf)).asStream.nextN(3,())------ > pkey "x" (pbind [("x",prand 'α' [100,300,200] inf)--- >                 ,("y",pseq [1,2,3] 1)]) == toP' [200,200,300]-pbind :: [(E.Key,P E.Value)] -> P E.Event-pbind =-    let ty = repeat E.E_s_new-        i = repeat Nothing-        s = repeat Nothing-    in pbind' ty i s---- | A variant of 'pbrown' where the l, r and s inputs are patterns.------ > 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 (brown' e) in ptake n (f l r s)---- | SC3 pattern to generate psuedo-brownian motion.------ > pbrown 'α' 0 9 1 5 == toP' [4,4,5,4,3]-pbrown :: (Enum e,Random n,Num n,Ord n) => e -> n -> n -> n -> Int -> P n-pbrown e l r s n = ptake n (fromList (brown e l r s))---- | SC3 sample and hold pattern.  For true values in the control--- pattern, step the value pattern, else hold the previous value.------ > Pclutch(Pser([1,2,3,4,5],8),--- >         Pseq([1,0,1,0,0,0,1,1],inf)).asStream.all------ > let {c = pbool (pseq [1,0,1,0,0,1,1] 1)--- >     ;r = toP' [1,1,2,2,2,3,4,5,5,1,1,1,2,3]}--- > in pclutch (pser [1,2,3,4,5] 8) c == r------ 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-pclutch :: P a -> P Bool -> P a-pclutch p q =-    let r = fmap (+ 1) (pcountpost q)-    in pstutter r p---- | SC3 name for 'fmap', ie. patterns are functors.------ > Pcollect({arg i;i * 3},Pseq(#[1,2,3],inf)).asStream.nextN(9)--- > pcollect (* 3) (toP [1,2,3]) == toP [3,6,9]------ > Pseq(#[1,2,3],3).collect({arg i;i * 3}).asStream.nextN(9)--- > fmap (* 3) (toP [1,2,3]) == toP [3,6,9]-pcollect :: (a -> b) -> P a -> P b-pcollect = fmap---- | 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.------ > Pconst(10,Prand([1,2,0.5,0.1],inf),0.001).asStream.nextN(15,())------ > let p = pconst 10 (prand 'α' [1,2,0.5,0.1] inf) 0.001--- > in (p,Data.Foldable.sum 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 stopping (fromList (f 0 (unP p)))---- | 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 = return [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 (return 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) (return 12) == toP' r------ This is the pattern variant of 'P.degree_to_key'.------ > let s = [0,2,4,5,7,9,11]--- > in map (P.degree_to_key s 12) [0,2,4,7,4,2,0] == [0,4,7,12,7,4,0]-pdegreeToKey :: (RealFrac a) => P a -> P [a] -> P a -> P a-pdegreeToKey = pzipWith3 (\i j k -> P.degree_to_key j k i)---- | SC3 pattern to calculate adjacent element difference.------ > pdiff (toP [0,2,3,5,6,8,9]) == toP [-2,-1,-2,-1,-2,-1,7]-pdiff :: Num n => P n -> P n-pdiff p = p - ptail p---- | SC3 pattern to partition a value into /n/ equal subdivisions.--- Subdivides each duration by each stutter and yields that value--- stutter times.  A stutter of @0@ will skip the duration value, a--- stutter of @1@ yields the duration value unaffected.------ > 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],inf);--- > PdurStutter(s,d).asStream.nextN(24)------ > 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] inf}--- > in ptake 24 (pdurStutter s d)-pdurStutter :: Fractional a => P Int -> P a -> P a-pdurStutter = liftP2 durStutter---- | Edit 'E.Value' at 'E.Key' in each element of an 'E.Event' pattern.-pedit :: E.Key -> (E.Value -> E.Value) -> P E.Event -> P E.Event-pedit k f = fmap (E.edit k f)---- | An SC3 pattern of random values that follow a exponential--- distribution.------ > Pexprand(0.0001,1,10).asStream.all--- > pexprand 'α' 0.0001 1 10-pexprand :: (Enum e,Random a,Floating a) => e -> a -> a -> Int -> P a-pexprand e l r n = fmap (M.exprandrng l r) (pwhite e 0 1 n)---- | SC3 pattern to take the first n elements of the pattern.  See--- also 'ptake'.------ > Pfinval(5,Pseq(#[1,2,3],inf)).asStream.nextN(5)--- > pfinval 5 (pseq [1,2,3] inf) == toP' [1,2,3,1,2]-pfinval :: Int -> P a -> P a-pfinval = ptake---- | SC3 pattern to fold values to lie within range (as opposed to--- wrap and clip).  This is /not/ related to the 'Data.Foldable'--- pattern instance.------ > pfold (toP [10,11,12,-6,-7,-8]) (-7) 11 == toP [10,11,10,-6,-7,-6]------ The underlying primitive is the 'fold_' function.------ > let f n = fold_ n (-7) 11--- > in map f [10,11,12,-6,-7,-8] == [10,11,10,-6,-7,-6]-pfold :: (RealFrac n) => P n -> n -> n -> P n-pfold p i j = fmap (\n -> fold_ n i j) p---- | Underlying form of haskell 'pfuncn' pattern.-pfuncn' :: (RandomGen g) => g -> (g -> (n,g)) -> Int -> P n-pfuncn' g_ f n =-  let go [] _ = []-      go (h:hs) g = let (r,g') = h g in r : go hs g'-  in P (go (replicate n f) g_) (stp n)---- | A variant of the SC3 pattern that evaluates a closure at each--- step.  The haskell variant function has a 'StdGen' form.-pfuncn :: (Enum e) => e -> (StdGen -> (n,StdGen)) -> Int -> P n-pfuncn e = pfuncn' (mkStdGen (fromEnum e))---- | SC3 geometric series pattern.------ > Pgeom(3,6,5).asStream.nextN(5)--- > pgeom 3 6 5 == toP' [3,18,108,648,3888]--- > pgeom 1 2 10 == toP' [1,2,4,8,16,32,64,128,256,512]------ Real numbers work as well.------ > pgeom 1.0 1.1 6-pgeom :: (Num a) => a -> a -> Int -> P a-pgeom i s n = P (C.geom n i s) Stop---- | SC3 pattern-based conditional expression.------ > var a = Pfunc({0.3.coin});--- > var b = Pwhite(0,9,in);--- > var c = Pwhite(10,19,inf);--- > Pif(a,b,c).asStream.nextN(9)------ > let {a = fmap (< 0.3) (pwhite 'α' 0.0 1.0 inf)--- >     ;b = pwhite 'β' 0 9 inf--- >     ;c = pwhite 'γ' 10 19 inf}--- > in ptake 9 (pif a b c) == toP' [11,3,6,11,11,15,17,4,7]-pif :: P Bool -> P a -> P a -> P a-pif = liftP3 ifExtending---- | Pattern to assign 'I.Instrument's to 'E.Event's.  An--- 'I.Instrument' is either a 'Synthdef' or a 'String'.  In the--- 'Synthdef' case the instrument is asynchronously sent to the server--- before processing the event, which has timing implications.  In--- general the instrument pattern ought to have a 'Synthdef' for the--- first occurence of the instrument, and a 'String' for subsequent--- occurences.-pinstr :: P I.Instrument -> P E.Event -> P E.Event-pinstr = pzipWith (\i e -> e {E.e_instrument = Just i})---- | Variant of 'pinstr' which lifts the 'String' pattern to an--- 'I.Instrument' pattern.-pinstr_s :: P (String,Bool) -> P E.Event -> P E.Event-pinstr_s p = pinstr (fmap (uncurry I.InstrumentName) p)---- | Variant of 'pinstr' which lifts the 'Synthdef' pattern to an--- 'I.Instrument' pattern.-pinstr_d :: P (Synthdef,Bool) -> P E.Event -> P E.Event-pinstr_d p = pinstr (fmap (uncurry I.InstrumentDef) p)---- | Pattern to extract 'E.Value's at 'E.Key' from an 'E.Event'--- pattern.------ > pkey_m "freq" (pbind [("freq",440)]) == toP' [Just 440]-pkey_m :: E.Key -> P E.Event -> P (Maybe E.Value)-pkey_m k = fmap (E.lookup_m k)---- | SC3 pattern to read 'E.Value' of 'E.Key' at 'E.Event' pattern.--- Note however that in haskell is usually more appropriate to name--- the pattern using /let/.------ > pkey "freq" (pbind [("freq",440)]) == toP' [440]--- > pkey "amp" (pbind [("amp",toP [0,1])]) == toP' [0,1]-pkey :: E.Key -> P E.Event -> P E.Value-pkey k = fmap (fromJust . E.lookup_m k)---- | SC3 interlaced embedding of subarrays.------ > Place([0,[1,2],[3,4,5]],3).asStream.all--- > 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.nextN(6)--- > place [[1],[2,5],[3,6]] 2 == toP' [1,2,3,1,5,6]--- > 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 i = length a-        f = if n == inf then id else take (n * i)-    in stoppingN n (fromList (f (L.concat (C.flop a))))---- | SC3 pattern that is a variant of 'pbind' for controlling--- monophonic (persistent) synthesiser nodes.-pmono :: I.Instrument -> Int -> [(E.Key,P E.Value)] -> P E.Event-pmono i k =-    let i' = case i of-               I.InstrumentDef d sr ->-                   let nm = synthdefName d-                   in i : repeat (I.InstrumentName nm sr)-               I.InstrumentName _ _ -> repeat i-        ty = E.E_s_new : repeat E.E_n_set-    in pbind' ty (repeat (Just k)) (map Just i')---- | Variant of 'pmono' that lifts 'Synthdef' to 'I.Instrument'.-pmono_d :: Synthdef -> Int -> [(E.Key,P E.Value)] -> P E.Event-pmono_d = pmono . flip I.InstrumentDef False---- | Variant of 'pmono' that lifts 'String' to 'I.Instrument'.-pmono_s :: String -> Int -> [(E.Key,P E.Value)] -> P E.Event-pmono_s = pmono . flip I.InstrumentName False---- | Idiom to scale 'E.Value' at 'E.Key' in an 'E.Event' pattern.-pmul :: E.Key -> P E.Value -> P E.Event -> P E.Event-pmul k = pzipWith (\i j -> E.edit_v k 1 (* i) j)---- | Variant that does not insert key.-pmul' :: E.Key -> P E.Value -> P E.Event -> P E.Event-pmul' k = pzipWith (\i j -> E.edit k (* i) j)---- | SC3 pattern to lace input patterns.  Note that the current--- implementation stops late, it cycles the second series one place.------ > ppatlace [1,prand 'α' [2,3] inf] 5 == toP' [1,3,1,2,1,3,1,2,1,2]-ppatlace :: [P a] -> Int -> P a-ppatlace a n =-    let i = length a-        f = if n == inf then id else take (n * i)-    in stoppingN n (P (f (L.concat (C.flop (map unP a)))) Continue)---- | SC3 pattern to repeats 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 = flip pconcatReplicate---- | Pattern variant of 'C.normalizeSum'.-pnormalizeSum :: Fractional n => P n -> P n-pnormalizeSum = liftP C.normalizeSum---- | Un-joined variant of 'prand'.-prand' :: Enum e => e -> [P a] -> Int -> P (P a)-prand' e a n = P (rand' e a n) (stp n)---- | SC3 pattern to make n random selections from a list of patterns,--- the resulting pattern is flattened (joined).------ > Prand([1,Pseq([10,20,30]),2,3,4,5],6).asStream.all--- > prand 'α' [1,toP [10,20],2,3,4,5] 4 == toP' [5,2,10,20,2]-prand :: Enum e => e -> [P a] -> Int -> P a-prand e a = pjoin' . prand' e a---- | 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]------ > Pwhite(0,255,20).reject({|x| x.odd}).asStream.all--- > preject odd (pwhite 'α' 0 255 10) == toP [32,158,62,216,240,20]------ > Pwhite(0,255,20).select({|x| x.odd}).asStream.all--- > pselect odd (pwhite 'α' 0 255 10) == toP [241,187,119,127]-preject :: (a -> Bool) -> P a -> P a-preject f = liftP (filter (not . f))---- | Underlying pattern for 'prorate'.-prorate' :: Num a => Either a [a] -> a -> P a-prorate' p =-    case p of-      Left p' -> fromList . rorate_n' p'-      Right p' -> fromList . rorate_l' p'---- | SC3 sub-dividing pattern.------ > Prorate(Pseq([0.35,0.5,0.8]),1).asStream.nextN(6)--- > prorate (fmap Left (pseq [0.35,0.5,0.8] 1)) 1------ > Prorate(Pseq([0.35,0.5,0.8]),Prand([20,1],inf)).asStream.nextN(6)--- > prorate (fmap Left (pseq [0.35,0.5,0.8] 1)) (prand 'α' [20,1] 3)------ > var l = [[1,2],[5,7],[4,8,9]]).collect(_.normalizeSum);--- > Prorate(Pseq(l,1).asStream.nextN(8)------ > let l = map (Right . C.normalizeSum) [[1,2],[5,7],[4,8,9]]--- > in prorate (toP l) 1-prorate :: Num a => P (Either a [a]) -> P a -> P a-prorate p = join . pzipWith prorate' p---- | 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)---- | 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]-pseq1 :: [P a] -> Int -> P a-pseq1 a i = pjoin' (ptake i (pflop a))---- | 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 1000000 (pseq [1,2,3] inf)) == toP' [2,3,1]-pseq :: [P a] -> Int -> P a-pseq a i = stoppingN i (pn (pconcat a) i)---- | A variant of 'pseq' that passes a new seed at each invocation,--- see also 'pfuncn'.-pseqr :: (Int -> [P a]) -> Int -> P a-pseqr f n = pconcat (L.concatMap f [1 .. n])---- | 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------ 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--- > pseqn [2,1] [8,pwhite 'α' 9 16 inf] 5-pseqn :: [Int] -> [P a] -> Int -> P a-pseqn n q =-    let go _ 0 = pempty-        go p c = let (i,j) = unzip (zipWith psplitAt n p)-                 in pconcat i `pappend` go j (c - 1)-    in go (map pcycle q)---- | 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 (pflopJoin a)---- | 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 (pconcat a))---- | 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,1.2,1.4]-pseries :: (Num a) => a -> a -> Int -> P a-pseries i s n = P (C.series n i s) (stp n)---- | 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]-pshuf :: Enum e => e -> [a] -> Int -> P a-pshuf e a =-    let (a',_) = R.scramble a (mkStdGen (fromEnum e))-    in pn (P a' Continue)----- | SC3 pattern to slide over a list of values.------ > 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]-pslide :: [a] -> Int -> Int -> Int -> Int -> Bool -> P a-pslide a n j s i = stoppingN n . fromList . slide a n j s i---- | Pattern variant of 'splitAt'.-psplitAt :: Int -> P a -> (P a,P a)-psplitAt n (P p st) = let (i,j) = splitAt n p in (P i st,P j st)---- | Pattern variant of 'S.splitPlaces'.-psplitPlaces' :: P Int -> P a -> P [a]-psplitPlaces' = liftP2 S.splitPlaces---- | A variant of 'psplitPlaces'' that joins the output pattern.-psplitPlaces :: P Int -> P a -> P (P a)-psplitPlaces n = fmap fromList . psplitPlaces' n---- | SC3 pattern to do time stretching.  It is equal to 'pmul' at--- \"stretch\".-pstretch :: P E.Value -> P E.Event -> P E.Event-pstretch = pmul "stretch"---- | SC3 pattern to repeat each element of a pattern _n_ times.------ > pstutter 2 (toP [1,2,3]) == 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 :: P Int -> P a -> P a-pstutter = liftP2 stutterExtending---- | SC3 pattern to select elements from a list of patterns by a--- pattern of indices.------ > switch l i = i >>= (l !!)--- > pswitch [pseq [1,2,3] 2,pseq [65,76] 1,800] (toP [2,2,0,1])-pswitch :: [P a] -> P Int -> P a-pswitch l = liftP (switch (map unP l))---- | SC3 pattern that uses a pattern of indices to select which--- pattern to retrieve the next value from.  Only one value is--- selected from each pattern.  This is in comparison to 'pswitch',--- which embeds the pattern in its entirety.------ > Pswitch1([Pseq([1,2,3],inf),--- >          Pseq([65,76],inf),--- >          8],--- >         Pseq([2,2,0,1],6)).asStream.all------ > pswitch1 [pseq [1,2,3] inf,pseq [65,76] inf,8] (pseq [2,2,0,1] 6)-pswitch1 :: [P a] -> P Int -> P a-pswitch1 l = liftP (switch1 (map unP l))---- | SC3 pattern to combine a list of streams to a stream of lists.--- See also `pflop`.------ > Ptuple([Pseries(7,-1,8),--- >        Pseq([9,7,7,7,4,4,2,2],1),--- >        Pseq([4,4,4,2,2,0,0,-3],1)],1).asStream.nextN(8)------ > ptuple [pseries 7 (-1) 8--- >        ,pseq [9,7,7,7,4,4,2,2] 1--- >        ,pseq [4,4,4,2,2,0,0,-3] 1] 1-ptuple :: [P a] -> Int -> P [a]-ptuple p = pseq [pflop' p]---- | A variant of 'pwhite' where the range inputs are patterns.-pwhite' :: (Enum e,Random n) => e -> P n -> P n -> P n-pwhite' e = liftP2 (white' e)---- | SC3 pattern to generate a uniform linear distribution in given range.------ > pwhite 'α' 0 9 5 == toP [3,0,1,6,6]------ It is important to note that this structure is not actually--- indeterminate, so that the below is zero.------ > let p = pwhite 'α' 0.0 1.0 3 in p - p == toP [0,0,0]-pwhite :: (Random n,Enum e) => e -> n -> n -> Int -> P n-pwhite e l r = fromList . white e l r---- | A variant of 'pwhite' that generates integral (rounded) values.-pwhitei :: (RealFrac n,Random n,Enum e) => e -> n -> n -> Int -> P n-pwhitei e l r = fmap roundf . pwhite e l r---- | 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.------ > let w = C.normalizeSum [1,3,5]--- > in pwrand 'α' [1,2,3] w 6 == toP [3,1,2,3,3,3]------ Pwrand.new([1,2,Pseq([3,4],1)],[1,3,5].normalizeSum,6).asStream.nextN(6)------ > let w = C.normalizeSum [1,3,5]--- > in pwrand 'α' [1,2,pseq [3,4] 1] w 6 == toP [3,4,1,2,3,4]-pwrand :: Enum e => e -> [P a] -> [Double] -> Int -> P a-pwrand e a w n = P (wrand e (map unP a) w n) Continue---- | SC3 pattern to constrain the range of output values by wrapping.--- See also 'pfold'.------ > Pn(Pwrap(Pgeom(200,1.07,26),200,1000.0),inf).asStream.nextN(26)--- > pwrap (pgeom 200 1.07 26) 200 1000-pwrap :: (Ord a,Num a) => P a -> a -> a -> P a-pwrap xs l r = fmap (genericWrap l r) xs---- | SC3 pattern that is like 'prand' but filters successive duplicates.------ > pxrand 'α' [1,toP [2,3],toP [4,5,6]] 15-pxrand :: Enum e => e -> [P a] -> Int -> P a-pxrand e a n = P (xrand e (map unP a) n) Continue---- * Monoid aliases---- | 'pconcat' is 'Data.Monoid.mconcat'.  See also 'pjoin'.------ > take 3 (concat (replicate maxBound [1,2])) == [1,2,1]--- > ptake 3 (pconcat (cycle [toP [1,2]])) == toP' [1,2,1]--- > ptake 3 (pconcat [pseq [1,2] 1,pseq [3,4] 1]) == toP' [1,2,3]-pconcat :: [P a] -> P a-pconcat = mconcat---- | Pattern variant for `Data.Monoid.mempty`, ie. the empty pattern.------ > pempty `pappend` pempty == pempty--- > pempty `pappend` 1 == 1 `pappend` pempty-pempty :: P a-pempty = mempty---- * Monad aliases---- | `Control.Monad.join` pattern variant.  See also `pconcat`.------ > take 3 (Control.Monad.join (replicate maxBound [1,2])) == [1,2,1]--- > ptake 3 (pjoin (preplicate inf (toP [1,2]))) == toP' [1,2,1]-pjoin :: P (P a) -> P a-pjoin = join---- | Variant that maintains the continuing mode of the outer structure.-pjoin' :: P (P a) -> P a-pjoin' x = (join x) {stP = stP x}---- * Data.List functions---- | Pattern variant of ':'.------ > pcons 'α' (pn (return 'β') 2) == fromList' "αββ"-pcons :: a -> P a -> P a-pcons i (P j st) = P (i:j) st---- | Pattern variant of `cycle`.------ > ptake 5 (pcycle (toP [1,2,3])) == toP' [1,2,3,1,2]--- > ptake 5 (pseq [1,2,3] inf) == toP' [1,2,3,1,2]-pcycle :: P a -> P a-pcycle = continuing . liftP cycle---- | Pattern variant of `drop`.------ > Pseries(1,1,20).drop(5).asStream.nextN(15)------ > pdrop 5 (pseries 1 1 10) == toP' [6,7,8,9,10]--- > pdrop 1 pempty == pempty-pdrop :: Int -> P a -> P a-pdrop n = liftP (drop n)---- | Pattern variant of `filter`.  Allows values for which the--- predicate is true.  Aliased to `pselect`.  See also `preject`.------ > pfilter (< 3) (pseq [1,2,3] 2) == toP' [1,2,1,2]-pfilter :: (a -> Bool) -> P a -> P a-pfilter f = liftP (filter f)---- | 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 = fromList . replicate n---- | Pattern variant of `scanl`.  `scanl` is similar to `foldl`, but--- returns a list of successive reduced values from the left.------ > Data.Foldable.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]-pscanl :: (a -> b -> a) -> a -> P b -> P a-pscanl f i = liftP (L.scanl f i)---- | Variant of 'drop', note that 'tail' is partial------ > ptail (toP [1,2]) == toP [2]--- > ptail pempty == pempty-ptail :: P a -> P a-ptail = pdrop 1---- | Pattern variant of 'take', 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 = stoppingN n . liftP (take n)---- * Non-SC3 patterns---- | Transforms a numerical pattern into a boolean pattern where--- values greater than zero are 'True' and zero and negative values--- 'False'.------ > pbool (toP [2,1,0,-1]) == toP [True,True,False,False]-pbool :: (Ord a,Num a) => P a -> P Bool-pbool = fmap (> 0)---- | 'pconcat' '.' 'replicate', stopping after /n/ elements.-pconcatReplicate :: Int -> P a -> P a-pconcatReplicate i = stoppingN i . pconcat . replicate i---- | Count the number of `False` values following each `True` value.------ > pcountpost (pbool (pseq [1,0,1,0,0,0,1,1] 1)) == toP' [1,3,0,0]-pcountpost :: P Bool -> P Int-pcountpost = liftP countpost---- | Count the number of `False` values preceding each `True` value.------ > pcountpre (pbool (pseq [0,0,1,0,0,0,1,1] 1)) == toP' [2,3,0]-pcountpre :: P Bool -> P Int-pcountpre = liftP countpre---- | Interleave elements from two patterns.  If one pattern ends the--- other pattern continues until it also ends.------ > let {p = pseq [1,2,3] 2--- >     ;q = pseq [4,5,6,7] 1}--- > in pinterleave p q == toP' [1,4,2,5,3,6,1,7,2,4,3,5]------ > ptake 5 (pinterleave (pcycle 1) (pcycle 2)) == toP' [1,2,1,2,1]--- > ptake 10 (pinterleave (pwhite 'α' 1 9 inf) (pseries 10 1 5))-pinterleave :: P a -> P a -> P a-pinterleave = liftP2 interleave---- | Pattern to remove successive duplicates.------ > 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 rsd---- | 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--- x.  False values at 'tr' generate `Nothing` values.------ > let {tr = pbool (toP [0,1,0,0,1,1])--- >     ;r = [Nothing,Just 1,Nothing,Nothing,Just 2,Just 3]}--- > in ptrigger tr (toP [1,2,3]) == fromList r-ptrigger :: P Bool -> P a -> P (Maybe a)-ptrigger p q =-    let r = pcountpre p-        f i x = preplicate i Nothing `pappend` return (Just x)-    in pjoin (pzipWith f r q)---- * Parallel patterns---- | Merge two 'E.Event' patterns with indicated start 'E.Time's.-ptmerge :: (E.Time,P E.Event) -> (E.Time,P E.Event) -> P E.Event-ptmerge (pt,p) (qt,q) =-    fromList (E.merge (pt,F.toList p) (qt,F.toList q))---- | Variant of 'ptmerge' with zero start times.-pmerge :: P E.Event -> P E.Event -> P E.Event-pmerge p q = ptmerge (0,p) (0,q)---- | Merge a set of 'E.Event' patterns each with indicated start 'E.Time'.-ptpar :: [(E.Time,P E.Event)] -> P E.Event-ptpar l =-    case l of-      [] -> pempty-      [(_,p)] -> p-      (pt,p):(qt,q):r -> ptpar ((min pt qt,ptmerge (pt,p) (qt,q)) : r)---- | Variant of 'ptpar' with zero start times.-ppar :: [P E.Event] -> P E.Event-ppar l = ptpar (zip (repeat 0) l)---- * Pattern audition---- | Send 'E.Event' to @scsynth@ at 'Transport'.-e_send :: Transport m => E.Time -> Int -> E.Event -> m ()-e_send t j e =-    let voidM a = a >> return ()-    in case E.to_sc3_bundle t j e of-        Just (p,q) -> do case E.instrument_def e of-                           Just d -> voidM (async (d_recv d))-                           Nothing -> return ()-                         sendBundle p-                         sendBundle q-        Nothing -> return ()---- | Function to audition a sequence of 'E.Event's using the @scsynth@--- instance at 'Transport' starting at indicated 'E.Time'.-e_tplay :: (Transport m) => E.Time -> [Int] -> [E.Event] -> m ()-e_tplay t j e =-    case (j,e) of-      (_,[]) -> return ()-      ([],_) -> error "e_tplay: no-id"-      (i:j',d:e') -> do let t' = t + E.fwd d-                        e_send t i d-                        pauseThreadUntil t'-                        e_tplay t' j' e'---- | Variant of 'e_tplay' with current clock time from 'time' as start--- time.  This function is used to implement the pattern instances of--- 'Audible'.-e_play :: (Transport m) => [Int] -> [E.Event] -> m ()-e_play lj le = do-  st <- time-  e_tplay st lj le--instance Audible (P E.Event) where-    play = e_play [1000..] . unP--instance Audible (Synthdef,P E.Event) where-    play (s,p) = do-      let i_d = I.InstrumentDef s True-          i_nm = I.InstrumentName (synthdefName s) True-          i = pcons i_d (pn (return i_nm) inf)-      _ <- async (d_recv s)-      e_play [1000..] (unP (pinstr i p))--instance Audible (String,P E.Event) where-    play (s,p) =-        let i = I.InstrumentName s True-        in e_play [1000..] (unP (pinstr (return i) p))-+--+-- 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

@@ -1,75 +1,306 @@ -- | List variants of @SC3@ pattern functions. module Sound.SC3.Lang.Pattern.List where -import qualified Data.Map as M-import Data.Maybe-import Data.List-import qualified Sound.SC3 as S+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 System.Random -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')+-- * Data.Bool variants -brown' :: (Enum e,Random n,Num n,Ord n) => e -> [n] -> [n] -> [n] -> [n]-brown' e l_ r_ s_ =-    let go _ [] = []-        go (n,g) ((l,r,s):z) = let (n',g') = brown_ (l,r,s) (n,g)-                               in n' : go (n',g') z-    in go (randomR (head l_,head r_) (mkStdGen (fromEnum e))) (zip3 l_ r_ s_)+-- | '>' @0@.  Values greater than zero are 'True' and zero and+-- negative values are 'False'.+bool :: (Ord n,Num n) => n -> Bool+bool = (> 0) +-- * Data.Functor variants++-- | 'fmap' of 'bool'.+--+-- > fbool [2,1,0,-1] == [True,True,False,False]+fbool :: (Ord a,Num a,Functor f) => f a -> f Bool+fbool = fmap (> 0)++-- | SC3 pattern to fold values to lie within range (as opposed to+-- wrap and clip).  This is /not/ related to "Data.Foldable".+--+-- > ffold [10,11,12,-6,-7,-8] (-7) 11 == [10,11,10,-6,-7,-6]+--+-- The underlying primitive is the 'S.fold_' function.+--+-- > let f n = S.fold_ n (-7) 11+-- > in map f [10,11,12,-6,-7,-8] == [10,11,10,-6,-7,-6]+ffold :: (Functor f,Num a,Ord a) => f a -> a -> a -> f a+ffold p i j = fmap (\n -> S.fold_ n i j) p++-- | SC3 pattern to constrain the range of output values by wrapping,+-- the primitive is 'S.genericWrap'.+--+-- > let p = fmap round (fwrap (geom 200 1.2 10) 200 1000)+-- > in p == [200,240,288,346,415,498,597,717,860,231]+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.+--+-- > countpost (map bool [1,0,1,0,0,0,1,1]) == [1,3,0,0]+countpost :: [Bool] -> [Int]+countpost =+    let f i p = if null p+                then [i]+                else let (x:xs) = p+                         r = i : f 0 xs+                     in if not x then f (i + 1) xs else r+    in tail . f 0++-- | Count the number of `False` values preceding each `True` value.+--+-- > countpre (fbool [0,0,1,0,0,0,1,1]) == [2,3,0]+countpre :: [Bool] -> [Int]+countpre =+    let f i p = if null p+                then if i == 0 then [] else [i]+                else let (x:xs) = p+                         r = i : f 0 xs+                     in if x then r else f (i + 1) xs+    in f 0++-- | Sample and hold initial value.+--+-- > hold [] == []+-- > hold [1..5] == [1,1,1,1,1]+-- > hold [1,undefined] == [1,1]+hold :: [a] -> [a]+hold l =+    case l of+      [] -> []+      e:_ -> map (const e) l++-- | Interleave elements from two lists.  If one list ends the other+-- continues until it also ends.+--+-- > interleave2 [1,2,3,1,2,3] [4,5,6,7] == [1,4,2,5,3,6,1,7,2,3]+-- > [1..9] `isPrefixOf` interleave2 [1,3..] [2,4..]+interleave2 :: [a] -> [a] -> [a]+interleave2 p q =+    case (p,q) of+      ([],_) -> q+      (_,[]) -> p+      (x:xs,y:ys) -> x : y : interleave2 xs ys++-- | N-ary variant of 'interleave2', ie. 'concat' of 'transpose'.+--+-- > interleave [whitei 'α' 0 4 3,whitei 'β' 5 9 3] == [3,7,0,8,1,6]+-- > [1..9] `isPrefixOf` interleave [[1,4..],[2,5..],[3,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+-- x.  False values at 'tr' generate `Nothing` values.+--+-- > let l = trigger (map toEnum [0,1,0,0,1,1]) [1,2,3]+-- > in l == [Nothing,Just 1,Nothing,Nothing,Just 2,Just 3]+trigger :: [Bool] -> [a] -> [Maybe a]+trigger p q =+    let r = countpre p+        f i x = replicate i Nothing ++ [Just x]+    in concat (C.zipWith_c f r q)++-- * SC3 Patterns++-- | Pbrown.  SC3 pattern to generate psuedo-brownian motion.+--+-- > [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) +-- | PdurStutter.  SC3 pattern to partition a value into /n/ equal+-- subdivisions.  Subdivides each duration by each stutter and yields+-- that value stutter times.  A stutter of @0@ will skip the duration+-- value, a stutter of @1@ yields the duration value unaffected.+--+-- > let {s = [1,1,1,1,1,2,2,2,2,2,0,1,3,4,0]+-- >     ;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 =     let f s d = case s of                 0 -> []                 1 -> [d]                 _ -> replicate s (d / fromIntegral s)-    in concat . C.zipWith_c f p+    in concat . zipWith f p -ifF :: Bool -> a -> a -> a-ifF x y z = if x then y else z+-- | 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) -ifF' :: (Bool,a,a) -> a-ifF' (x,y,z) = if x then y else z+-- | Pfuncn.  Variant of the SC3 pattern that evaluates a closure at+-- each step that has a 'StdGen' form.+funcn :: Enum e => e -> (StdGen -> (n,StdGen)) -> Int -> [n]+funcn e = funcn' (mkStdGen (fromEnum e)) -ifTruncating :: [Bool] -> [a] -> [a] -> [a]-ifTruncating  a b c = map ifF' (zip3 a b c)+-- | Pgeom.  'C.geom' with arguments re-ordered.+--+-- > geom 3 6 5 == [3,18,108,648,3888]+geom :: Num a => a -> a -> Int -> [a]+geom i s n = C.geom n i s -ifExtending :: [Bool] -> [a] -> [a] -> [a]-ifExtending a b c = map ifF' (C.zip3_c a b c)+-- | Pif.  Consume values from /q/ or /r/ according to /p/.+--+-- > if_demand [True,False,True] [1,3] [2] == [1,2,3]+if_demand :: [Bool] -> [a] -> [a] -> [a]+if_demand p q r =+    case if_rec (p,q,r) of+      Just (e,(p',q',r')) -> e : if_demand p' q' r'+      Nothing -> [] +-- | Prand.  Random elements of /p/.+--+-- > 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-        f m g = if m == 0-                then []-                else let (i,g') = randomR (0,k) g-                     in (a !! i) : f (m - 1) g'-    in f n (mkStdGen (fromEnum e))--rorate_n' :: Num a => a -> a -> [a]-rorate_n' p i = [i * p,i * (1 - p)]--rorate_n :: Num a => [a] -> [a] -> [a]-rorate_n p = concat . C.zipWith_c rorate_n' p--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 . C.zipWith_c rorate_l' p--segment :: [a] -> Int -> (Int,Int) -> [a]-segment a k (l,r) =-    let i = map (S.genericWrap 0 k) [l .. r]+        i = white e 0 k n     in map (a !!) i +-- | Pseq.  'concat' of 'replicate' of 'concat'.+--+-- > seq' [return 1,[2,3],return 4] 2 == [1,2,3,4,1,2,3,4]+seq' :: [[a]] -> Int -> [a]+seq' l n = concat (replicate n (concat l))++-- | Pslide.  SC3 pattern to slide over a list of values.+--+-- > 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@@ -79,24 +310,135 @@        then concat (take n (map (segment a k) (zip l r)))        else error "slide: non-wrap variant not implemented" -stutterTruncating :: [Int] -> [a] -> [a]-stutterTruncating ns = concat . zipWith replicate ns--stutterExtending :: [Int] -> [a] -> [a]-stutterExtending ns = concat . C.zipWith_c replicate ns+-- | 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 +-- | Pswitch.  SC3 pattern to select elements from a list of patterns+-- by a pattern of indices.+--+-- > let r = switch [[1,2,3,1,2,3],[65,76],[800]] [2,2,0,1]+-- > in r == [800,800,1,2,3,1,2,3,65,76] switch :: [[a]] -> [Int] -> [a] switch l i = i >>= (l !!) +-- | Pswitch1.  SC3 pattern that uses a pattern of indices to select+-- which pattern to retrieve the next value from.  Only one value is+-- selected from each pattern.  This is in comparison to 'switch',+-- which embeds the pattern in its entirety.+--+-- > let p = switch1 [(cycle [1,2,3])+-- >                 ,(cycle [65,76])+-- >                 ,repeat 8] (concat (replicate 6 [2,2,0,1]))+-- > in p == [8,8,1,65,8,8,2,76,8,8,3,65,8,8,1,76,8,8,2,65,8,8,3,76] switch1 :: [[a]] -> [Int] -> [a] switch1 ps =-    let go _ [] = []-        go m (i:is) = case M.lookup i m of+    let rec m l =+            case l of+              [] -> []+              i:l' -> case M.lookup i m of                         Nothing -> []                         Just [] -> []-                        Just (x:xs) -> x : go (M.insert i xs m) is-    in go (M.fromList (zip [0..] (C.extendSequences ps)))+                        Just (x:xs) -> x : rec (M.insert i xs m) l'+    in rec (M.fromList (zip [0..] ps)) +-- | Pwhite.  SC3 pattern to generate a uniform linear distribution in+-- given range.+--+-- > white 'α' 0 9 5 == [3,0,1,6,6]+--+-- It is important to note that this structure is not actually+-- indeterminate, so that the below is zero.+--+-- > 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)))++-- | 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.+--+-- > 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))++-- | Pxrand.  SC3 pattern that is like 'rand' but filters successive+-- duplicates.+--+-- > xrand 'α' [return 1,[2,3],[4,5,6]] 9 == [4,5,6,2,3,4,5,6,1]+xrand :: Enum e => e -> [[a]] -> Int -> [a]+xrand e a n = take_inf n (xrand' e a)++-- * 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 =+    case i of+      (True:p,q:q',r) -> Just (q,(p,q',r))+      (False:p,q,r:r') -> Just (r,(p,q,r'))+      _ -> Nothing++-- | 'zip3' variant.+--+-- > if_zip [True,False,True] [1,3] [2] == [1]+if_zip :: [Bool] -> [a] -> [a] -> [a]+if_zip a b c =+    let f (x,y,z) = if x then y else z+    in map f (zip3 a b c)++-- | Underlying 'funcn'.+funcn' :: (RandomGen g) => g -> (g -> (n,g)) -> Int -> [n]+funcn' g_ f n =+  let rec [] _ = []+      rec h g =+          case h of+            [] -> []+            e:h' -> let (r,g') = e g in r : rec h' g'+  in rec (replicate n f) g_++rorate_n' :: Num a => a -> a -> [a]+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_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++-- | 'white' with pattern inputs.+--+-- > white' 'α' (repeat 0) [9,19,9,19,9,19] == [3,0,1,6,6,15] white' :: (Enum e,Random n) => e -> [n] -> [n] -> [n] white' e l r =     let g = mkStdGen (fromEnum e)@@ -104,63 +446,29 @@         f a b = let (a',b') = randomR b a in (b',a')     in snd (mapAccumL f g n) -white :: (Random n,Enum e) => e -> n -> n -> Int -> [n]-white e l r n = take n (randomRs (l,r) (mkStdGen (fromEnum e)))+-- | Type-specialised ('Integral') 'white'.+--+-- > whitei' 'α' 1 9 5 == [3,9,2,9,4]+whitei' :: (Random n,Integral n,Enum e) => e -> n -> n -> Int -> [n]+whitei' = white -wrand' :: (Enum e) =>e -> [[a]] -> [Double] -> [a]+-- | A variant of 'pwhite' that generates integral (rounded) values.+--+-- > 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 r : f g'     in f (mkStdGen (fromEnum e)) -wrand :: (Enum e) => e -> [[a]] -> [Double] -> Int -> [a]-wrand e a w n = take n (wrand' e a w)-+-- | 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 :: Enum e => e -> [[a]] -> Int -> [a]-xrand e a n = take n (xrand' e a)--countpost :: [Bool] -> [Int]-countpost =-    let f i p = if null p-                then [i]-                else let (x:xs) = p-                         r = i : f 0 xs-                     in if not x then f (i + 1) xs else r-    in tail . f 0--countpre :: [Bool] -> [Int]-countpre =-    let f i p = if null p-                then if i == 0 then [] else [i]-                else let (x:xs) = p-                         r = i : f 0 xs-                     in if x then r else f (i + 1) xs-    in f 0--interleave :: [a] -> [a] -> [a]-interleave p q =-    case (p,q) of-      ([],_) -> q-      (_,[]) -> p-      (x:xs,y:ys) -> x : y : interleave xs ys--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)---- > let tr = map toEnum [0,0,1,0,0,0,1,1]--- > in trigger tr [1,2,3]-trigger :: [Bool] -> [a] -> [Maybe a]-trigger p q =-    let r = countpre p-        f i x = replicate i Nothing ++ [Just x]-    in concat (C.zipWith_c f r q)-

@@ -1,12 +1,13 @@ -- | 'RandomGen' based @sclang@ random number functions. module Sound.SC3.Lang.Random.Gen where -import Data.Maybe-import qualified Sound.SC3.Lang.Collection as C-import qualified Sound.SC3.Lang.Math as M+import Data.Maybe {- base  -} import System.Random {- random -} import System.Random.Shuffle {- random-shuffle -} +import qualified Sound.SC3.Lang.Collection as C+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)@@ -57,7 +58,7 @@ exprand :: (Floating n,Random n,RandomGen g) => n -> n -> g -> (n,g) exprand l r g =     let (n,g') = rrand 0.0 1.0 g-    in (M.exprandrng l r n,g')+    in (M.exprange l r n,g')  -- | Variant of 'exprand' generating /k/ values. nexprand :: (Floating n,Random n,RandomGen g) =>

@@ -1,10 +1,12 @@ -- | 'getStdRandom' based @sclang@ random number functions. module Sound.SC3.Lang.Random.IO where -import Control.Monad.IO.Class-import Sound.SC3.Lang.Random.Gen as R+import Control.Monad.IO.Class {- transformers -} import System.Random {- random -} +import Sound.SC3.Lang.Random.Gen as R++-- | 'liftIO' of 'randomRIO'. randomM :: (Random a, MonadIO m) => (a, a) -> m a randomM = liftIO . randomRIO @@ -16,6 +18,7 @@ rand2 :: (MonadIO m,Random n,Num n) => n -> m n rand2 n = randomM (-n,n) +-- | 'liftIO' of 'getStdRandom'. randomG :: MonadIO m => (StdGen -> (a, StdGen)) -> m a randomG = liftIO . getStdRandom 

@@ -1,36 +1,77 @@--- | Denis Lorrain. \"A Panoply of Stochastic 'Cannons'\". /Computer--- Music Journal/, 4(1):53-81, Spring 1980.+-- | Denis Lorrain.+-- \"A Panoply of Stochastic \'Cannons\'\".+-- /Computer Music Journal/, 4(1):53-81, Spring 1980. module Sound.SC3.Lang.Random.Lorrain_1980 where --- | 4.3.1 (g=1)+-- | §4.3.1 (g=1)+--+-- > import System.Random+-- > let r = take 32768 (randomRs (0.0,1.0) (mkStdGen 12345))+--+-- > import Sound.SC3.Plot+-- > import Sound.SC3.Plot.Histogram+-- > let h = plotHistogram . map (histogram 512)+--+-- > h [map (linear 1.0) r] linear :: Floating a => a -> a -> a linear g u = g * (1 - sqrt u) --- | 4.3.2 (δ=[0.5,1,2])+-- | §4.3.2 (δ=[0.5,1,2])+--+-- > h (map (\d -> map (exponential d) r) [0.5,1,2]) exponential :: Floating a => a -> a -> a exponential delta u = (- (log u)) / delta --- | 4.3.5 (τ=1)+-- | §4.3.5 (τ=1)+--+-- > 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] cauchy :: Floating a => a -> a -> a cauchy tau u = tau * tan (pi * u) --- | 4.3.5 (iopt=False,τ=1) (Algorithm 10)+-- | §4.3.5 (iopt=False,τ=1) (Algorithm 10)+--+-- > h [mapMaybe (narrow 20 . cauchy' False 1.0) r]+-- > h [mapMaybe (narrow 20 . cauchy' True 1.0) r] cauchy' :: Floating a => Bool -> a -> a -> a cauchy' iopt tau u =     let u' = if iopt then u / 2 else u         u'' = pi * u'-    in tau * tan u'' -- tan u'' == sin u'' / cos u''+    in tau * tan u'' -- tan n == sin n / cos n --- | 4.3.6+-- | §4.3.6+--+-- > h [map hyperbolic_cosine r] hyperbolic_cosine :: Floating a => a -> a hyperbolic_cosine u = log (tan (pi * u / 2)) --- | 4.3.7 (β=0,α=1)+-- | §4.3.7 (β=0,α=1)+--+-- > h [map (logistic 0.0 1.0) r] logistic :: Floating a => a -> a -> a -> a-logistic beta alpha u = (- beta - log (recip u - 1)) / alpha+logistic beta' alpha u = (- beta' - log (recip u - 1)) / alpha --- | 4.3.8+-- | §4.3.8+--+-- > h [map arc_sine r] arc_sine :: Floating a => a -> a arc_sine u =     let x = sin (pi * u / 2)     in x * x++-- | §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)]+beta :: (Floating a,Ord a) => a -> a -> (a,a) -> Maybe a+beta a b (u1,u2) =+    let ea = 1.0 / a+        eb = 1.0 / b+        y1 = u1 ** ea+        y2 = u2 ** eb+        s = y1 + y2+    in if s <= 1.0 then Just (y1 / s) else Nothing

@@ -1,8 +1,9 @@ -- | 'Rand' monad based @sclang@ random number functions. module Sound.SC3.Lang.Random.Monad where -import Control.Monad+import Control.Monad {- base -} import Control.Monad.Random {- MonadRandom -}+ import qualified Sound.SC3.Lang.Math as M  -- | @SimpleNumber.rand@ is 'getRandomR' in (0,/n/).@@ -64,7 +65,7 @@ exprand :: (Floating n,Random n,RandomGen g) => n -> n -> Rand g n exprand l r = do   n <- rrand 0.0 1.0-  return (M.exprandrng l r n)+  return (M.exprange l r n)  -- | Variant of 'exprand' generating /k/ values. --

@@ -1,11 +1,11 @@ Name:              hsc3-lang-Version:           0.13+Version:           0.14 Synopsis:          Haskell SuperCollider Language Description:       Haskell library defining operations from the                    SuperCollider language class library License:           GPL Category:          Sound-Copyright:         (c) Rohan Drape, 2007-2012+Copyright:         (c) Rohan Drape, 2007-2013 Author:            Rohan Drape Maintainer:        rd@slavepianos.org Stability:         Experimental@@ -19,14 +19,15 @@ Library   Build-Depends:   array,                    base == 4.*,+                   bifunctors,                    bytestring,                    containers,                    data-default,                    hmatrix-special,-                   hosc == 0.13.*,-                   hsc3 == 0.13.*,+                   hosc == 0.14.*,+                   hsc3 == 0.14.*,                    MonadRandom,-                   mtl,+                   transformers,                    split,                    random,                    random-shuffle,@@ -48,6 +49,7 @@                    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.List                    Sound.SC3.Lang.Random.Lorrain_1980