hsc3-lang 0.9 → 0.11

raw patch · 95 files changed

+3324/−2364 lines, 95 filesdep +MonadRandomdep +data-defaultdep +hoscPVP ok

version bump matches the API change (PVP)

Dependencies added: MonadRandom, data-default, hosc, hsc3, random-shuffle

API changes (from Hackage documentation)

Files

• Help/Collection/collection.help.lhs +0/−87
• Help/Math/pitch.help.lhs +0/−54
• Help/Pattern/List/pappend.help.lhs +0/−20
• Help/Pattern/List/pbool.help.lhs +0/−8
• Help/Pattern/List/pclutch.help.lhs +0/−21
• Help/Pattern/List/pcollect.help.lhs +0/−10
• Help/Pattern/List/pcountpre.help.lhs +0/−12
• Help/Pattern/List/pcycle.help.lhs +0/−11
• Help/Pattern/List/pdegreeToKey.help.lhs +0/−26
• Help/Pattern/List/pdrop.help.lhs +0/−9
• Help/Pattern/List/pempty.help.lhs +0/−9
• Help/Pattern/List/pfilter.help.lhs +0/−9
• Help/Pattern/List/pfin.help.lhs +0/−19
• Help/Pattern/List/pgeom.help.lhs +0/−15
• Help/Pattern/List/phead.help.lhs +0/−12
• Help/Pattern/List/pinterleave.help.lhs +0/−15
• Help/Pattern/List/pn.help.lhs +0/−7
• Help/Pattern/List/prand.help.lhs +0/−25
• Help/Pattern/List/preject.help.lhs +0/−9
• Help/Pattern/List/prepeat.help.lhs +0/−11
• Help/Pattern/List/prsd.help.lhs +0/−10
• Help/Pattern/List/pseq.help.lhs +0/−35
• Help/Pattern/List/pser.help.lhs +0/−13
• Help/Pattern/List/pseries.help.lhs +0/−13
• Help/Pattern/List/pstutter.help.lhs +0/−19
• Help/Pattern/List/pswitch.help.lhs +0/−11
• Help/Pattern/List/pswitch1.help.lhs +0/−18
• Help/Pattern/List/ptail.help.lhs +0/−14
• Help/Pattern/List/ptake.help.lhs +0/−10
• Help/Pattern/List/ptrigger.help.lhs +0/−22
• Help/Pattern/List/pwhite.help.lhs +0/−35
• Help/Pattern/List/pzip.help.lhs +0/−12
• Help/Pattern/Step/pappend.help.lhs +0/−12
• Help/Pattern/Step/pclutch.help.lhs +0/−29
• Help/Pattern/Step/pcollect.help.lhs +0/−9
• Help/Pattern/Step/pcontinue.help.lhs +0/−3
• Help/Pattern/Step/pcountpre.help.lhs +0/−10
• Help/Pattern/Step/pcycle.help.lhs +0/−9
• Help/Pattern/Step/pdegreeToKey.help.lhs +0/−26
• Help/Pattern/Step/pdrop.help.lhs +0/−8
• Help/Pattern/Step/pempty.help.lhs +0/−10
• Help/Pattern/Step/pexprand.help.lhs +0/−13
• Help/Pattern/Step/pfilter.help.lhs +0/−9
• Help/Pattern/Step/pfin.help.lhs +0/−26
• Help/Pattern/Step/pfix.help.lhs +0/−18
• Help/Pattern/Step/pgeom.help.lhs +0/−17
• Help/Pattern/Step/phead.help.lhs +0/−14
• Help/Pattern/Step/pif.help.lhs +0/−34
• Help/Pattern/Step/pinterleave.help.lhs +0/−12
• Help/Pattern/Step/pn.help.lhs +0/−16
• Help/Pattern/Step/ppatlace.help.lhs +0/−30
• Help/Pattern/Step/prand.help.lhs +0/−21
• Help/Pattern/Step/preject.help.lhs +0/−10
• Help/Pattern/Step/prepeat.help.lhs +0/−10
• Help/Pattern/Step/prorate.help.lhs +0/−11
• Help/Pattern/Step/prp.help.lhs +0/−37
• Help/Pattern/Step/prsd.help.lhs +0/−8
• Help/Pattern/Step/pscan.help.lhs +0/−33
• Help/Pattern/Step/pscanl.help.lhs +0/−28
• Help/Pattern/Step/pseq.help.lhs +0/−48
• Help/Pattern/Step/pser.help.lhs +0/−16
• Help/Pattern/Step/pseries.help.lhs +0/−15
• Help/Pattern/Step/pstutter.help.lhs +0/−26
• Help/Pattern/Step/pswitch.help.lhs +0/−11
• Help/Pattern/Step/pswitch1.help.lhs +0/−22
• Help/Pattern/Step/ptail.help.lhs +0/−10
• Help/Pattern/Step/ptake.help.lhs +0/−7
• Help/Pattern/Step/ptrigger.help.lhs +0/−17
• Help/Pattern/Step/pwhite.help.lhs +0/−36
• Help/Pattern/Step/pwrap.help.lhs +0/−17
• Help/Pattern/Step/pxrand.help.lhs +0/−9
• README +2/−2
• Sound/SC3/Lang/Collection.hs +565/−0
• Sound/SC3/Lang/Collection/Collection.hs +0/−56
• Sound/SC3/Lang/Collection/Extension.hs +38/−0
• Sound/SC3/Lang/Collection/Numerical.hs +0/−37
• Sound/SC3/Lang/Collection/Numerical/Extending.hs +49/−0
• Sound/SC3/Lang/Collection/Numerical/Truncating.hs +52/−0
• Sound/SC3/Lang/Collection/SequenceableCollection.hs +0/−156
• Sound/SC3/Lang/Collection/Universal/Datum.hs +225/−0
• Sound/SC3/Lang/Control/Duration.hs +64/−0
• Sound/SC3/Lang/Control/Event.hs +267/−0
• Sound/SC3/Lang/Control/Instrument.hs +23/−0
• Sound/SC3/Lang/Control/OverlapTexture.hs +171/−0
• Sound/SC3/Lang/Control/Pitch.hs +136/−0
• Sound/SC3/Lang/Data/Vowel.hs +198/−0
• Sound/SC3/Lang/Math.hs +57/−0
• Sound/SC3/Lang/Math/Pitch.hs +0/−67
• Sound/SC3/Lang/Pattern/ID.hs +1102/−0
• Sound/SC3/Lang/Pattern/List.hs +126/−295
• Sound/SC3/Lang/Pattern/Step.hs +0/−440
• Sound/SC3/Lang/Random/Gen.hs +102/−0
• Sound/SC3/Lang/Random/IO.hs +49/−0
• Sound/SC3/Lang/Random/Monad.hs +73/−0
• hsc3-lang.cabal +25/−13

@@ -1,87 +0,0 @@-* Lists of numbers are numerical, Extension--Pointwise operations in the supercollider -language extend the shorter input by-cycling.--That is, the expression:--| [1, 2] + [3, 4, 5]--is equivalent to:--| [1, 2, 1] + [3, 4, 5]--and so describes the three element -list [4, 6, 6].--The collection module provides list -instances for the standard haskell -numerical type classes with the same -extension behaviour, so that:--> import Sound.SC3.Lang.Collection.Numerical--> [1, 2] + [3, 4, 5]--has the same value as in the supercollider-language, and as distinct from the value of:--> zipWith (+) [1, 2] [3, 4, 5]--which is the two element list [4, 6].--The function underlying the list numerical -instances is zipWith_c:--> import Sound.SC3.Lang.Collection.SequenceableCollection--> zipWith_c (+) [1, 2] [3, 4, 5]--Since literals are interpreted as single-element lists, the expression:--> [1, 2, 3] * 4--denotes the list [4, 8, 12].--* Sequencable Collection (Sanity Check)--> series 5 1 2 == [1,3..9]--> geom 5 3 6 == [3,18,24,30,36]--> fib 5 1 1 == [1,2,3,5,8]--> first [1..] == Just 1--> first [] == Nothing--> last' [1..5] == Just 5--> last' [] == Nothing--> indexOf [0..] 5 == Just 5--> import Data.List--> indexOf [0..] 5 == elemIndex 5 [0..]--> keep 4 [1..10] == [1..4]--> keep (-4) [1..10] == [7..10]--> keep (-4) [1,2] == [1,2]--> drop' 4 [1..10] == [5..10]--> drop' (-4) [1..10] == [1..6]--> separateAt (<) [3,2,1,2,3,2]--> clump 3 [1..10] == [[1..3],[4..6],[7..9],[10]]--> clumps [1,2,3,4] [1..10] == [[1],[2,3],[4,5,6],[7,8,9,10]]--> clumps [1,2,3] [1..10] == [[1],[2,3],[4,5,6],[7],[8,9],[10]]-

@@ -1,54 +0,0 @@-* Pitch & record--> import Sound.SC3.Lang.Math.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.--The haskell variant implements Pitch as-a labeled data type, with a default value-such that scale degree 5 is the a above-middle c.--> freq (defaultPitch { degree = 5 })--The note is given as a degree, with a modal-transposition, indexing 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 root, octave and-gamut transpositions.--The frequency is derived by a chromatic-transposition of the midinote, with a-harmonic multiplier.--> let { p = defaultPitch->     ; n = p { stepsPerOctave = 12->             , scale = [0, 2, 4, 5, 7, 9, 11]->             , degree = 0->             , mtranspose = 5 }->     ; m = n { root = 0->             , octave = 5->             , gtranspose = 0 }->     ; f = m { ctranspose = 0->             , harmonic = 1 } }-> in (note n, midinote m, freq f)--By editing the values of aspects of-a pitch, processes can cooperate. -Below one process controls the note-by editing the modal transposition,-a second edits the octave.--> 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)

@@ -1,20 +0,0 @@-(++) :: [a] -> [a] -> [a]-pappend :: P a -> P a -> P a--Sequence two patterns.  This is the mappend instance of Monoid.--> import Sound.SC3.Lang.Pattern.List--> let { p = pseq [1, 2] 1->     ; q = pseq [2, 3] 1 }-> in p `pappend` q--> pnull (pempty `pappend` pempty)--> ptake 5 (prepeat 3 `pappend` prepeat 4)--> [1,2]++[2,3]--> null ([] ++ [])--> take 5 (repeat 3 ++ repeat 4)

@@ -1,8 +0,0 @@-bool :: (Functor f, Ord a, Num a) => f a -> f Bool-pbool :: (Ord a, Num a) => P a -> P Bool--> import Sound.SC3.Lang.Pattern.List--> pbool (pseq [1, 0, 1, 0, 0, 0, 1, 1] 1)--> bool [1, 0, 1, 0, 0, 0, 1, 1]

@@ -1,21 +0,0 @@-clutch :: [a] -> [Bool] -> [a]-pclutch :: P a -> P Bool -> P a-- i - input- c - clutch--Sample and hold a pattern.  For true values in the control pattern,-step the value pattern, else hold the previous value.--> import Sound.SC3.Lang.Pattern.List--> let { p = pseq [1, 2, 3, 4, 5] 3->     ; q = pbool (pseq [1, 0, 1, 0, 0, 0, 1, 1] 1) }-> in pclutch p q--Note the initialization behavior, nothing-is generated until the first true value.--> let { p = pseq [1, 2, 3, 4, 5] 3->     ; q = pbool (pseq [0, 0, 0, 1, 0, 0, 1, 0, 1] 1) }-> in pclutch p q

@@ -1,10 +0,0 @@-fmap :: (Functor f) => (a -> b) -> f a -> f b-pcollect :: (a -> b) -> P a -> P b--Patterns are functors.--> import Sound.SC3.Lang.Pattern.List--> pcollect (* 3) (pseq [1, 2, 3] 3)--> fmap (* 3) (pseq [1, 2, 3] 3)

@@ -1,12 +0,0 @@-countpre :: [Bool] -> [Int]-countpost :: [Bool] -> [Int]-pcountpre :: P Bool -> P Int-pcountpost :: P Bool -> P Int--> import Sound.SC3.Lang.Pattern.List--> pcountpre (pbool (pseq [0, 0, 1, 0, 0, 0, 1, 1] 1))-> pcountpost (pbool (pseq [1, 0, 1, 0, 0, 0, 1, 1] 1))--> countpre (bool [0, 0, 1, 0, 0, 0, 1, 1])-> countpost (bool [1, 0, 1, 0, 0, 0, 1, 1])

@@ -1,11 +0,0 @@-cycle :: [a] -> [a]-pcycle :: P a -> P a--pattern variant of Data.List.cycle--> import Sound.SC3.Lang.Pattern.List--> ptake 5 (pcycle (pseq [1,2,3] 1))--> take 5 (cycle [1,2,3]) == [1,2,3,1,2]-

@@ -1,26 +0,0 @@-pdegreeToKey :: (RealFrac a) => P a -> P [a] -> P a -> P a--         degree - scale degree (zero based)-          scale - list of divisions (ie. [0, 2, 4, 5, 7, 9, 11])- stepsPerOctave - division of octave (ie. 12)--Derive notes from an index into a scale.--> import Sound.SC3.Lang.Pattern.List--> let { p = pseq [0, 1, 2, 3, 4, 3, 2, 1, 0, 2, 4, 7, 4, 2] 2->     ; q = prepeat [0, 2, 4, 5, 7, 9, 11]->     ; r = prepeat 12 }-> in pdegreeToKey p q r--> let { p = pseq [0, 1, 2, 3, 4, 3, 2, 1, 0, 2, 4, 7, 4, 2] 2->     ; q = pseq [return [0, 2, 4, 5, 7, 9, 11]->                ,return [0, 2, 3, 5, 7, 8, 11]] 1->     ; r = prepeat 12 }-> in pdegreeToKey p (pstutter 14 q) r--The degree_to_key function is also given.--> import Sound.SC3.Lang.Math--> map (\n -> degree_to_key n [0,2,4,5,7,9,11] 12) [0,2,4,7,4,2,0]

@@ -1,9 +0,0 @@-drop :: Int -> [a] -> [a]-pdrop :: P Int -> P a -> P a--Drop first n element from pattern.--> import Sound.SC3.Lang.Pattern.List--> let p = pseq [1, 2, 3] 4-> in (pdrop 7 p, p)

@@ -1,9 +0,0 @@-pempty :: P a--The empty pattern. (The instance for Monoid mempty.)--> import Sound.SC3.Lang.Pattern.List--> pempty--> pempty `pappend` return 1

@@ -1,9 +0,0 @@-filter :: (a -> Bool) -> [a] -> [a]-pfilter :: (a -> Bool) -> P a -> P a--Allows values for which the predicate is true. --> import Sound.SC3.Lang.Pattern.List--> let p = pseq [1, 2, 3] 3-> in pfilter (< 3) p

@@ -1,19 +0,0 @@-take :: Int -> [a] -> [a]-ptake :: P Int -> P a -> P a--  n - number of elements to take-  x - value pattern--Take only the first n elements of the pattern -into the stream.  pfin = ptake.--> import Sound.SC3.Lang.Pattern.List--> let p = pseq [1, 2, 3] pinf-> in pfin 5 p--Note that pfin does not extend the input pattern,-unlike pser.--> let p = pseq [1, 2, 3] 1-> in (pfin 5 p, pser [p] 5)

@@ -1,15 +0,0 @@-pgeom :: (Num a) => a -> a -> Int -> P a--Geometric series pattern.--  start - start value-   grow - multiplication factor- length - number of values produced--> import Sound.SC3.Lang.Pattern.List--> pgeom 1 2 12--Real numbers work as well.--> pgeom 1.0 1.1 6

@@ -1,12 +0,0 @@-phead :: P a -> Maybe a--Inspect the first element of a pattern.--> import Sound.SC3.Lang.Pattern.List--> phead (pseq [1, 2, 3] 1)--> let p = pseq [1, 2, 3] 1-> in maybe pempty (\x -> x `pcons` ptail p) (phead p)--> phead pempty

@@ -1,15 +0,0 @@-interleave :: [a] -> [a] -> [a]-pinterleave :: P a -> P a -> P a--Interleave elements from two patterns.  If one pattern ends the other-pattern continues until it also ends.--> import Sound.SC3.Lang.Pattern.List--> let { p = pseq [1, 2, 3] 3->     ; q = pseq [4, 5, 6, 7] 2 }-> in pinterleave p q--> ptake 10 (pinterleave (pcycle 1) (pcycle 2))--> ptake 10 (pinterleave (pwhite "x" 1 9) (pseries 10 1 5))

@@ -1,7 +0,0 @@-pn :: P a -> P Int -> P a--Repeats the enclosed pattern a number of times.--> import Sound.SC3.Lang.Pattern.List--> pn (pseq [1, 2, 3] 1) 4

@@ -1,25 +0,0 @@-pchoose :: String -> P a -> P a-prand :: String -> [P a] -> P Int -> P a--Returns one item from a finite pattern at random for each step. --> import Sound.SC3.Lang.List--> let p = pchoose "x" (pseq [1, 2, 3, 4, 5] 1)-> in ptake 5 p--> prand "x" [ pseq [1, 2] 1->           , pseq [3, 4] 1->           , pseq [5, 6] 1 ] 10--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. --> let p = pseq [prand "a" [pempty, pseq [24, 31, 36, 43, 48, 55] 1] 1->              ,pseq [60, prand "b" [63, 65] 1->                    ,67, prand "c" [70, 72, 74] 1] (pwhite "c" 2 5)->              ,prand "d" [74, 75, 77, 79, 81] (pwhite "e" 3 9)] pinf-> in ptake 24 p-

@@ -1,9 +0,0 @@-preject :: (a -> Bool) -> P a -> P a-preject f = pfilter (not . f)--Rejects values for which the predicate is true. --> import Sound.SC3.Lang.Pattern.List--> let p = pseq [1, 2, 3] 3-> in preject (== 1) p

@@ -1,11 +0,0 @@-repeat :: a -> [a]-prepeat :: a -> P a--pattern variant of Data.List.repeat--> import Sound.SC3.Lang.Pattern.List--> ptake 5 (prepeat 3)--> take 5 (repeat 3) == [3,3,3,3,3]-

@@ -1,10 +0,0 @@-rsd :: (Eq a) => [a] -> [a]-prsd :: (Eq a) => P a -> P a--Remove successive duplicates.--> import Sound.SC3.Lang.Pattern.List--> prsd (pseq [1,1,2,2,2,3,3] 1)--> rsd [1,1,2,2,2,3,3] == [1,2,3]

@@ -1,35 +0,0 @@-pseq :: [P a] -> P Int -> P a--Cycle over a list of patterns. The repeats pattern gives-the number of times to repeat the entire list. --> import Sound.SC3.Lang.Pattern.List--> pseq [1, 2, 3] 2--Unlike Pseq, pseq does not have an offset argument to-give a starting offset into the list.--> import Sound.SC3.Lang.Collection--> pseq (rotate 3 [1, 2, 3, 4]) 3--Because the repeat counter is a pattern one can have-a random number of repeats.--> pseq [1, 2] (pwhite "u" 1 9)--For the same reason the pattern is static when re-examined.--> let p = pseq [0, pseq [1] (pwhite "u" 1 3), 2] 5-> in ptake 24 p--Only the first element of the repeat pattern is consulted.--> let p = pseq [1,2] 1-> in pseq [1] p--If one specifies the value pinf for the repeats variable, -then it will repeat indefinitely.--> ptake 9 (pseq [1, 2, 3] pinf)

@@ -1,13 +0,0 @@-pser :: [P a] -> P Int -> P a--pser is like pseq, however the repeats variable -gives the number of elements in the sequence,-not the number of cycles of the pattern.--> import Sound.SC3.Lang.Pattern.List--> pser [1, 2, 3] 5--> pser [1, pser [100, 200] 3, 3] 9--> pser [1, 2, 3] 5 *. 3

@@ -1,13 +0,0 @@-pseries :: (Num a) => a -> a -> Int -> P a--An arithmetric series. --  start - start value-   step - addition factor- length - number of values--> import Sound.SC3.Lang.Pattern.List--> pseries 0 2 24--> pseries 1.0 0.1 24

@@ -1,19 +0,0 @@-stutter :: [Int] -> [a] -> [a]-pstutter :: P Int -> P a -> P a--  count - number of repeats-      x - value pattern--Repeat each element of a pattern n times.--> import Sound.SC3.Lang.Pattern.List--> let p = pstutter (pcycle 2) (pseq [1, 2, 3] pinf)-> in ptake 13 p--> let { p = pseq [1, 2] pinf->     ; q = pseq [1, 2, 3] pinf->     ; r = pstutter p q }-> in ptake 13 r--> stutter [1,2,3] [4,5,6] == [4,5,5,6,6,6]

@@ -1,11 +0,0 @@-pswitch :: [P a] -> P Int -> P a-pswitch l i = i >>= (l !!)--Select elements from a list of patterns by a pattern of indices.--> import Sound.SC3.Lang.Pattern.List--> let { a = pseq [1, 2, 3] 2->     ; b = pseq [65, 76] 1->     ; c = pswitch [a, b, 800] (pseq [2, 2, 0, 1] pinf) }-> in ptake 24 c

@@ -1,18 +0,0 @@-pswitch1 :: [P a] -> P Int -> P a--  list - patterns to index- which - index--The pattern of indices is used select which pattern-to retrieve the next value from.  Only one value -is selected from each the pattern.--This is in comparison to pswitch, which embeds the -pattern in its entirety.  pswitch1 switches every value.--> import Sound.SC3.Lang.Pattern.List--> let { p = pseq [1, 2, 3] pinf->     ; q = pseq [65, 76] pinf->     ; r = pswitch1 [p, q, pn 800 3] (pseq [2, 0, 1] pinf) }-> in ptake 24 r

@@ -1,14 +0,0 @@-tail :: [a] -> [a]-ptail :: P a -> P a--Drop first element from pattern.--> import Sound.SC3.Lang.Pattern.List--> ptail (pseq [1, 2, 3] 1)--> ptail pempty--Note that the haskell tail function is partial.--> tail []

@@ -1,10 +0,0 @@-take :: Int -> [a] -> [a]-ptake :: P Int -> P a -> P a--> import Sound.SC3.Lang.Pattern.List--> ptake 5 (pseq [1,2,3] 5)--> ptake 5 (pseq [1,2,3] 1)--> take 5 [1..] == [1..5]

@@ -1,22 +0,0 @@-trigger :: [Bool] -> [a] -> [Maybe a]-ptrigger :: P Bool -> P a -> P (Maybe a)--  tr - boolean pattern-   x - value pattern--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. --> import Sound.SC3.Lang.Pattern.List--> let { p = pseq [1, 2, 3] 1->     ; t = pbool (pseq [0, 0, 1, 0, 0, 0, 1, 1] 1) } -> in ptrigger t p--> let { p = [1, 2, 3]->     ; t = bool [0, 0, 1, 0, 0, 0, 1, 1] }-> in trigger t p

@@ -1,35 +0,0 @@-pwhite :: (Random a) => String -> P a -> P a -> P a--Uniform linear distribution in given range.--> import Sound.SC3.Lang.Pattern.List--> phead (pwhite "x" 0.0 1.0)--> ptake 5 (pwhite "x" 0.0 1.0)--It is important to note that this structure is not actually-indeterminate, so that the below is zero.--> let p = ptake 12 (pwhite "x" 0.0 1.0)-> in p - p--And likewise the below is a list of two equal elements.--> let { p = pwhite "x" 1 10->     ; q = ptake 1 p }-> in pseq [q, q] 1--The below is alternately lower and higher noise.--> let { l = pseq [0.0, 10.0] 1->     ; r = pseq [1.0, 11.0] 1->     ; p = pwhite "x" l r }-> in ptake 12 p--Or equivalently,--> let { b = pseq [return (0.0, 1.0)->                ,return (10.0, 11.0)] 1->     ; p = pwhite "x" (fmap fst b) (fmap snd b) }-> in ptake 12 p

@@ -1,12 +0,0 @@-zip :: [a] -> [b] -> [(a, b)]-pzip :: P a -> P b -> P (a, b)--> import Sound.SC3.Lang.Pattern.List--> ptake 5 (pzip (prepeat 3) (prepeat 4))--Stops on shortest pattern.--> pzip (pseries 0 1 5) (pseries 0 (-1) 4)--> zip [1..] [3,2,1] == [(1,3),(2,2),(3,1)]

@@ -1,12 +0,0 @@-mappend :: P a -> P a -> P a--Sequence two patterns.  This is the mappend instance of Monoid.--> import Data.Monoid-> import Sound.SC3.Lang.Pattern.Step--> let { p = pseq [1, 2] 1->     ; q = pseq [2, 3] 1 }-> in evalP (p `mappend` q)--> evalP (mempty `mappend` mempty)

@@ -1,29 +0,0 @@-pclutch :: (Num b, Ord b) => P a -> P b -> P a-pclutch' :: P a -> P Bool -> P a-- i - input- c - clutch--Sample and hold a pattern.  For values greater than-zero in the control pattern, step the value pattern,-else hold the previous value. --> import Sound.SC3.Lang.Pattern.Step--> let { p = pseq [1, 2, 3, 4, 5] 3->     ; q = pseq [1, 0, 1, 0, 0, 0, 1, 1] 1 }-> in evalP (pclutch p q)--There is a variant that requires a boolean -pattern.  --> let { p = pseq [1, 2, 3, 4, 5] 3->     ; q = fmap not (pbool (pseq [0, 0, 1, 0, 0, 0, 1, 1] 1)) }-> in evalP (pclutch' p q)--Note the initialization behavior, nothing-is generated until the first true value.--> let { p = pseq [1, 2, 3, 4, 5] 3->     ; q = pseq [0, 0, 0, 1, 0, 0, 1] 1 }-> in evalP (pclutch p q)

@@ -1,9 +0,0 @@-pcollect :: (a -> b) -> P a -> P b-pcollect = fmap--Patterns are functors.--> import Sound.SC3.Lang.Pattern.Step--> let p = pcollect (* 3) (pseq [1, 2, 3] 3)-> in evalP p

@@ -1,3 +0,0 @@-pcontinue :: P x -> (x -> P x -> P a) -> P a--> import Sound.SC3.Lang.Pattern.Step

@@ -1,10 +0,0 @@-pcountpre :: P Bool -> P Int-pcountpost :: P Bool -> P Int--> import Sound.SC3.Lang.Pattern.Step--> let p = pbool (pseq [0, 0, 1, 0, 0, 0, 1, 1] 1)-> in evalP (pcountpre p)--> let p = pbool (pseq [1, 0, 1, 0, 0, 0, 1, 1] 1)-> in evalP (pcountpost p)

@@ -1,9 +0,0 @@-pcycle :: P a -> P a--pattern variant of Data.List.cycle--> import Sound.SC3.Lang.Pattern.Step--> evalP (ptake 5 (pcycle (pseq [1,2,3] 1)))--[1,2,3,1,2]

@@ -1,26 +0,0 @@-pdegreeToKey :: (RealFrac a) => P a -> P [a] -> P a -> P a--         degree - scale degree (zero based)-          scale - list of divisions (ie. [0, 2, 4, 5, 7, 9, 11])- stepsPerOctave - division of octave (ie. 12)--Derive notes from an index into a scale.--> import Sound.SC3.Lang.Pattern.Step--> let { p = pseq [0, 1, 2, 3, 4, 3, 2, 1, 0, 2, 4, 7, 4, 2] 2->     ; q = prepeat [0, 2, 4, 5, 7, 9, 11]->     ; r = prepeat 12 }-> in evalP (pdegreeToKey p q r)--> let { p = pseq [0, 1, 2, 3, 4, 3, 2, 1, 0, 2, 4, 7, 4, 2] 2->     ; q = pseq [return [0, 2, 4, 5, 7, 9, 11]->                ,return [0, 2, 3, 5, 7, 8, 11]] 1->     ; r = prepeat 12 }-> in evalP (pdegreeToKey p (pstutter 14 q) r)--The degree_to_key function is also given.--> import Sound.SC3.Lang.Math--> map (\n -> degree_to_key n [0,2,4,5,7,9,11] 12) [0,2,4,7,4,2,0]

@@ -1,8 +0,0 @@-pdrop :: P Int -> P a -> P a--Drop first n element from pattern.--> import Sound.SC3.Lang.Pattern.Step--> let p = pseq [1, 2, 3] 4-> in evalP (pdrop 7 p)

@@ -1,10 +0,0 @@-mempty :: P a--The empty pattern.--> import Data.Monoid-> import Sound.SC3.Lang.Pattern.Step--> evalP mempty--> evalP (mempty `mappend` return 1)

@@ -1,13 +0,0 @@-pexprand :: (Floating a, Random a) => P a -> P a -> P Int -> P a--Exponential distribution distribution in given range.--> import Sound.SC3.Lang.Pattern.Step--> let p = pexprand 0.01 0.99 12-> in evalP p--> let { l = pseq [1, 11] 1->     ; r = pseq [2, 12] 1->     ; p = pexprand l r 12 }-> in evalP p

@@ -1,9 +0,0 @@-pfilter :: (a -> Bool) -> P a -> P a--Allows values for which the predicate is true. --> import Sound.SC3.Lang.Pattern.Step--> let { p = pseq [1, 2, 3] 3->     ; q = pfilter (< 3) p }-> in evalP q

@@ -1,26 +0,0 @@-pfin :: P Int -> P a -> P a-pfin_ :: Int -> P a -> P a-ptake :: P Int -> P a -> P a-ptake_ :: P Int -> P a -> P a--  n - number of elements to take-  x - value pattern--Take only the first n elements of the pattern -into the stream.--> import Sound.SC3.Lang.Pattern.Step--> let p = pseq [1, 2, 3] pinf-> in evalP (pfin 5 p)--There is a variant where the count not a pattern.--> let p = pseq [1, 2, 3] 1-> in evalP (pfin_ 5 p)--Note that pfin does not extend the input pattern,-unlike pser.--> let p = pseq [1, 2, 3] 1-> in evalP (pser [p] 5)

@@ -1,18 +0,0 @@-pfix :: Int -> P a -> P a--> import Sound.SC3.Lang.Pattern.Step--The psuedo-random nodes are actually indeterminate.-To fix the value of these nodes use pfix.--> let p = pwhite 0.0 1.0 12-> in evalP (p - p)--> let p = pfix 0 (pwhite 0.0 1.0 12)-> in evalP (p - p)--The innermost pfix is binding.--> let p = pwhite 0.0 1.0 12-> in evalP (pzip (pfix 1 (pfix 0 p) - pfix 0 p)->                (pfix 0 (pfix 1 p) - pfix 0 p))

@@ -1,17 +0,0 @@-pgeom :: (Num a) => a -> a -> Int -> P a--Geometric series pattern.--  start - start value-   grow - multiplication factor- length - number of values produced--> import Sound.SC3.Lang.Pattern.Step--> let p = pgeom 1 2 12-> in evalP p--Real numbers work as well.--> let p = pgeom 1.0 1.1 6-> in evalP p

@@ -1,14 +0,0 @@-phead :: P a -> P a--Retain only the first element of a pattern.--> import Data.Monoid-> import Sound.SC3.Lang.Pattern.Step--> let p = pseq [1, 2, 3] 1-> in evalP (phead p)--> let p = pseq [1, 2, 3] 1-> in evalP (phead p `mappend` ptail p)--> evalP (phead mempty)

@@ -1,34 +0,0 @@-pif :: P Bool -> P a -> P a -> P a--Pattern-based conditional expression.-- condition - pattern of selectors-    iftrue - pattern selected from when condition is true-   iffalse - pattern selected from when condition is false--> import Sound.SC3.Lang.Pattern.Step--A determinstic condition pattern, with deterministic-branches.--> let { c = pbool (pseq [1, 0, 1, 0, 0, 0, 1, 0, 1, 0, 0] 1)->     ; p = pseq [1,2,3,4,5] pinf->     ; q = pseq [11,12,13,14,15] pinf }-> in evalP (pif c p q)--A non-deterministic condition pattern, with-noisy branches.--> let { c = fmap (< 0.3) (pwhite 0 1 20)->     ; p = pwhite 0 9 pinf->     ; q = pwhite 100 109 pinf }-> in evalP (pif c p q)--Note that the noisy variant can be had for-less trouble as:--> let { c = fmap (< 0.3) (pwhite 0 1 20)->     ; p = pwhite 0 9 pinf->     ; q = pwhite 100 109 pinf ->     ; if_f c' p' q' = if c' then p' else q' }-> in evalP (pzipWith3 if_f c p q)

@@ -1,12 +0,0 @@-pinterleave :: P a -> P a -> P a--Interleave elements from two patterns.--> import Sound.SC3.Lang.Pattern.Step--> let { p = pseq [1, 2, 3] 3->     ; q = pseq [4, 5, 6, 7] 2 }-> in evalP (pinterleave p q)--> let p = pinterleave (pwhite 1 9 5) (pseries 10 1 10)-> in evalP p

@@ -1,16 +0,0 @@-pn :: P a -> P Int -> P a-preplicate :: P Int -> P a -> P a--Repeats the enclosed pattern a number of times.--> import Sound.SC3.Lang.Pattern.Step--> let p = pn (pseq [1, 2, 3] 1) 4-> in evalP p--There is a variant with the arguments-reversed.--> let p = preplicate 4 (pseq [1, 2, 3] 1)-> in evalP p-

@@ -1,30 +0,0 @@-ppatlace :: [P a] -> P Int -> P a--     list - patterns to step through-  repeats - number of steps to take--Interlaced embedding of streams.  Similar to -Place, but the list is an array of streams or -patterns. The results of each stream will be-output in turn.--> import Sound.SC3.Lang.Pattern.Step--> let { w = pwhite 1 5 5->     ; g = pgeom 10 1.01 10 }-> in evalP (ppatlace [w, g] 15)--> let { w = pwhite 1 5 5->     ; g = pgeom 10 1.01 10 }-> in evalP (ptake 15 (ppatlacea (pseq (map return [w, g]) 1)))--Note that the ppatlace has an infinite number -of repeats, but the resulting stream is finite -because the member streams are all finite. -When the first stream (pwhite) comes to an end, -it is skipped and you see only the second -stream until it stops.--If even one member stream is infinite and -ppatlace has infinite repeats, the ppatlace -stream will also be infinite.

@@ -1,21 +0,0 @@-prand :: [P a] -> P Int -> P a--Returns one item from the list at random for each repeat. --> import Sound.SC3.Lang.Pattern.Step--> let p = prand [1, 2, 3, 4, 5] 6-> in evalR "x" p--> let p = prand [ pseq [1, 2] 1->               , pseq [3, 4] 1->               , pseq [5, 6] 1 ] 9-> in evalR "x" p--> import Data.Monoid--> let p = pseq [prand [mempty, pseq [24, 31, 36, 43, 48, 55] 1] 1->              ,pseq [60, prand [63, 65] 1->                    ,67, prand [70, 72, 74] 1] (prrand 2 5)->              ,prand [74, 75, 77, 79, 81] (prrand 3 9)] pinf-> in take 24 (evalR "x" p)

@@ -1,10 +0,0 @@-preject :: (a -> Bool) -> P a -> P a-preject f = pfilter (not . f)--Rejects values for which the predicate is true. --> import Sound.SC3.Lang.Pattern.Step--> let { p = pseq [1, 2, 3] 3->     ; q = preject (== 1) p }-> in evalP q

@@ -1,10 +0,0 @@-prepeat :: a -> P a--pattern variant of Data.List.repeat--> import Sound.SC3.Lang.Pattern.Step--> evalP (ptake 5 (prepeat 3))--[3,3,3,3,3]-

@@ -1,11 +0,0 @@-prorate--Divide stream proportionally-- proportions - a pattern that returns either numbers (divides the-               pattern into pairs) or arrays of size n which are used-               to split up the input into n parts.-     pattern - a numerical pattern--> let p = prorate (pseq [0.35, 0.5, 0.8] 1) 1-> in evalP p

@@ -1,37 +0,0 @@-> import Sound.SC3.Lang.Pattern.Step-> import System.IO--> data S = S { c :: Char }--> u :: Show a => (a, S) -> IO S-> u (a,_) = print a >> getChar >>= return . S--> s0 :: S-> s0 = S 'a'--> p :: P S Char-> p = prp (\s -> (pcons (c s) p, s))--> q :: P S (Char,Int)-> q = pzip p (pseq [1,2,3,4,5] 1)--> main :: IO ()-> main = do->   hSetBuffering stdin NoBuffering->   s <- u (('t',0), s0)->   r <- runP s u (flip (:)) [] q->   print (reverse r)---- for below, set hsc3-literate-p to nil--import Sound.SC3.Lang.Pattern.Step-import System.IO--let { u (x,_) = print x >> getChar >>= return-    ; s0 = 'a'-    ; p = prp (\s -> (pcons s p, s))-    ; q = pzip p (pseq [1,2,3,4,5] 1) }-in do { hSetBuffering stdin NoBuffering-      ; s <- u (('t',0), s0)-      ; r <- runP s u (flip (:)) [] q-      ; print (reverse r) }

@@ -1,8 +0,0 @@-prsd :: (Eq a) => P a -> P a--Remove successive duplicates.--> import Sound.SC3.Lang.Pattern.Step--> let p = pseq [1,1,2,2,2,3,3] 1-> in evalP (prsd p)

@@ -1,33 +0,0 @@-pscan :: (x -> y -> (x, a)) -> Maybe (x -> a) -> x -> P y -> P a--Basic state threading function.  x is the state, an optional-final state to value function can be given if required.--> import Sound.SC3.Lang.Pattern.Step--> let { p = pzip (pbool (pseq [1,0,0,1,0] 1)) (pseq [1,2,3,4,5] 1)->     ; f ys (b, x) = let r = if b then [x] else (x:ys) in (r, r) }-> in evalP (pscan f Nothing [] p)--[[1],[2,1],[3,2,1],[4],[5,4]]--> let { b = pbool (pseq [1,0,0,1,0,1] 1)->     ; p = pseq [1,2,3] 1->     ; q = pseq [11,12,13] 1->     ; f (x, y) True = ((ptail x, y), phead x)->     ; f (x, y) False = ((x, ptail y), phead y) }-> in evalP (psequence (pscan f Nothing (p,q) b))--[1,11,12,2,13,3]--> let { p = pbool (pseq [1,0,0,1,0,1] 1)->     ; q = pseq [1,2,3] 2->     ; r = pseq [11,12,13] 2->     ; s = pzip3 p q r->     ; f ([],ys) (True, x, y) = (([], ys ++ [y]), x)->     ; f ((x':xs),ys) (True, x, y) = ((xs ++ [x], ys ++ [y]), x')->     ; f (xs,[]) (False, x, y) = ((xs ++ [x], []), y)->     ; f (xs,y':ys) (False, x, y) = ((xs++[x], ys ++ [y]), y') }-> in evalP (pscan f Nothing ([],[]) s)--[1,11,12,2,13,3]

@@ -1,28 +0,0 @@-pscanl :: (a -> y -> a) -> a -> P y -> P a--Pattern variant of scanl.  Takes the second argument and the -first item of the pattern and applies the function to them, then-feeds the function with this result and the second argument -and so on. Returns the pattern of intermediate and final results.--> import Sound.SC3.Lang.Pattern.Step--> evalP (pscanl (/) 64 (pseq [4, 2, 4] 1))--[64.0,16.0,8.0,2.0]--> evalP (pscanl (/) 3 mempty)--[3.0]--> evalP (pscanl max 5 (pseq [1, 2, 3, 4] 1))--[5,5,5,5,5]--> evalP (pscanl max 5 (pseq [1, 2, 3, 4, 5, 6, 7] 1))--[5,5,5,5,5,5,6,7]--> evalP (pscanl (\x y -> 2*x + y) 4 (pseq [1, 2, 3] 1))--[4, 9, 20, 43]

@@ -1,48 +0,0 @@-pseq :: [P a] -> P Int -> P a-pseq_ :: [P a] -> Int -> P a--Cycle over a list of patterns. The repeats pattern gives-the number of times to repeat the entire list. --> import Sound.SC3.Lang.Pattern.Step--> let a = pseq [1, 2, 3] 2-> in evalP a--Unlike Pseq, pseq does not have an offset argument to-give a starting offset into the list.--> import Sound.SC3.Lang.Collection--> let p = pseq (rotate 3 [1, 2, 3, 4]) 3-> in evalP p--Because the repeat counter is a pattern one can have-a random number of repeats.--> let p = pseq [1, 2] (prrand 1 9)-> in evalR "x" p--For the same reason the pattern is not static when -re-examined.--> let p = pseq [0, pseq [1] (prrand 1 3), 2] 5-> in take 24 (evalR "x" p)--Further, if the repeat pattern is not singular,-the sequence will repeat until the pattern is exhausted.--> let { p = pseq [1] 3->     ; q = pseq [1] p }-> in evalP q--If one specifies the value pinf for the repeats variable, -then it will repeat indefinitely.--> let p = pseq [1, 2, 3] pinf-> in take 9 (evalP p)--There is a variant with a true integer repeat count.--> let p = pseq_ [1, 2, 3] 5-> in evalP p

@@ -1,16 +0,0 @@-pser :: [P a] -> P Int -> P a--pser is like pseq, however the repeats variable -gives the number of elements in the sequence,-not the number of cycles of the pattern.--> import Sound.SC3.Lang.Pattern.Step--> let p = pser [1, 2, 3] 5-> in evalP p--> let p = pser [1, pser [100, 200] 3, 3] 9-> in evalP p--> let p = pser [1, 2, 3] 5 *. 3-> in evalP p

@@ -1,15 +0,0 @@-pseries :: (Num a) => a -> a -> Int -> P a--An arithmetric series. --  start - start value-   step - addition factor- length - number of values--> import Sound.SC3.Lang.Pattern.Step--> let p = pseries 0 2 24-> in evalP p--> let p = pseries 1.0 0.1 24-> in evalP p

@@ -1,26 +0,0 @@-pstutter :: P Int -> P a -> P a-pstutter' :: P Int -> P a -> P a--  count - number of repeats *cyc*-      x - value pattern--Repeat each element of a pattern n times.--> import Sound.SC3.Lang.Pattern.Step--> let p = pstutter 2 (pseq [1, 2, 3] pinf)-> in take 13 (evalP p)--> let { p = pseq [1, 2] pinf->     ; q = pseq [1, 2, 3] pinf->     ; r = pstutter p q }-> in take 13 (evalP r)--There is a variant, pstutter', that does not do-implicit extension on the count pattern.--> let p = pstutter' (prepeat 2) (pseq [1, 2, 3] pinf)-> in take 13 (evalP p)--> let p = pstutter' (pseq [2,3] 1) (pseq [1, 2, 3] pinf)-> in evalP p

@@ -1,11 +0,0 @@-pswitch :: [P a] -> P Int -> P a-pswitch l i = i >>= (l !!)--Select elements from a list of patterns by a pattern of indices.--> import Sound.SC3.Lang.Pattern.Step--> let { a = pseq [1, 2, 3] 2->     ; b = pseq [65, 76] 1->     ; c = pswitch [a, b, 800] (pseq [2, 2, 0, 1] pinf) }-> in take 24 (evalP c)

@@ -1,22 +0,0 @@-pswitch1 :: [P a] -> P Int -> P a-pswitch1m :: IntMap (P a) -> P Int -> P a--  list - patterns to index- which - index--The pattern of indices is used select which pattern-to retrieve the next value from.  Only one value -is selected from each the pattern.--This is in comparison to pswitch, which embeds the -pattern in its entirety.  pswitch1 switches every value.--pswitch1 is implemented in terms of pswitch1m.--> import Control.Applicative-> import Sound.SC3.Lang.Pattern.Step--> let { p = pseq [1, 2, 3] pinf->     ; q = pseq [65, 76] pinf->     ; r = pswitch1 [p, q, pure 800] (pseq [2, 2, 0, 1] pinf) }-> in take 24 (evalP r)

@@ -1,10 +0,0 @@-ptail :: P a -> P a--Drop first element from pattern.--> import Sound.SC3.Lang.Pattern.Step--> let p = pseq [1, 2, 3] 1-> in evalP (ptail p)--> evalP (ptail mempty)

@@ -1,7 +0,0 @@-ptake :: P Int -> P a -> P a--> import Sound.SC3.Lang.Pattern.Step--> evalP (ptake 5 (pseq [1,2,3] pinf))--> evalP (ptake 5 (pseq [1,2,3] 1))

@@ -1,17 +0,0 @@-ptrigger :: P Bool -> P a -> P (Maybe a)--  tr - boolean pattern-   x - value pattern--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. --> import Sound.SC3.Lang.Pattern.Step--> let { p = pseq [1, 2, 3, 4, 5] 3     ->     ; t = pbool (pseq [0, 0, 1, 0, 0, 0, 1, 1] 1) } -> in evalP (ptrigger t p)

@@ -1,36 +0,0 @@-pwhite :: (Random a) => P a -> P a -> P Int -> P a--Uniform linear distribution in given range.--> import Sound.SC3.Lang.Pattern.Step--> let p = pwhite 0.0 1.0 12-> in evalR "x" p--It is important to note that this structure is-actually indeterminate, so that the below is-non-zero.--> let p = pwhite 0.0 1.0 12-> in evalR "x" (p - p)--And likewise the below is a list of two possibly -different elements.--> let { p = pwhite 1 10 1->     ; q = phead p }-> in evalR "x" (pseq [q, q] 1)--The below is alternately lower and higher noise.--> let { l = pseq [0.0, 10.0] 1->     ; r = pseq [1.0, 11.0] 1->     ; p = pwhite l r 12 }-> in evalR "x" p--Or equivalently,--> let { b = pseq [return (0.0, 1.0)->                ,return (10.0, 11.0)] 1->     ; p = pwhite (fmap fst b) (fmap snd b) 12 }-> in evalR "x" p

@@ -1,17 +0,0 @@-pwrap :: (Ord a, Num a) => P a -> P a -> P a -> P a-- x - input- l - lower bound *cycle*- r - upper bound *cycle*--If x is outside of (l, r) wrap until it lies inside.--> import Sound.SC3.Lang.Pattern.Step--> let { p = pseries 6 2 9->     ; q = pwrap p 2 10 }-> in evalP q--> let { p = pseries 6 2 9->     ; q = pwrap p 1 11 }-> in evalP q

@@ -1,9 +0,0 @@-pxrand :: (Eq a) => [P a] -> P Int -> P a--Like prand, returns one item from the list at random for each -step, but pxrand never repeats the same element twice in a row. --> import Sound.SC3.Lang.Pattern.Step--> let p = pxrand [1,2,3] 10-> in evalP p

@@ -1,7 +1,7 @@ hsc3-lang - Haskell SuperCollider Language Library -hsc3-lang provides Sound.SC3.Lang, a Haskell module that -defines a subset of functions from the SuperCollider +hsc3-lang provides Sound.SC3.Lang, a Haskell module that+defines a subset of functions from the SuperCollider class library.    http://slavepianos.org/rd/

@@ -0,0 +1,565 @@+-- | In cases where a method takes arguments, these precede the+-- collection argument in the haskell variant, so that @c.m(i,j)@+-- becomes @m i j c@.++module Sound.SC3.Lang.Collection where++import Data.List.Split {- split -}+import Data.List as L+import Data.Maybe++-- * Collection++-- | @Collection.*fill@ is 'map' over indices to /n/.+--+-- > fill 4 (* 2) == [0,2,4,6]+fill :: Int -> (Int -> 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++-- | @Collection.isEmpty@ is 'null'.+--+-- > isEmpty [] == True+isEmpty :: [a] -> Bool+isEmpty = null++-- | Function equal to 'const' of /f/ of /e/.+--+-- > select (ignoringIndex even) [1,2,3,4] == [2,4]+ignoringIndex :: (a -> b) -> a -> Int -> 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 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 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 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 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 f l = fmap snd (find (uncurry f) (zip l [0..]))++-- | @Collection.inject@ is a variant on 'foldl'.+--+-- > inject 0 (+) [1..5] == 15+-- > inject 1 (*) [1..5] == 120+inject :: a -> (a -> b -> a) -> [b] -> a+inject i f = foldl f i++-- | @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' 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 f =+    let g e = not . f e+    in not . any' g++-- | @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++-- | @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 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' 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 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 f = minimum . collect f++-- | Variant of 'zipWith' that cycles the shorter input.+--+-- > zipWith_c (+) [1,2] [3,4,5] == [4,6,6]+zipWith_c :: (a -> b -> c) -> [a] -> [b] -> [c]+zipWith_c f a b =+    let g [] [] _ = []+        g [] b' (_,e) = if e then [] else g a b' (True,e)+        g a' [] (e,_) = if e then [] else g a' b (e,True)+        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'.+--+-- > zip_c [1,2] [3,4,5] == [(1,3),(2,4),(1,5)]+zip_c :: [a] -> [b] -> [(a,b)]+zip_c = zipWith_c (,)++-- | Variant of 'zipWith3' that cycles the shorter inputs.+--+-- > zipWith3_c (,,) [1] [2,3] [4,5,6] == [(1,2,4),(1,3,5),(1,2,6)]+zipWith3_c :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]+zipWith3_c f p q r =+    let g = map (const ())+        l = [g p,g q,g r]+        f' _ = f+    in zipWith4 f' (extension l) (cycle p) (cycle q) (cycle r)++-- | 'zipWith3_c' based variant of 'zip3'.+--+-- > zip3_c [1] [2,3] [4,5,6] == [(1,2,4),(1,3,5),(1,2,6)]+zip3_c :: [a] -> [b] -> [c] -> [(a,b,c)]+zip3_c = zipWith3_c (\a b c -> (a,b,c))++-- | 'zipWith_c' based variant of applicative '<*>'.+--+-- > zap_c [(+1),negate] [1..6] == [2,-2,4,-4,6,-6]+zap_c :: [a -> b] -> [a] -> [b]+zap_c = zipWith_c (\f e -> f e)++-- * Sequenceable Collection++-- | @SequenceableCollection.*series@ is an arithmetic series with+-- arguments /size/, /start/ and /step/.+--+-- > 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]+-- > enumFromThenTo 5 7 10 == [5,7,9]+series :: (Num a) => Int -> a -> a -> [a]+series n i j =+    case n of+      0 -> []+      _ -> i : series (n - 1) (i + j) j++-- | @SequenceableCollection.*geom@ is a geometric series with arguments+-- /size/, /start/ and /grow/.+--+-- > 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 n i j =+    case n of+      0 -> []+      _ -> i : geom (n - 1) (i * j) j++-- | @SequenceableCollection.*fib@ is the Fibonacci series where /n/+-- is number of elements, /i/ is the initial step and /j/ the initial+-- value.+--+-- > 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 n i j =+    case n of+      0 -> []+      _ -> j : fib (n - 1) j (i + j)++-- | @SequenceableCollection.first@ is a total variant of 'L.head'.+--+-- > [3,4,5].first == 3+-- > first [3,4,5] == Just 3+-- > first' [3,4,5] == 3+--+-- > [].first == nil+-- > first [] == Nothing+first :: [t] -> Maybe t+first xs =+    case xs of+      [] -> Nothing+      x:_ -> Just x++-- | Synonym for 'L.head'.+first' :: [t] -> t+first' = head++-- | Total variant of 'L.last'.+--+-- > (1..5).last == 5+-- > lastM [1..5] == Just 5+-- > L.last [1..5] == 5+--+-- > [].last == nil+-- > lastM [] == Nothing+lastM :: [t] -> Maybe t+lastM xs =+    case xs of+      [] -> Nothing+      [x] -> Just x+      _:xs' -> lastM xs'++-- | @SequenceableCollection.last@ is a synonym for 'lastM'.+last :: [t] -> Maybe t+last = lastM++-- | Synonym for 'L.last'.+last' :: [t] -> t+last' = L.last++-- | @SequenceableCollection.indexOf@ is a variant of 'elemIndex' with+-- reversed arguments.+--+-- > [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++-- | 'fromJust' variant of 'indexOf'.+indexOf' :: Eq a => [a] -> a -> Int+indexOf' l = fromJust . indexOf l++-- | @SequenceableCollection.indexOfEqual@ is just 'indexOf'.+indexOfEqual :: Eq a => [a] -> a -> Maybe Int+indexOfEqual = indexOf++-- | @SequenceableCollection.indexOfGreaterThan@ is the index of the+-- first greater element.+--+-- > indexOfGreaterThan 70 [10,5,77,55,12,123] == Just 2+indexOfGreaterThan :: (Ord a) => a -> [a] -> Maybe Int+indexOfGreaterThan e = detectIndex (ignoringIndex (> e))++-- | @SequenceableCollection.indexIn@ is the index of nearest element.+--+-- > indexIn 5.2 [2,3,5,6] == 2+indexIn :: (Ord a,Num a) => a -> [a] -> Int+indexIn e l =+    let f 0 = 0+        f j = let i = j - 1+                  right = l !! j+                  left = l !! i+              in if (e - left) < (right - e) then i else j+    in maybe (size l - 1) f (indexOfGreaterThan e l)++-- | @SequenceableCollection.indexInBetween@ is the linearly+-- interpolated fractional index.+--+-- > indexInBetween 5.2 [2,3,5,6] == 2.2+indexInBetween :: (Ord a,Fractional a) => a -> [a] -> a+indexInBetween e l =+    let f 0 = 0+        f j = let i = fromIntegral j+                  a = l !! (j - 1)+                  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)++-- | @SequenceableCollection.keep@ is, for positive /n/ a synonym for+-- '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]+-- > keep 3 [1,2,3,4,5] == [1,2,3]+--+-- > [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]+-- > keep (-4) [1,2] == [1,2]+keep :: Int -> [a] -> [a]+keep n l =+    if n < 0+    then L.drop (length l + n) l+    else take 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/.+--+-- > [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) == [1,2]+-- > drop (-3) [1,2,3,4,5] == [1,2]+--+-- > [1,2].drop(-4) == []+-- > drop (-4) [1,2] == []+drop :: Int -> [a] -> [a]+drop n l =+    if n < 0+    then take (length l + n) l+    else L.drop n l++-- | Function to calculate a list equal in length to the longest input+-- list, therefore being productive over infinite lists.+--+-- > extension [[1],[2,3],[4,5,6]] == [(),(),()]+-- > take 3 (extension [[1],[2..]]) == [(),(),()]+extension :: [[a]] -> [()]+extension x =+    if null x+    then []+    else let x' = filter (not . null) (map tail x)+         in () : extension x'++-- | @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]]+-- > 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]]+-- > 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 [] == []+--+-- The 'flop' and 'extendSequences' functions are non-strict and+-- productive.+--+-- > take 4 (flop [[1..3],[4..]]) == [[1,4],[2,5],[3,6],[1,7]]+-- > map (take 4) (extendSequences [[1..3],[4..]]) == [[1,2,3,1],[4,5,6,7]]+flop :: [[a]] -> [[a]]+flop l =+    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'.+--+-- > [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++-- | @List.foldExtend@ extends sequence by /folding/ backwards at end.+-- 'foldExtend' is in terms of 'cycleFold', which is in terms of+-- 'mirror1'.+--+-- > [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.+--+-- > [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++-- | Variant of 'separate' that performs initial separation.+separateAt :: (a -> a -> Bool) -> [a] -> ([a],[a])+separateAt f xs =+    case xs of+      (x1:x2:xs') ->+          if f x1 x2+          then ([x1],x2:xs')+          else let g e (l,r) = (e:l,r)+               in x1 `g` separateAt f (x2:xs')+      _ -> (xs,[])++-- | @SequenceableCollection.separate@ applies the predicate 'f' to+-- 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]]+-- > 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]]+-- > 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 =+    let (e,r) = separateAt f l+    in if null r then [e] else e : separate f r++-- | @SequenceableCollection.clump@ is a synonym for+-- 'Data.List.Split.splitEvery'.+--+-- > [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 = splitEvery++-- | @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]]+-- > 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 =+    let f [] _ = undefined+        f (n:ns) l = let (e,r) = splitAt n l+                     in if null r then [e] else e : clumps ns r+    in case m of+         [] -> []+         _ -> f (cycle m) s++-- | @SequenceableCollection.integrate@ is the incremental sum of+-- elements.+--+-- > integrate [3,4,1,1] == [3,7,8,9]+integrate :: (Num a) => [a] -> [a]+integrate = scanl1 (+)++-- | @SequenceableCollection.differentiate@ is the pairwise difference+-- between elements.+--+-- > differentiate [3,4,1,1] == [3,1,-3,0]+differentiate :: (Num a) => [a] -> [a]+differentiate l = zipWith (-) l (0:l)++-- | Rotate /n/ places to the left.+--+-- > 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++-- | Rotate /n/ places to the right.+--+-- > 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++-- | @ArrayedCollection.normalizeSum@ ensures sum of elements is one.+--+-- > normalizeSum [1,2,3] == [1/6,2/6,3/6]+normalizeSum :: (Fractional a) => [a] -> [a]+normalizeSum l =+    let n = sum l+    in map (/ n) l++-- | @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)+-- > 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)+-- > slide 3 2 [1,2,3,4,5,6] == [1,2,3,3,4,5]+--+-- > [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 w n l =+    let k = length l+    in concatMap (\i -> take w (L.drop 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]+-- > 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]+-- > mirror1 [1,2,3,4] == [1,2,3,4,3,2]+mirror1 :: [a] -> [a]+mirror1 l =+    case l of+      [] -> []+      [e] -> [e]+      _ -> l ++ tail (reverse (tail l))++-- | @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]+-- > 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]+-- > stutter 2 [1,2,3] == [1,1,2,2,3,3]+stutter :: Int -> [a] -> [a]+stutter n = concatMap (replicate n)++-- | @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]+-- > rotate 1 [1..5] == [5,1,2,3,4]+--+-- > (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]+-- > rotate 3 [1..5] == [3,4,5,1,2]+rotate :: Int -> [a] -> [a]+rotate n = if n < 0 then rotateLeft n else rotateRight n

@@ -1,56 +0,0 @@-module Sound.SC3.Lang.Collection.Collection where--import Data.List-import Data.Maybe--fill :: Int -> (Int -> a) -> [a]-fill n f = map f [0 .. n - 1]--size :: [a] -> Int-size = length--isEmpty :: [a] -> Bool-isEmpty = null--ignoringIndex :: (a -> b) -> a -> Int -> b-ignoringIndex f e _ = f e--collect :: (a -> Int -> b) -> [a] -> [b]-collect f l = zipWith f l [0..]--select :: (a -> Int -> Bool) -> [a] -> [a]-select f l = map fst (filter (uncurry f) (zip l [0..]))--reject :: (a -> Int -> Bool) -> [a] -> [a]-reject f l = map fst (filter (not . uncurry f) (zip l [0..]))--detect :: (a -> Int -> Bool) -> [a] -> Maybe a-detect f l = maybe Nothing (Just . fst) (find (uncurry f) (zip l [0..]))--detectIndex :: (a -> Int -> Bool) -> [a] -> Maybe Int-detectIndex f l = maybe Nothing (Just . snd) (find (uncurry f) (zip l [0..]))--inject :: a -> (a -> b -> a) -> [b] -> a-inject i f = foldl f i--any' :: (a -> Int -> Bool) -> [a] -> Bool-any' f = isJust . detect f--every :: (a -> Int -> Bool) -> [a] -> Bool-every f = let g e = not . f e-          in not . any' g--count :: (a -> Int -> Bool) -> [a] -> Int-count f = length . select f--occurencesOf :: (Eq a) => a -> [a] -> Int-occurencesOf k = count (\e _ -> e == k)--sum' :: (Num a) => (b -> Int -> a) -> [b] -> a-sum' f = sum . collect f--maxItem :: (Ord b) => (a -> Int -> b) -> [a] -> b-maxItem f = maximum . collect f--minItem :: (Ord b) => (a -> Int -> b) -> [a] -> b-minItem f = minimum . collect f

@@ -0,0 +1,38 @@+-- | Variants of standard numerical operators with SC3 extension+-- behaviour.  Pointwise operations in SuperCollider language extend+-- the shorter input by cycling.+--+-- > [1,2] +. [3,4,5] == [1,2,1] +. [3,4,5]+-- > [1,2] +. [3,4,5] == [4,6,6]+--+-- The function underlying the list numerical instances is 'zipWith_c'.+--+-- > zipWith (+) [1,2] [3,4,5] == [4,6]+-- > zipWith_c (+) [1,2] [3,4,5] == [4,6,6]+module Sound.SC3.Lang.Collection.Extension where++import qualified Sound.SC3.Lang.Collection as C++-- | Class defining 'zipWith_c' which is a cycle extending variant of+-- 'zipWith'.+class Extending f where+    zipWith_c :: (a -> b -> c) -> f a -> f b -> f c++instance Extending [] where+    zipWith_c = C.zipWith_c++-- | 'zipWith_c' '+'.+(+.) :: (Extending f,Num a) => f a -> f a -> f a+(+.) = zipWith_c (+)++-- | 'zipWith_c' '*'.+(*.) :: (Extending f,Num a) => f a -> f a -> f a+(*.) = zipWith_c (*)++-- | 'zipWith_c' '/'.+(/.) :: (Extending f,Fractional a) => f a -> f a -> f a+(/.) = zipWith_c (/)++-- | 'zipWith_c' '-'.+(-.) :: (Extending f,Num a) => f a -> f a -> f a+(-.) = zipWith_c (-)

@@ -1,37 +0,0 @@-module Sound.SC3.Lang.Collection.Numerical where--import Sound.SC3.Lang.Collection.SequenceableCollection (zipWith_c)--instance Num a => Num [a] where-    negate         = map negate-    (+)            = zipWith_c (+)-    (-)            = zipWith_c (-)-    (*)            = zipWith_c (*)-    abs            = map abs-    signum         = map signum-    fromInteger n  = [fromInteger n]--instance Fractional a => Fractional [a] where-    recip          = map recip-    (/)            = zipWith_c (/)-    fromRational n = [fromRational n]--instance Floating a => Floating [a] where-    pi             = cycle [pi]-    exp            = map exp-    log            = map log-    sqrt           = map sqrt-    (**)           = zipWith_c (**)-    logBase        = zipWith_c logBase-    sin            = map sin-    cos            = map cos-    tan            = map tan-    asin           = map asin-    acos           = map acos-    atan           = map atan-    sinh           = map sinh-    cosh           = map cosh-    tanh           = map tanh-    asinh          = map asinh-    acosh          = map acosh-    atanh          = map atanh

@@ -0,0 +1,49 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- | List instances of the standard haskell numerical classes with SC3+-- extension behaviour.  Provides instances for 'Num', 'Fractional'+-- and 'Floating'.+--+-- > [1,2] + [3,4,5] == [4,6,6]+-- > [1,2,3] * [4,5] == [4,10,12]+--+-- Literals are interpreted as single element lists.+--+-- > [1,2,3] + 4 == [5,6,7]+-- > [1,2,3] * 4 == [4,8,12]+module Sound.SC3.Lang.Collection.Numerical.Extending where++import Sound.SC3.Lang.Collection.Extension (zipWith_c)++instance Num a => Num [a] where+    negate = map negate+    (+) = zipWith_c (+)+    (-) = zipWith_c (-)+    (*) = zipWith_c (*)+    abs = map abs+    signum = map signum+    fromInteger n = [fromInteger n]++instance Fractional a => Fractional [a] where+    recip = map recip+    (/) = zipWith_c (/)+    fromRational n = [fromRational n]++instance Floating a => Floating [a] where+    pi = cycle [pi]+    exp = map exp+    log = map log+    sqrt = map sqrt+    (**) = zipWith_c (**)+    logBase = zipWith_c logBase+    sin = map sin+    cos = map cos+    tan = map tan+    asin = map asin+    acos = map acos+    atan = map atan+    sinh = map sinh+    cosh = map cosh+    tanh = map tanh+    asinh = map asinh+    acosh = map acosh+    atanh = map atanh

@@ -0,0 +1,52 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- | List instances of the standard haskell numerical classes with+-- standard haskell truncating behaviour.  Provides instances for+-- 'Num', 'Fractional' and 'Floating'.+--+-- > [1,2] + [3,4,5] == [4,6]+-- > [1,2,3] * [4,5] == [4,10]+--+-- Literals are interpreted as infinte lists.+--+-- > [1,2,3] + 4 == [5,6,7]+-- > [1,2,3] * 4 == [4,8,12]+module Sound.SC3.Lang.Collection.Numerical.Truncating where++instance (Num a) => Num [a] where+    (+) = zipWith (+)+    (-) = zipWith (-)+    (*) = zipWith (*)+    abs = map abs+    signum = map signum+    fromInteger = repeat . fromInteger+    negate = map negate++instance (Fractional a) => Fractional [a] where+    (/) = zipWith (/)+    recip = map recip+    fromRational = repeat . fromRational++instance Floating a => Floating [a] where+    pi = repeat pi+    exp = map exp+    log = map log+    sqrt = map sqrt+    (**) = zipWith (**)+    logBase = zipWith logBase+    sin = map sin+    cos = map cos+    tan = map tan+    asin = map asin+    acos = map acos+    atan = map atan+    sinh = map sinh+    cosh = map cosh+    tanh = map tanh+    asinh = map asinh+    acosh = map acosh+    atanh = map atanh++{-+[1,2,3] * [4,5]+[1,2,3] * 2+-}

@@ -1,156 +0,0 @@-module Sound.SC3.Lang.Collection.SequenceableCollection where--import Control.Monad-import Data.List-import Data.List.Split-import Sound.SC3.Lang.Collection.Collection-import System.Random---- | Arithmetic series (size, start, step)-series :: (Num a) => Int -> a -> a -> [a]-series 0 _ _ = []-series n i j = i : series (n - 1) (i + j) j---- | Geometric series (size, start, grow)-geom :: (Num a) => Int -> a -> a -> [a]-geom 0 _ _ = []-geom n i j = i : series (n - 1) (i * j) j---- | Fibonacci series (size, initial step, start)-fib :: (Num a) => Int -> a -> a -> [a]-fib 0 _ _ = []-fib n i j = j : fib (n - 1) j (i + j)---- | Random values (size, min, max) - ought this be in floating?-rand :: (Random a) => Int -> a -> a -> IO [a]-rand n l r = replicateM n (getStdRandom (randomR (l, r)))---- | Random values in the range -abs to +abs (size, abs)-rand2 :: (Num a, Random a) => Int -> a -> IO [a]-rand2 n m = replicateM n (getStdRandom (randomR (negate m, m)))---- | The first element.-first :: [t] -> Maybe t-first (x:_) = Just x-first _ = Nothing---- | The last element.-last' :: [t] -> Maybe t-last' [] = Nothing-last' [x] = Just x-last' (_:xs) = last' xs---- | flip elemIndex-indexOf :: Eq a => [a] -> a -> Maybe Int-indexOf = flip elemIndex---- | indexOf-indexOfEqual :: Eq a => [a] -> a -> Maybe Int-indexOfEqual = indexOf---- | Collection is sorted, index of first greater element.-indexOfGreaterThan :: (Ord a) => a -> [a] -> Maybe Int-indexOfGreaterThan e = detectIndex (ignoringIndex (> e))---- | Collection is sorted, index of nearest element.-indexIn :: (Ord a, Num a) => a -> [a] -> Int-indexIn e l =-    let f 0 = 0-        f j = let i = j - 1-                  right = l !! j-                  left = l !! i-              in if (e - left) < (right - e) then i else j-    in maybe (size l - 1) f (indexOfGreaterThan e l)---- | Collection is sorted, linearly interpolated fractional index.-indexInBetween :: (Ord a, Fractional a) => a -> [a] -> a-indexInBetween e l =-    let f 0 = 0-        f j = let i = fromIntegral j-                  a = l !! (j - 1)-                  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)--keep :: Int -> [a] -> [a]-keep n l =-    if n < 0-    then drop (length l + n) l-    else take n l--drop' :: Int -> [a] -> [a]-drop' n l =-    if n < 0-    then take (length l + n) l-    else drop n l--extendSequences :: [[a]] -> [[a]]-extendSequences l =-    let n = maximum (map length l)-    in map (take n . cycle) l--flop :: [[a]] -> [[a]]-flop = transpose . extendSequences--choose :: [a] -> IO a-choose l = liftM (l!!) (getStdRandom (randomR (0, length l - 1)))--separateAt :: (a -> a -> Bool) -> [a] -> ([a], [a])-separateAt f (x1:x2:xs) =-    if f x1 x2-    then ([x1], x2:xs)-    else let g e (l,r) = (e:l, r)-         in x1 `g` separateAt f (x2:xs)-separateAt _ l = (l,[])--separate :: (a -> a -> Bool) -> [a] -> [[a]]-separate f l =-    let (e, r) = separateAt f l-    in if null r then [e] else e : separate f r--clump :: Int -> [a] -> [[a]]-clump = splitEvery--clumps :: [Int] -> [a] -> [[a]]-clumps [] _ = []-clumps m s =-    let f [] _ = undefined-        f (n:ns) l = let (e, r) = splitAt n l-                     in if null r then [e] else e :clumps ns r-    in f (cycle m) s---- | dx -> d-integrate :: (Num a) => [a] -> [a]-integrate [] = []-integrate (x:xs) =-    let f p c = (p + c, p + c)-    in x : snd (mapAccumL f x xs)---- | d -> dx-differentiate :: (Num a) => [a] -> [a]-differentiate l = zipWith (-) l (0:l)---- | Rotate n places to the left (ie. rotate 1 [1, 2, 3] is [2, 3, 1]).-rotate :: Int -> [a] -> [a]-rotate n p =-    let (b, a) = splitAt n p-    in a ++ b---- | Ensure sum of elements is one.-normalizeSum :: (Fractional a) => [a] -> [a]-normalizeSum l =-    let n = sum l-    in map (/ n) l---- | Variant that cycles the shorter input.-zipWith_c :: (a -> b -> c) -> [a] -> [b] -> [c]-zipWith_c f a b =-    let g [] [] _ = []-        g [] b' (_, e) = if e then [] else g a b' (True, e)-        g a' [] (e, _) = if e then [] else g a' b (e, True)-        g (a0 : aN) (b0 : bN) e = f a0 b0 : g aN bN e-    in g a b (False, False)--zip_c :: [a] -> [b] -> [(a, b)]-zip_c = zipWith_c (,)

@@ -0,0 +1,225 @@+{-# 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'.+module Sound.SC3.Lang.Collection.Universal.Datum where++import Data.Maybe+import Data.Ratio+import GHC.Exts (IsString(..))+import Sound.OpenSoundControl.Type (Datum(..))+import System.Random++instance IsString Datum where+    fromString = String++-- | 'Datum' as real number if 'Double', 'Float' or 'Int', else 'Nothing'.+--+-- > map datum_r [Int 5,Float 5,String "5"] == [Just 5,Just 5,Nothing]+datum_r :: Datum -> Maybe Double+datum_r d =+    case d of+      Double n -> Just n+      Float n -> Just n+      Int n -> Just (fromIntegral n)+      _ -> Nothing++-- | A 'fromJust' variant of 'datum_r'.+--+-- > map datum_r' [Int 5,Float 5] == [5,5]+datum_r' :: Datum -> Double+datum_r' = fromJust . datum_r++-- | Extract 'String' from 'Datum', else 'Nothing'.+--+-- > map datum_str [String "5",Int 5] == [Just "5",Nothing]+datum_str :: Datum -> Maybe String+datum_str d =+    case d of+      String s -> Just s+      _ -> Nothing++-- | A 'fromJust' variant of 'datum_str'.+datum_str' :: Datum -> String+datum_str' = fromJust . datum_str++-- | 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"++-- | Promote 'Int' and 'Float' 'Datum' to 'Double' 'Datum'.+--+-- > map datum_promote [Int 5,Float 5] == [Double 5,Double 5]+datum_promote :: Datum -> Datum+datum_promote d =+    case d of+      Int n -> Double (fromIntegral n)+      Float n -> Double n+      _ -> d++-- | 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++-- | A 'Double' binary operator.+type F_Binop = Double -> Double -> Double++-- | Given 'Int' 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 =+    case (d1,d2) of+      (Int n1,Int n2) -> Int (fi n1 n2)+      (Float n1,Float n2) -> Float (fd n1 n2)+      (Double n1,Double n2) -> Double (fd n1 n2)+      _ -> case (datum_r d1,datum_r d2) of+             (Just n1,Just n2) -> Double (fd n1 n2)+             _ -> error "datum_lift2"++-- | A 'datum_promote' variant of 'datum_lift2'.+--+-- > datum_lift2' (+) (Float 1) (Float 2) == Double 3+datum_lift2' :: F_Binop -> Datum -> Datum -> Datum+datum_lift2' f d1 =+    let d1' = datum_promote d1+    in datum_lift2 (error "datum_lift2:non integral") f d1' .+       datum_promote++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)++instance Fractional Datum where+    recip = datum_lift' recip+    (/) = datum_lift2' (/)+    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++instance Real Datum where+    toRational d =+        case d of+          Int n -> fromIntegral n % 1+          Float n -> toRational n+          Double n -> toRational n+          _ -> error "datum,real,partial"++instance RealFrac Datum where+  properFraction d = let (i,j) = properFraction (datum_r' d) in (i,Double j)+  truncate = truncate . datum_r'+  round = round . datum_r'+  ceiling = ceiling . datum_r'+  floor = floor . datum_r'++instance Ord Datum where+    p < q = case (datum_r p,datum_r q) of+              (Just i,Just j) -> i < j+              _ -> error "datum,ord,partial"++-- | 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"++-- | 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"++-- | 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 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++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')+        (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"+  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+-}

@@ -0,0 +1,64 @@+-- | 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+             }++-- | Run 'delta_f' for 'Duration'.+--+-- > delta (defaultDuration {dur = 2,stretch = 2}) == 4+delta :: Duration a -> a+delta d = delta_f d d++-- | Run 'sustain_f' for 'Duration'.+--+-- > sustain defaultDuration == 0.8+sustain :: Duration a -> a+sustain d = sustain_f d d++-- | If 'fwd'' field is set at 'Duration' extract value, else+-- calculate 'delta'.+--+-- > 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').+--+-- > default_sustain_f (defaultDuration {legato = 1.2}) == 1.2+default_delta_f :: (Num a,Fractional a) => Duration a -> a+default_delta_f d = dur d * stretch d * (60 / tempo d)++-- | The default 'sustain_f' field for 'Duration'.  Equal to 'dur' '*'+-- 'legato' '*' 'stretch' '*' (@60@ '/' 'tempo').+--+-- > default_sustain_f (defaultDuration {legato = 1.2}) == 1.2+default_sustain_f :: (Num a,Fractional a) => Duration a -> a+default_sustain_f d = dur d * legato d * stretch d * (60 / tempo d)++-- | Default 'Duration' 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}

@@ -0,0 +1,267 @@+-- | An 'Event' is a ('Key','Value') 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 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++-- | The type of the /key/ at an 'Event'.+type Key = String++-- | The type of the /value/ at an 'Event'.+type Value = Double++-- | The /type/ of an 'Event'.+type Type = String++-- | 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)++-- | The /default/ empty event.+defaultEvent :: Event+defaultEvent =+    Event {e_type = "unknown"+          ,e_id = Nothing+          ,e_instrument = Nothing+          ,e_map = M.empty}++-- | Lookup /k/ in /e/.+--+-- > lookup_m "k" defaultEvent == Nothing+lookup_m :: Key -> Event -> Maybe Value+lookup_m k e = M.lookup k (e_map e)++-- | Variant of 'lookup_m' with a default value /v/.+--+-- > lookup_v 1 "k" defaultEvent == 1+lookup_v :: Value -> Key -> Event -> Value+lookup_v v k e = fromMaybe v (lookup_m k e)++-- | Variant of 'lookup_v' with a transformation function.+--+-- > 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'++-- | 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"}++-- | 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'"}++-- | Insert (/k/,/v/) into /e/.+--+-- > 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)}++-- | The frequency of the 'pitch' of /e/.+--+-- > freq (event [("degree",5)]) == 440+-- > freq (event [("midinote",69)]) == 440+freq :: Event -> Double+freq = P.detunedFreq . pitch++-- | Lookup /db/ field of 'Event', the default value is @-20db@.+db :: Event -> Value+db = lookup_v (-20) "db"++-- | Function to convert from decibels to linear amplitude.+dbAmp' :: Floating a => a -> a+dbAmp' a = 10 ** (a * 0.05)++-- | The linear amplitude of the amplitude model at /e/.+--+-- > amp (event [("db",-20)]) == 0.1+amp :: Event -> Value+amp e = lookup_v (dbAmp' (db e)) "amp" e++-- | The /fwd/ value of the duration model at /e/.+--+-- > fwd (event [("dur",1),("stretch",2)]) == 2+fwd :: Event -> Double+fwd = D.fwd . duration++-- | The /sustain/ value of the duration model at /e/.+--+-- > sustain (event [("dur",1),("legato",0.5)]) == 0.5+sustain :: Event -> Double+sustain = D.sustain . duration++-- | List of reserved /keys/ for pitch, duration and amplitude models.+--+-- > ("degree" `elem` reserved) == True+reserved :: [Key]+reserved =+    ["amp","db"+    ,"delta","dur","legato","fwd'","stretch","sustain","tempo"+    ,"ctranspose","degree","freq","midinote","mtranspose","note","octave"]++-- | 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)++-- | Extract non-'reserved' 'Keys' from 'Event'.+parameters :: Event -> [(Key,Value)]+parameters = mapMaybe parameters' . M.toList . e_map++-- | '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++-- | 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++-- | 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}++-- | Construct an 'Event' from a list of (/key/,/value/) pairs.+--+-- > lookup_m "k" (event [("k",1)]) == Just 1+event :: [(Key,Value)] -> Event+event l =+    Event {e_type = "s_new"+          ,e_id = Nothing+          ,e_instrument = Nothing+          ,e_map = M.fromList l}++-- | 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++-- | 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++-- | Merge two sorted sequence of (/location/,/value/) pairs.+--+-- > 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++-- | Times are real valued @UTC@.+type Time = Double++-- | 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)++-- | Insert /fwd/ 'Key's into a time-stamped 'Event' sequence.+add_fwd :: [(Time,Event)] -> [Event]+add_fwd e =+    case e of+      (t0,e0):(t1,e1):e' ->+          insert "fwd'" (t1 - t0) e0 : 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)++-- | Generate @SC3@ 'O.OSC' messages describing 'Event'.  If the+-- 'Event' 'Type' has a @_p@ suffix, where @p@ stands for /persist/,+-- this does not generate a gate command.+to_sc3_osc :: Time -> Int -> Event -> Maybe (O.OSC,O.OSC)+to_sc3_osc t j e =+    let s = instrument_name e+        rt = sustain e {- rt = release time -}+        f = freq e+        pr = ("freq",f) : ("amp",amp e) : ("sustain",rt) : parameters e+        i = fromMaybe j (e_id e)+    in if isNaN f+       then Nothing+       else let m_on = case e_type e of+                         "s_new" -> [S.s_new s i S.AddToTail 1 pr]+                         "s_new_p" -> [S.s_new s i S.AddToTail 1 pr]+                         "n_set" -> [S.n_set i pr]+                         "n_set_p" -> [S.n_set i pr]+                         "rest" -> []+                         _ -> error "to_sc3_osc:m_on:type"+                m_off = case e_type e of+                         "s_new" -> [S.n_set i [("gate",0)]]+                         "s_new_p" -> []+                         "n_set" -> [S.n_set i [("gate",0)]]+                         "n_set_p" -> []+                         "rest" -> []+                         _ -> error "to_sc3_osc:m_off:type"+            in Just (O.Bundle (O.UTCr t) m_on+                    ,O.Bundle (O.UTCr (t+rt)) m_off)

@@ -0,0 +1,23 @@+-- | An instrument abstraction and a /default/ instrument for patterns.+module Sound.SC3.Lang.Control.Instrument where++import Sound.SC3.ID++-- | An 'Instrument' is either a 'Synthdef' or the 'String' naming a+-- 'Synthdef'.+data Instrument = InstrumentDef Synthdef+                | InstrumentName String+                  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))

@@ -0,0 +1,171 @@+-- | @SC2@ @OverlapTexture@ related functions.+module Sound.SC3.Lang.Control.OverlapTexture where++import Data.List+import Sound.OpenSoundControl+import Sound.SC3+import Sound.SC3.Lang.Control.Event as E+import Sound.SC3.Lang.Control.Instrument+import Sound.SC3.Lang.Pattern.ID++-- | Make an 'envGen' 'UGen' with 'envLinen'' structure with given+-- /attack/\//delay/ and /sustain/ times.+mk_env :: UGen -> UGen -> UGen+mk_env a s =+    let c = EnvNum 4+        p = envLinen' a s a 1 (c,c,c)+    in envGen KR 1 1 0 1 RemoveSynth p++-- | Apply 'mk_env' envelope to input signal and write to output bus @0@.+with_env' :: UGen -> UGen -> UGen -> UGen+with_env' g a = out 0 . (*) g . mk_env a++-- | Variant of 'with_env'' where envelope parameters are lifted from+-- 'Double' to 'UGen'.+with_env :: (Double,Double) -> UGen -> UGen+with_env (a,s) g = with_env' g (constant a) (constant s)++-- | Control parameters for 'overlapTextureU' and related functions.+type OverlapTexture = (Double,Double,Double,Int)++-- | Extract envelope parameters for 'with_env' from 'OverlapTexture'.+overlapTexture_env :: OverlapTexture -> (Double,Double)+overlapTexture_env (a,s,_,_) = (a,s)++-- | Extract /duration/ and /legato/ paramaters from 'OverlapTexture'.+overlapTexture_dt :: OverlapTexture -> (Double,Double)+overlapTexture_dt (a,s,o,_) = ((a + s + a) / o,o)++-- | Control parameters for 'xfadeTextureU' and related functions.+type XFadeTexture = (Double,Double,Int)++-- | Extract envelope parameters for 'with_env' from 'XFadeTexture'.+xfadeTexture_env :: XFadeTexture -> (Double,Double)+xfadeTexture_env (a,s,_) = (a,s)++-- | Extract /duration/ and /legato/ paramaters from 'XFadeTexture'.+xfadeTexture_dt :: XFadeTexture -> (Double,Double)+xfadeTexture_dt (a,s,_) = let dt = a + s in (dt,(dt + a) / dt)++-- | Generate 'Synthdef' from envelope parameters for 'with_env' and+-- a continuous signal.+gen_synth :: (Double,Double) -> UGen -> Synthdef+gen_synth k g =+  let n = show (hashUGen g)+      g' = with_env k g+  in synthdef n g'++-- | Generate an 'Event' pattern from 'OverlapTexture' control+-- parameters and a continuous signal.+overlapTextureU' :: OverlapTexture -> UGen -> P Event+overlapTextureU' k g =+    let s = gen_synth (overlapTexture_env k) g+        (d,l) = overlapTexture_dt k+        (_,_,_,c) = k+        i = return (InstrumentDef s)+    in pinstr i (pbind [("dur",pn (return d) c),("legato", return l)])++-- | Audition pattern given by 'overlapTextureU''.+overlapTextureU :: OverlapTexture -> UGen -> IO ()+overlapTextureU k = audition . overlapTextureU' k++-- | Generate 'Synthdef' from a signal processing function over the+-- indicated number of channels.+post_process_s :: Int -> (UGen -> UGen) -> Synthdef+post_process_s nc f =+    let i = in' nc AR 0+        u = replaceOut 0 (f i)+        nm = show (hashUGen u)+    in synthdef nm u++-- | Audition 'Event' pattern with specified post-processing function.+post_process_a :: Transport t =>+                  t -> P Event -> Int -> (UGen -> UGen) -> IO ()+post_process_a fd p nc f = do+  let s = post_process_s nc f+  _ <- async fd (d_recv s)+  send fd (s_new (synthdefName s) (-1) AddToTail 2 [])+  play fd p++-- | Variant of 'overlapTextureU' with post-processing stage.+overlapTextureU_pp :: OverlapTexture -> UGen -> Int -> (UGen -> UGen) -> IO ()+overlapTextureU_pp k u nc f = do+  let p = overlapTextureU' k u+  withSC3 (\fd -> post_process_a fd p nc f)++-- | Generate an 'Event' pattern from 'XFadeTexture' control+-- parameters and a continuous signal.+xfadeTextureU' :: XFadeTexture -> UGen -> P Event+xfadeTextureU' k g =+    let s = gen_synth (xfadeTexture_env k) g+        (d,l) = xfadeTexture_dt k+        (_,_,c) = k+        i = return (InstrumentDef s)+    in pinstr i (pbind [("dur",pn (return d) c),("legato", return l)])++-- | Audition pattern given by 'xfadeTextureU''.+xfadeTextureU :: XFadeTexture -> UGen -> IO ()+xfadeTextureU k = audition . xfadeTextureU' k++-- | Variant of 'xfadeTextureU' with post-processing stage.+xfadeTextureU_pp :: XFadeTexture -> UGen -> Int -> (UGen -> UGen) -> IO ()+xfadeTextureU_pp k u nc f = do+  let p = xfadeTextureU' k u+  withSC3 (\fd -> post_process_a fd p nc f)++-- | Variant of 'overlapTextureU'' where the continuous signal for+-- each 'Event' is derived from a state transform function seeded with+-- given initial state.+overlapTextureS' :: OverlapTexture -> (st -> (UGen,st)) -> st -> P Event+overlapTextureS' k u i_st =+    let (d,l) = overlapTexture_dt k+        (_,_,_,c) = k+        g = take c (unfoldr (Just . u) i_st)+        s = map (InstrumentDef . gen_synth (overlapTexture_env k)) g+    in pinstr (fromList s) (pbind [("dur",prepeat d),("legato",prepeat l)])++-- | Audition pattern given by 'overlapTextureS''.+overlapTextureS :: OverlapTexture -> (st -> (UGen,st)) -> st -> IO ()+overlapTextureS k u = audition . overlapTextureS' k u++-- | Variant of 'overlapTextureS' with post-processing stage.+overlapTextureS_pp :: OverlapTexture -> (st -> (UGen,st)) -> st -> Int -> (UGen -> UGen) -> IO ()+overlapTextureS_pp k u i_st nc f = do+  let p = overlapTextureS' k u i_st+  withSC3 (\fd -> post_process_a fd p nc f)++-- | Run a state transforming function /f/ that also operates with a+-- delta 'E.Time' indicating the duration to pause before re-running+-- the function.+at' :: st -> Double -> ((st,E.Time) -> IO (Maybe (st,E.Time))) -> IO ()+at' st t f = do+  r <- f (st,t)+  case r of+    Just (st',t') -> do pauseThreadUntil (t + t')+                        at' st' (t + t') f+    Nothing -> return ()++-- | Variant of 'at'' that pauses until initial 'E.Time'.+at :: st -> E.Time -> ((st,E.Time) -> IO (Maybe (st,E.Time))) -> IO ()+at st t f = do+  pauseThreadUntil t+  _ <- at' st t f+  return ()++-- | Underlying function of 'overlapTextureM' with explicit 'Transport'.+overlapTextureM' :: Transport t => t -> OverlapTexture -> IO UGen -> IO ()+overlapTextureM' fd k u = do+  t <- utcr+  let n = "ot_" ++ show t+      (dt,_) = overlapTexture_dt k+      (_,_,_,c) = k+      f (st,_) = do g <- u+                    let g' = with_env (overlapTexture_env k) g+                    _ <- async fd (d_recv (synthdef n g'))+                    send fd (s_new n (-1) AddToTail 1 [])+                    if st == 0 then return Nothing else return (Just (st-1,dt))+  at c t f++-- | Variant of 'overlapTextureU' where the continuous signal is in the 'IO' monad.+overlapTextureM :: OverlapTexture -> IO UGen -> IO ()+overlapTextureM k u = withSC3 (\fd -> overlapTextureM' fd k u)

@@ -0,0 +1,136 @@+-- | @SC3@ pitch model implementation.+module Sound.SC3.Lang.Control.Pitch where++-- | 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.+--+-- The haskell variant implements 'Pitch' as a labeled data type, with+-- a default value such that scale degree 5 is the A above middle C.+--+-- > freq (defaultPitch {degree = 5}) == 440+--+-- The note is given as a degree, with a modal transposition, indexing+-- 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+-- root, octave and gamut transpositions.+--+-- The frequency is derived by a chromatic transposition of the+-- midinote, with a harmonic multiplier.+--+-- > let {p = defaultPitch+-- >     ;n = p {stepsPerOctave = 12+-- >            ,scale = [0,2,4,5,7,9,11]+-- >            ,degree = 0+-- >            ,mtranspose = 5}+-- >     ;m = n {root = 0+-- >            ,octave = 5+-- >            ,gtranspose = 0}+-- >     ;f = m {ctranspose = 0+-- >            ,harmonic = 1}}+-- > in (note n,midinote m,freq f) == (9,69,440)+--+-- By editing the values of aspects of a pitch, processes can+-- cooperate.  Below one process controls the note by editing the+-- modal transposition, a second edits the octave.+--+-- > 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)))++-- | 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+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+          }++-- | 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 d (scale e) (stepsPerOctave e)++-- | Translate degree, scale and steps per octave to key.+--+-- > degree_to_key 5 [0,2,4,5,7,9,11] 12 == 9+degree_to_key :: (RealFrac a) => a -> [a] -> a -> a+degree_to_key d s n =+    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.+--+-- > note (defaultPitch {degree = 5}) == 9+note :: Pitch a -> a+note e = note_f e e++-- | The midi note value of the pitch model.+--+-- > midinote (defaultPitch {degree = 5}) == 69+midinote :: Pitch a -> a+midinote e = midinote_f e e++-- | 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++-- | 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

@@ -0,0 +1,198 @@+-- | Data set giving formant locations for 'Vowel's.+module Sound.SC3.Lang.Data.Vowel where++import Data.List+import Data.Maybe++-- * Lookup functions++-- | Extract 'Fn'th formant triple of an 'Fdata'.+--+-- > formant F1 (fdata Bass I) == (1750,-30,90)+formant :: Num n => Fn -> Fdata n -> (n,n,n)+formant n v = formants v !! fromEnum n++-- | Lookup formant 'Fdata' given 'Voice' and 'Vowel'.+--+-- > fdata Bass I == (Bass,I,[250,1750,2600,3050,3340]+-- >                        ,[0,-30,-16,-22,-28]+-- >                        ,[60,90,100,120,120])+fdata :: Num n => Voice -> Vowel -> Fdata n+fdata v i =+    let f (p,q,_,_,_) = p == v && q == i+    in fromMaybe (error "fdata") (find f fdata_table)++-- | Formant triples of an 'Fdata'.+--+-- > formants (fdata Bass I) == [(250,0,60)+-- >                            ,(1750,-30,90)+-- >                            ,(2600,-16,100)+-- >                            ,(3050,-22,120)+-- >                            ,(3340,-28,120)]+formants :: Num n => Fdata n -> [(n,n,n)]+formants (_,_,f,a,bw) = map triple' (transpose [f,a,bw])++-- * Data types++-- | Enumeration of voices.+data Voice = Soprano | Alto | CounterTenor | Tenor | Bass+           deriving (Enum,Bounded,Eq,Read,Show)++-- | Enumeration of vowels.+data Vowel = A | E | I | O | U+             deriving (Enum,Bounded,Eq,Read,Show)++-- | Vowel tuple of form ('Voice','Vowel',/freq/,/db/,/bw/).+type Fdata n = (Voice,Vowel,[n],[n],[n])++-- | Enumeration of formant indices.+data Fn = F0 | F1 | F2 | F3 | F4+        deriving (Enum,Bounded,Eq,Read,Show)++-- * Table++-- | 'Fdata' table.+fdata_table :: Num n => [Fdata n]+fdata_table =+    [(Soprano+     ,A+     ,[800,1150,2900,3900,4950]+     ,[0,-6,-32,-20,-50]+     ,[80,90,120,130,140])+    ,(Soprano+     ,E+     ,[350,2000,2800,3600,4950]+     ,[0,-20,-15,-40,-56]+     ,[60,100,120,150,200])+    ,(Soprano+     ,I+     ,[270,2140,2950,3900,4950]+     ,[0,-12,-26,-26,-44]+     ,[60,90,100,120,120])+    ,(Soprano+     ,O+     ,[450,800,2830,3800,4950]+     ,[0,-11,-22,-22,-50]+     ,[70,80,100,130,135])+    ,(Soprano+     ,U+     ,[325,700,2700,3800,4950]+     ,[0,-16,-35,-40,-60]+     ,[50,60,170,180,200])+    ,(Alto+     ,A+     ,[800,1150,2800,3500,4950]+     ,[0,-4  ,-20,-36,-60]+     ,[80,90,120,130,140])+    ,(Alto+     ,E+     ,[400,1600,2700,3300,4950]+     ,[0,-24,-30,-35,-60]+     ,[60,80,120,150,200])+    ,(Alto+     ,I+     ,[350,1700,2700,3700,4950]+     ,[0,-20,-30,-36,-60]+     ,[50,100,120,150,200])+    ,(Alto+     ,O+     ,[450,800,2830,3500,4950]+     ,[0,-9  ,-16,-28,-55]+     ,[70,80,100,130,135])+    ,(Alto+     ,U+     ,[325,700,2530,3500,4950]+     ,[0,-12,-30,-40,-64]+     ,[50,60,170,180,200])+    ,(CounterTenor+     ,A+     ,[660,1120,2750,3000,3350]+     ,[0,-6  ,-23,-24,-38]+     ,[80,90,120,130,140])+    ,(CounterTenor+     ,E+     ,[440,1800,2700,3000,3300]+     ,[0,-14,-18,-20,-20]+     ,[70,80,100,120,120])+    ,(CounterTenor+     ,I+     ,[270,1850,2900,3350,3590]+     ,[0,-24,-24,-36,-36]+     ,[40,90,100,120,120])+    ,(CounterTenor+     ,O+     ,[430,820,2700,3000,3300]+     ,[0,-10,-26,-22,-34]+     ,[40,80,100,120,120])+    ,(CounterTenor+     ,U+     ,[370,630,2750,3000,3400]+     ,[0,-20,-23,-30,-34]+     ,[40,60,100,120,120])+    ,(Tenor+     ,A+     ,[650,1080,2650,2900,3250]+     ,[0,-6   ,-7  ,-8,-22]+     ,[80,90,120,130,140])+    ,(Tenor+     ,E+     ,[400,1700,2600,3200,3580]+     ,[0,-14,-12,-14,-20]+     ,[70,80,100,120,120])+    ,(Tenor+     ,I+     ,[290,1870,2800,3250,3540]+     ,[0,-15,-18,-20,-30]+     ,[40,90,100,120,120])+    ,(Tenor+     ,O+     ,[400,800,2600,2800,3000]+     ,[0,-10,-12,-12,-26]+     ,[40,80,100,120,120])+    ,(Tenor+     ,U+     ,[350,600,2700,2900,3300]+     ,[0,-20,-17,-14,-26]+     ,[40,60,100,120,120])+    ,(Bass+     ,A+     ,[600,1040,2250,2450,2750]+     ,[0,-7   ,-9  ,-9,-20]+     ,[60,70,110,120,130])+    ,(Bass+     ,E+     ,[400,1620,2400,2800,3100]+     ,[0,-12  ,-9,-12,-18]+     ,[40,80,100,120,120])+    ,(Bass+     ,I+     ,[250,1750,2600,3050,3340]+     ,[0,-30,-16,-22,-28]+     ,[60,90,100,120,120])+    ,(Bass+     ,O+     ,[400,750,2400,2600,2900]+     ,[0,-11,-21,-20,-40]+     ,[40,80,100,120,120])+    ,(Bass+     ,U+     ,[350,600,2400,2675,2950]+     ,[0,-20,-32,-28,-36]+     ,[40,80,100,120,120])]++-- * Tuple/List functions++-- | Construct a triple from a three element list.+--+-- > triple [1..3] == Just (1,2,3)+triple :: [a] -> Maybe (a,a,a)+triple x =+    case x of+      [p,q,r] -> Just (p,q,r)+      _ -> Nothing++-- | Partial variant of 'triple'.+--+-- > triple' [1..3] == (1,2,3)+triple' :: [a] -> (a,a,a)+triple' = fromJust . triple

@@ -0,0 +1,57 @@+-- | @sclang@ math functions.+module Sound.SC3.Lang.Math where++import Data.Bits++-- * 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 :: Bits a => String -> a+parseBits x =+    let x' = filter (id . bitChar . snd) (zip [0..] (reverse x))+    in foldr ((.|.) . bit . fst) 0 x'++-- * SimpleNumber++-- | Variant of @SimpleNumber.exprand@ that shifts a linear (0,1)+-- value to an exponential distribution.+--+-- > 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)++-- | Psuedo-inifite bounded value.+--+-- > inf == maxBound+inf :: Bounded a => a+inf = maxBound++-- | Predicate for 'inf'.+--+-- > isInf inf == True+isInf :: (Eq a,Bounded a) => a -> Bool+isInf = (== inf)++-- | @SimpleNumber.linexp@ shifts from linear to exponential ranges.+--+-- > 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 =+    if n <= l+    then l'+    else if n >= r+         then r'+         else ((r'/l') ** ((n-l)/(r-l))) * l'

@@ -1,67 +0,0 @@-module Sound.SC3.Lang.Math.Pitch where--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_cps :: (Floating a) => a -> a-midi_cps a = 440.0 * (2.0 ** ((a - 69.0) * (1.0 / 12.0)))--defaultPitch :: (Floating a, RealFrac a) => Pitch a-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-          }--default_freq_f :: (Floating a) => Pitch a -> a-default_freq_f e = midi_cps (midinote e + ctranspose e) * harmonic e--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--default_note_f :: (RealFrac a) => Pitch a -> a-default_note_f e =-    let d = degree e + mtranspose e-    in degree_to_key d (scale e) (stepsPerOctave e)--degree_to_key :: (RealFrac a) => a -> [a] -> a -> a-degree_to_key d s n =-    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--note :: Pitch a -> a-note e = note_f e e--midinote :: Pitch a -> a-midinote e = midinote_f e e--freq :: Pitch a -> a-freq e = freq_f e e--detunedFreq :: (Num a) => Pitch a -> a-detunedFreq e = freq e + detune e

@@ -0,0 +1,1102 @@+{-# Language FlexibleInstances #-}+-- | @sclang@ pattern library functions.+-- See <http://slavepianos.org/rd/?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.OpenSoundControl+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.+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 L.any (== Stop) 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 if null x'+       then C.extension (map F.toList x)+       else C.extension (map F.toList 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 = fmap (const ())+        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 = fmap (const ())+        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 = fmap (const ())+        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 "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.+pdegreeToKey :: (RealFrac a) => P a -> P [a] -> P a -> P a+pdegreeToKey = pzipWith3 P.degree_to_key++-- | 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 -> P E.Event -> P E.Event+pinstr_s p = pinstr (fmap I.InstrumentName p)++-- | Variant of 'pinstr' which lifts the 'Synthdef' pattern to an+-- 'I.Instrument' pattern.+pinstr_d :: P Synthdef -> P E.Event -> P E.Event+pinstr_d p = pinstr (fmap 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 ->+                   let nm = synthdefName d+                   in i : repeat (I.InstrumentName nm)+               I.InstrumentName _ -> repeat i+        ty = "s_new_p" : repeat "n_set_p"+    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 s = pmono (I.InstrumentDef s)++-- | Variant of 'pmono' that lifts 'String' to 'I.Instrument'.+pmono_s :: String -> Int -> [(E.Key,P E.Value)] -> P E.Event+pmono_s s = pmono (I.InstrumentName s)++-- | 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 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 t => t -> E.Time -> Int -> E.Event -> IO ()+e_send fd t j e =+    case E.to_sc3_osc t j e of+      Just (p,q) -> do case E.instrument_def e of+                         Just d -> async fd (d_recv d) >> return ()+                         Nothing -> return ()+                       send fd p+                       send fd 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 t) => t -> E.Time -> [Int] -> [E.Event] -> IO ()+e_tplay fd 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 fd t i d+                        pauseThreadUntil t'+                        e_tplay fd t' j' e'++-- | Variant of 'e_tplay' with current clock time from 'utcr' as start+-- time.  This function is used to implement the pattern instances of+-- 'Audible'.+e_play :: (Transport t) => t -> [Int] -> [E.Event] -> IO ()+e_play fd lj le = do+  st <- utcr+  e_tplay fd st lj le++instance Audible (P E.Event) where+    play fd = e_play fd [1000..] . unP++instance Audible (Synthdef,P E.Event) where+    play fd (s,p) = do+      let i_d = I.InstrumentDef s+          i_nm = I.InstrumentName (synthdefName s)+          i = pcons i_d (pn (return i_nm) inf)+      _ <- async fd (d_recv s)+      e_play fd [1000..] (unP (pinstr i p))++instance Audible (String,P E.Event) where+    play fd (s,p) =+        let i = I.InstrumentName s+        in e_play fd [1000..] (unP (pinstr (return i) p))+

@@ -1,335 +1,166 @@+-- | List variants of @SC3@ pattern functions. module Sound.SC3.Lang.Pattern.List where -import qualified Control.Applicative as A-import qualified Control.Monad as M-import qualified Data.Array as A-import qualified Data.Foldable as F-import qualified Data.HashTable as H-import qualified Data.List as L-import qualified Data.Monoid as M-import qualified Data.Traversable as T-import qualified Sound.SC3.Lang.Collection.Collection as S-import qualified Sound.SC3.Lang.Collection.SequenceableCollection as S-import qualified Sound.SC3.Lang.Math.Pitch as S-import qualified System.Random as R+import qualified Data.Map as M+import Data.Maybe+import Data.List+import qualified Sound.SC3 as S+import qualified Sound.SC3.Lang.Collection as C+import qualified Sound.SC3.Lang.Random.Gen as R+import System.Random -data P a = P { unP :: [a] }+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') --- * Instances+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_) -instance A.Alternative P where-    empty = pempty-    (<|>) = pappend+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) -instance A.Applicative P where-    pure = M.return-    (<*>) = M.ap+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 -instance F.Foldable P where-    foldr = pfoldr+ifF :: Bool -> a -> a -> a+ifF x y z = if x then y else z -instance (Fractional a) => Fractional (P a) where-    (/) = pzipWith (/)-    recip = fmap recip-    fromRational = return . fromRational+ifF' :: (Bool,a,a) -> a+ifF' (x,y,z) = if x then y else z -instance Functor P where-    fmap f = P . fmap f . unP+ifTruncating :: [Bool] -> [a] -> [a] -> [a]+ifTruncating  a b c = map ifF' (zip3 a b c) -instance (Eq a) => Eq (P a) where-    (P p) == (P q) = p == q+ifExtending :: [Bool] -> [a] -> [a] -> [a]+ifExtending a b c = map ifF' (C.zip3_c a b c) -instance Monad P where-    m >>= f = pconcatMap f m-    return x = P [x]+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)) -instance M.MonadPlus P where-    mzero = pempty-    mplus = pappend+rorate_n' :: Num a => a -> a -> [a]+rorate_n' p i = [i * p,i * (1 - p)] -instance M.Monoid (P a) where-    mempty = pempty-    mappend = pappend+rorate_n :: Num a => [a] -> [a] -> [a]+rorate_n p = concat . C.zipWith_c rorate_n' p -instance (Num a) => Num (P a) where-    (+) = pzipWith (+)-    (-) = pzipWith (-)-    (*) = pzipWith (*)-    abs = fmap abs-    signum = fmap signum-    fromInteger = return . fromInteger-    negate = fmap negate+rorate_l' :: Num a => [a] -> a -> [a]+rorate_l' p i = map (* i) p -instance (Show a) => Show (P a) where-    show = show . unP+rorate_l :: Num a => [[a]] -> [a] -> [a]+rorate_l p = concat . C.zipWith_c rorate_l' p -instance T.Traversable P where-    traverse f = let cons_f x ys = pcons A.<$> f x A.<*> ys-                 in pfoldr cons_f (A.pure pempty)+segment :: [a] -> Int -> (Int,Int) -> [a]+segment a k (l,r) =+    let i = map (S.genericWrap 0 k) [l .. r]+    in map (a !!) i --- * Basic constructors+slide :: [a] -> Int -> Int -> Int -> Int -> Bool -> [a]+slide a n j s i wr =+    let k = length a+        l = enumFromThen i (i + s)+        r = map (+ (j - 1)) l+    in if wr+       then concat (take n (map (segment a k) (zip l r)))+       else error "slide: non-wrap variant not implemented" -pinf :: P Int-pinf = return 83886028 -- 2 ^^ 23+stutterTruncating :: [Int] -> [a] -> [a]+stutterTruncating ns = concat . zipWith replicate ns --- * List functions+stutterExtending :: [Int] -> [a] -> [a]+stutterExtending ns = concat . C.zipWith_c replicate ns -bool :: (Functor f, Ord a, Num a) => f a -> f Bool-bool = fmap (> 0)+switch :: [[a]] -> [Int] -> [a]+switch l i = i >>= (l !!) -clutch :: [a] -> [Bool] -> [a]-clutch p q =-    let r = fmap (+ 1) (countpost q)-    in stutter r p+switch1 :: [[a]] -> [Int] -> [a]+switch1 ps =+    let go _ [] = []+        go m (i:is) = 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))) --- | Count false values following each true value.+white' :: (Enum e,Random n) => e -> [n] -> [n] -> [n]+white' e l r =+    let g = mkStdGen (fromEnum e)+        n = zip l r+        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)))++wrand' :: (Enum e) =>e -> [[a]] -> [Double] -> [a]+wrand' e a w =+    let f g = let (r,g') = R.wchoose a w g+              in r ++ f g'+    in f (mkStdGen (fromEnum e))++wrand :: (Enum e) => e -> [[a]] -> [Double] -> Int -> [a]+wrand e a w n = take n (wrand' e a w)++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 [] = [i]-        f i (x:xs) = if not x-                     then f (i + 1) xs-                     else i : f 0 xs+    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 false values preceding each true value. countpre :: [Bool] -> [Int] countpre =-    let f i [] = if i == 0 then [] else [i]-        f i (x:xs) = if x -                     then i : f 0 xs-                     else f (i + 1) xs+    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 [] = p-interleave [] q = q-interleave (p:ps) (q:qs) = p : q : interleave ps qs+interleave p q =+    case (p,q) of+      ([],_) -> q+      (_,[]) -> p+      (x:xs,y:ys) -> x : y : interleave xs ys --- | Remove successive duplicates. rsd :: (Eq a) => [a] -> [a] rsd =-    let f _ [] = []-        f Nothing (x:xs) = x : f (Just x) xs-        f (Just y) (x:xs) = if x == y-                            then f (Just x) xs-                            else x : f (Just x) xs-    in f Nothing--stutter :: [Int] -> [a] -> [a]-stutter [] _ = []-stutter _ [] = []-stutter (n:ns) (p:ps) = replicate n p ++ stutter ns ps+    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 (zipWith f r q)---- * Pattern functions--pappend :: P a -> P a -> P a-pappend p q = P (unP p ++ unP q)--papply :: P (a -> b) -> P a -> P b-papply (P f) (P x) = P (f A.<*> x)--pbool :: (Ord a, Num a) => P a -> P Bool-pbool = bool--pclutch :: P a -> P Bool -> P a-pclutch (P x) (P c) = P (clutch x c)--pcollect :: (a -> b) -> P a -> P b-pcollect = fmap--pcountpost :: P Bool -> P Int-pcountpost = P . countpost . unP--pcountpre :: P Bool -> P Int-pcountpre = P . countpre . unP--pconcat :: P (P a) -> P a-pconcat p =-    if pnull p-    then pempty-    else case phead p of-           Nothing -> pempty-           Just x -> x `pappend` (pconcat (ptail p))--pconcatMap :: (b -> P a) -> P b -> P a-pconcatMap f = pconcat . fmap f--pcons :: a -> P a -> P a-pcons x = P . (x:) . unP--pcycle :: P a -> P a-pcycle = P . L.cycle . unP--pdegreeToKey :: (RealFrac a) => P a -> P [a] -> P a -> P a-pdegreeToKey = pzipWith3 S.degree_to_key--pdrop :: P Int -> P a -> P a-pdrop n =-    case phead n of-      Nothing -> error "pdrop"-      Just n' -> P . L.drop n' . unP--pempty :: P a-pempty = P []--pfilter :: (a -> Bool) -> P a -> P a-pfilter f = P . L.filter f . unP--pfin :: P Int -> P a -> P a-pfin = ptake--pfoldr :: (a -> b -> b) -> b -> P a -> b-pfoldr f x = L.foldr f x . unP--pgeom :: (Num a) => a -> a -> Int -> P a-pgeom i s n = P (S.geom n i s)--phead :: P a -> Maybe a-phead (P []) = Nothing-phead (P (x:_)) = Just x--pinterleave :: P a -> P a -> P a-pinterleave (P p) (P q) = P (interleave p q)--pn :: P a -> P Int -> P a-pn (P p) n =-    let f 0 _ = []-        f i xs = xs ++ f (i - 1) xs-    in case phead n of-         Nothing -> error "preplicate"-         Just x -> P (f x p)--pnull :: P a -> Bool-pnull = L.null . unP--prepeat :: a -> P a-prepeat = P . L.repeat--preject :: (a -> Bool) -> P a -> P a-preject f =-    let g i _ = f i-    in P . S.reject g . unP--prsd :: (Eq a) => P a -> P a-prsd = P . rsd . unP--pseq :: [P a] -> P Int -> P a-pseq ps n =-    case phead n of-      Nothing -> error "pseq: empty repeat pattern"-      Just n' -> let ps' = concat (replicate n' ps)-                 in L.foldr pappend pempty ps'--pser :: [P a] -> P Int -> P a-pser ps n = ptake n (pseq ps pinf)--pseries :: (Num a) => a -> a -> Int -> P a-pseries i s n = P (S.series n i s)--pstutter :: P Int -> P a -> P a-pstutter (P n) (P p) = P (stutter n p)--pswitch :: [P a] -> P Int -> P a-pswitch l i = i >>= (l !!)--pswitch1 :: [P a] -> P Int -> P a-pswitch1 ps i =-    case phead i of-      Nothing -> pempty-      Just i' -> let (l, r) = splitAt i' ps-                     (p:_) = r-                     x = phead p-                     j = ptail i-                 in case x of-                      Nothing -> pswitch1 ps j-                      Just x' -> let ps' = l ++ [ptail p] ++ tail r-                                 in x' `pcons` pswitch1 ps' j--ptail :: P a -> P a-ptail =-    let f [] = []-        f (_:xs) = xs-    in P . f . unP--ptake :: P Int -> P a -> P a-ptake n =-    case phead n of-      Nothing -> error "ptake: empty length pattern"-      Just n' -> P . L.take n' . unP--ptrigger :: P Bool -> P a -> P (Maybe a)-ptrigger (P p) (P q) = P (trigger p q)--pzip :: P a -> P b -> P (a, b)-pzip (P p) (P q) = P (zip p q)--pzip3 :: P a -> P b -> P c -> P (a, b, c)-pzip3 (P p) (P q) (P r) = P (zip3 p q r)--pzipWith :: (a -> b -> c) -> P a -> P b -> P c-pzipWith f (P p) (P q) = P (L.zipWith f p q)--pzipWith3 :: (a -> b -> c -> d) -> P a -> P b -> P c -> P d-pzipWith3 f (P p) (P q) (P r) = P (L.zipWith3 f p q r)---- * Random patterns--choosea :: R.StdGen -> A.Array Int a -> [a]-choosea g r = -    let (i, g') = R.randomR (A.bounds r) g-        x = r A.! i-    in x : choosea g' r--pchoose :: String -> P a -> P a-pchoose s (P p) = -    let g = R.mkStdGen (fromIntegral (H.hashString s))-    in P (choosea g (A.listArray (0, length p - 1) p))--pnoise :: (R.Random a) => String -> P a-pnoise s =-    let g = R.mkStdGen (fromIntegral (H.hashString s))-    in P (R.randoms g)--prand :: String -> [P a] -> P Int -> P a-prand s ps n = -    case phead n of-      Nothing -> error "prand"-      Just n' -> let g = R.mkStdGen (fromIntegral (H.hashString s))-                     qs = choosea g (A.listArray (0, length ps - 1) ps)-                 in L.foldr pappend pempty (take n' qs)--prand_b :: (R.Random a) => R.StdGen -> P (a,a) -> P a-prand_b g b =-    case phead b of-      Nothing -> pempty-      Just b' -> let (x, g') = R.randomR b' g-                 in pcons x (prand_b g' (ptail b))--pwhite :: (R.Random a) => String -> P a -> P  a -> P a-pwhite s l r =-    let b = pzip (pcycle l) (pcycle r)-        g = R.mkStdGen (fromIntegral (H.hashString s))-    in prand_b g b---- * Extension--pzipWith_c :: (a -> b -> c) -> P a -> P b -> P c-pzipWith_c f p = pzipWith f p . pcycle--(+.) :: Num a => P a -> P a -> P a-(+.) = pzipWith_c (+)--(*.) :: Num a => P a -> P a -> P a-(*.) = pzipWith_c (*)--(/.) :: Fractional a => P a -> P a -> P a-(/.) = pzipWith_c (/)+    in concat (C.zipWith_c f r q) -(-.) :: Num a => P a -> P a -> P a-(-.) = pzipWith_c (-)

@@ -1,440 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}--module Sound.SC3.Lang.Pattern.Step where--import qualified Control.Applicative as A-import qualified Control.Monad as M-import qualified Data.Array as A-import qualified Data.HashTable as H-import qualified Data.IntMap as M-import qualified Data.List as L-import qualified Data.Maybe as M-import qualified Data.Monoid as M-import qualified Sound.SC3.Lang.Math.Pitch as S-import qualified System.Random as R--data P s a-    = Empty-    | Value a-    | RP (s -> (P s a, s))-    | Append (P s a) (P s a)-    | forall x . Unfoldr (x -> Maybe (a, x)) x-    | forall x . Continue (P s x) (x -> P s x -> P s a)-    | forall x . Apply (P s (x -> a)) (P s x)-    | forall x y . Scan (x -> y -> (x, a)) (Maybe (x -> a)) x (P s y)--data Result s a -    = Result s a (P s a)-    | Done s--step :: s -> P s a -> Result s a-step g Empty = Done g-step g (Value a) = Result g a M.mempty-step g (RP f) =-    let (p, g') = f g-    in step g' p-step g (Append x y) =-    case step g x of-      Done g' -> step g' y-      Result g' a x' -> Result g' a (Append x' y)-step g (Continue p f) =-    case step g p of-      Done g' -> Done g'-      Result g' x p' -> step g' (f x p')-step g (Unfoldr f x) =-    let y = f x-    in case y of-         Nothing -> Done g-         Just (a, x') -> Result g a (Unfoldr f x')-step g (Apply p q) =-    case step g p of-      Done g' -> Done g'-      Result g' f p' -> case step g' q of-                          Done g'' -> Done g''-                          Result g'' x q' -> Result g'' (f x) (Apply p' q')-step g (Scan f f' i p) =-    case step g p of-      Done g' -> case f' of-                   Just h -> Result g' (h i) Empty-                   Nothing -> Done g'-      Result g' a p' -> let (j, x) = f i a-                        in Result g' x (Scan f f' j p')--runP :: Monad m =>-        s -> ((a, s) -> m s) -> (b -> a -> b) -> b -> P s a -> m b-runP s u f i p = do-  case step s p of-    Done _ -> return i-    Result s' a p' -> do s'' <- u (a, s')-                         runP s'' u f (f i a) p'--pfoldr' :: s -> (a -> b -> b) -> b -> P s a -> b-pfoldr' g f i p =-    case step g p of-      Done _ -> i-      Result g' a p' -> f a (pfoldr' g' f i p')--evalP :: P () a -> [a]-evalP = pfoldr' () (:) []--evalR :: String -> P R.StdGen a -> [a]-evalR s =-    let g = R.mkStdGen (fromIntegral (H.hashString s))-    in pfoldr' g (:) []--instance (Show a) => Show (P s a) where-    show _ = show "a pattern"--instance (Eq a) => Eq (P s a) where-    _ == _ = False--instance M.Monad (P s) where-    (>>=) p f = Continue p (\x q -> f x `M.mappend` (>>=) q f)-    return = Value--instance M.MonadPlus (P s) where-    mzero = Empty-    mplus = Append--instance M.Monoid (P s a) where-    mempty = Empty-    mappend = Append---- | Apply `f' pointwise to elements of `p' and `q'.-pzipWith :: (a -> b -> c) -> P s a -> P s b -> P s c-pzipWith f p = (A.<*>) (A.pure f A.<*> p)--instance (Num a) => Num (P s a) where-    (+) = pzipWith (+)-    (-) = pzipWith (-)-    (*) = pzipWith (*)-    abs = fmap abs-    signum = fmap signum-    fromInteger = return . fromInteger-    negate = fmap negate--instance (Fractional a) => Fractional (P s a) where-    (/) = pzipWith (/)-    recip = fmap recip-    fromRational = return . fromRational--pcycle :: P s a -> P s a-pcycle x = x `M.mappend` pcycle x--prepeat :: a -> P s a-prepeat = pcycle . return--instance Functor (P a) where-    fmap = (A.<*>) . prepeat--instance A.Applicative (P s) where-    pure = prepeat-    (<*>) = Apply--instance A.Alternative (P s) where-    empty = Empty-    (<|>) = Append---- * Basic constructors--prp :: (s -> (P s a, s)) -> P s a-prp = RP--pinf :: P s Int-pinf = return 83886028 -- 2 ^^ 23--pcontinue :: P s x -> (x -> P s x -> P s a) -> P s a-pcontinue = Continue--pscan :: (x -> y -> (x, a)) -> Maybe (x -> a) -> x -> P s y -> P s a-pscan = Scan--punfoldr :: (x -> Maybe (a, x)) -> x -> P s a-punfoldr = Unfoldr---- * Control--pfilter :: (a -> Bool) -> P s a -> P s a-pfilter f p =-    let g x p' = if f x-                 then M.mappend (return x) (pfilter f p')-                 else pfilter f p'-    in pcontinue p g--plist :: [P s a] -> P s a-plist = foldr M.mappend M.mempty--pcons :: a -> P s a -> P s a-pcons = M.mappend . return--preplicate_ :: Int -> P s a -> P s a-preplicate_ n p | n > 0 = M.mappend p (preplicate_ (n - 1) p)-                | otherwise = M.mempty--preplicate :: P s Int -> P s a -> P s a-preplicate n p = n >>= (\x -> preplicate_ x p)--pn :: P s a -> P s Int -> P s a-pn = flip preplicate--pn_ :: P s a -> Int -> P s a-pn_ = flip preplicate_---- | 'n' initial values at 'p'.-ptake_ :: Int -> P s a -> P s a-ptake_ n p =-    let e = error "ptake_"-    in pzipWith const p (preplicate_ n (return e))--ptake :: P s Int -> P s a -> P s a-ptake n p =-    let e = error "ptake"-    in pzipWith const p (preplicate n (return e))---- | 'n' initial values at pcycle of 'p'.-prestrict_ :: Int -> P s a -> P s a-prestrict_ n = ptake_ n . pcycle--prestrict :: P s Int -> P s a -> P s a-prestrict n = ptake n . pcycle--pmapMaybe :: (a -> Maybe b) -> P s a -> P s b-pmapMaybe f = fmap M.fromJust . pfilter M.isJust . fmap f--preject :: (a -> Bool) -> P s a -> P s a-preject f = pfilter (not . f)--pzipWith3 :: (a -> b -> c -> d) -> P s a -> P s b -> P s c -> P s d-pzipWith3 f p q = (A.<*>) (A.pure f A.<*> p A.<*> q)--pzipWith4 :: (a -> b -> c -> d -> e) -> -             P s a -> P s b -> P s c -> P s d -> P s e-pzipWith4 f p q r = (A.<*>) (A.pure f A.<*> p A.<*> q  A.<*> r)--pzip :: P s a -> P s b -> P s (a,b)-pzip = pzipWith (,)--pzip3 :: P s a -> P s b -> P s c -> P s (a,b,c)-pzip3 = pzipWith3 (,,)--pzip4 :: P s a -> P s b -> P s c -> P s d -> P s (a,b,c,d)-pzip4 = pzipWith4 (,,,)--pseries :: (Num a) => a -> a -> Int -> P s a-pseries i s n =-    let f (_, 0) = Nothing-        f (j, m) = Just (return j, (j + s, m - 1))-    in plist (L.unfoldr f (i, n))--pgeom :: (Num a) => a -> a -> Int -> P s a-pgeom i s n =-    let f (_, 0) = Nothing-        f (j, m) = Just (return j, (j * s, m - 1))-    in plist (L.unfoldr f (i, n))--pstutter' :: P s Int -> P s a -> P s a-pstutter' n p =-    let f :: Int -> a -> P s a-        f i e = preplicate (return i) (return e)-    in psequence (pzipWith f n p)--pstutter :: P s Int -> P s a -> P s a-pstutter = pstutter' . pcycle---- | Count false values preceding each true value.-pcountpre :: P s Bool -> P s Int-pcountpre p =-    let f x e = if e then (0, Just x) else (x + 1, Nothing)-    in pmapMaybe id (pscan f Nothing 0 p)---- | Count false values following each true value.-pcountpost :: P s Bool -> P s Int-pcountpost p =-    let f x e = if e then (0, Just x) else (x + 1, Nothing)-    in ptail (pmapMaybe id (pscan f (Just Just) 0 p))--pclutch' :: P s a -> P s Bool -> P s a-pclutch' p q =-    let r = fmap (+ 1) (pcountpost q)-    in pstutter' r p--pbool :: (Ord a, Num a) => P s a -> P s Bool-pbool = fmap (> 0)--pclutch :: (Num b, Ord b) => P s a -> P s b -> P s a-pclutch p = pclutch' p . pbool--pcollect :: (a -> b) -> P s a -> P s b-pcollect = fmap--pdegreeToKey :: (RealFrac a) => P s a -> P s [a] -> P s a -> P s a-pdegreeToKey = pzipWith3 S.degree_to_key--pfin :: P s Int -> P s a -> P s a-pfin = ptake--pfin_ :: Int -> P s a -> P s a-pfin_ = ptake_--wrap :: (Ord a, Num a) => a -> a -> a -> a-wrap l r x = if x > r-             then wrap l r (x - (r - l))-             else if x < l-                  then wrap l r (x + (r - l))-                  else x--pwrap :: (Ord a, Num a) => P s a -> P s a -> P s a -> P s a-pwrap x l r =-    let f x' l' r' = wrap l' r' x'-    in pzipWith3 f x (pcycle l) (pcycle r)---- | Remove successive duplicates.-prsd :: (Eq a) => P s a -> P s a-prsd p =-    let f Nothing a = (Just a, Just a)-        f (Just x) a = (Just a, if a == x then Nothing else Just a)-    in pmapMaybe id (pscan f Nothing Nothing p)--psequence :: P s (P s a) -> P s a-psequence = M.join--pduple :: (a, a) -> P s a-pduple (x, y) = return x `M.mappend` return y--pinterleave :: P s a -> P s a -> P s a-pinterleave p = psequence . fmap pduple . pzip p--ptrigger :: P s Bool -> P s a -> P s (Maybe a)-ptrigger p q =-    let r = pcountpre p-        f i = M.mappend (preplicate_ i (return Nothing)) . return . Just-    in M.join (pzipWith f r q)--pif :: P s Bool -> P s a -> P s a -> P s a-pif b p q =-    let f (x, y) True = ((ptail x, y), phead x)-        f (x, y) False = ((x, ptail y), phead y)-    in psequence (pscan f Nothing (p,q) b)--phead :: P s a -> P s a-phead p = pcontinue p (\x _ -> return x)--ptail :: P s a -> P s a-ptail p = pcontinue p (\_ p' -> p')--pdrop :: P s Int -> P s a -> P s a-pdrop n p = n >>= (\x -> if x > 0-                         then pdrop (return (x-1)) (ptail p)-                         else p)--pscanl :: (a -> y -> a) -> a -> P s y -> P s a-pscanl f i p =-    let g x y = let r = f x y in (r, r)-    in pcons i (pscan g Nothing i p)---- * Random numbers--prrandf :: (R.RandomGen s, R.Random a) => -           (a -> a -> a -> a) -> a -> a -> P s a-prrandf f l r = prp (\g -> let (x, g') = R.randomR (l,r) g-                           in (return (f l r x), g'))--prrand :: (R.RandomGen s, R.Random a) => -          a -> a -> P s a-prrand = prrandf (\_ _ x -> x)--prrandexp :: (R.RandomGen s, Floating a, R.Random a) => -             a -> a -> P s a-prrandexp = prrandf (\l r x -> l * (log (r / l) * x))--pchoosea :: (R.RandomGen s) => A.Array Int (P s a) -> P s a-pchoosea r = prp (\g -> let (i, g') = R.randomR (A.bounds r) g -                        in (r A.! i, g'))--pchoose :: R.RandomGen s => [P s a] -> P s a-pchoose l = pchoosea (A.listArray (0, length l - 1) l)--prand :: R.RandomGen s => [P s a] -> P s Int -> P s a-prand p = pseq [pchoose p]--pwhite :: (R.RandomGen s, R.Random a) => -          P s a -> P s a -> P s Int -> P s a-pwhite l r n = prestrict n (M.join (pzipWith prrand l r))--pexprand :: (R.RandomGen s, Floating a, R.Random a) => -            P s a -> P s a -> P s Int -> P s a-pexprand l r n = prestrict n (M.join (pzipWith prrandexp l r))--pxrand :: (R.RandomGen s, Eq a) => [P s a] -> P s Int -> P s a-pxrand p n = ptake n (prsd (pseq [pchoose p] pinf))--pwrand :: R.RandomGen s => [P s a] -> [P s a] -> P s Int -> P s a-pwrand = undefined---- * List--pseq_ :: [P s a] -> Int -> P s a-pseq_ l n = plist (concat (replicate n l))--pseq :: [P s a] -> P s Int -> P s a-pseq l n = n >>= (\x -> plist (concat (replicate x l)))---- | 'n' values from the infinite cycle of the streams at l.-pser_ :: [P s a] -> Int -> P s a-pser_ l n = prestrict_ n (plist l)--pser :: [P s a] -> P s Int -> P s a-pser l n = prestrict n (plist l)--pswitch :: [P s a] -> P s Int -> P s a-pswitch l i = i >>= (l !!)--pswitch1m :: M.IntMap (P s a) -> P s Int -> P s a-pswitch1m m is =-    let f i js = let h = phead (m M.! i)-                     t = ptail (m M.! i)-                 in h `M.mappend` pswitch1m (M.insert i t m) js-    in pcontinue is f--pswitch1 :: [P s a] -> P s Int -> P s a-pswitch1 = pswitch1m . M.fromList . zip [0..]--ppatlace :: [P s a] -> P s Int -> P s a-ppatlace ps n =-    let is = pseq (map return [0 .. length ps - 1]) pinf-    in ptake n (pswitch1 ps is)--{---Neither the definition above or the variant below are correct.-Both deadlock once all patterns are empty.  pswitch1 has the -same problem.  --ppatlacea :: P s (P s a) -> P s a-ppatlacea ps = -    let f p qs = let h = phead p-                     t = ptail p-                     rs = qs `mappend` return t-                 in h `mappend` (ppatlacea rs)-    in pcontinue ps f--}---- * Extend--pzipWith_c :: (a -> b -> c) -> P s a -> P s b -> P s c-pzipWith_c f p = pzipWith f p . pcycle--infixl 7  *., /.-infixl 6  +., -.--(+.) :: Num a => P s a -> P s a -> P s a-(+.) = pzipWith_c (+)--(*.) :: Num a => P s a -> P s a -> P s a-(*.) = pzipWith_c (*)--(/.) :: Fractional a => P s a -> P s a -> P s a-(/.) = pzipWith_c (/)--(-.) :: Num a => P s a -> P s a -> P s a-(-.) = pzipWith_c (-)

@@ -0,0 +1,102 @@+-- | 'RandomGen' based @sclang@ random number functions.+module Sound.SC3.Lang.Random.Gen where++import Data.List+import Data.Maybe+import qualified Sound.SC3.Lang.Collection as C+import qualified Sound.SC3.Lang.Math as M+import System.Random {- random -}+import System.Random.Shuffle {- random-shuffle -}++-- | @SimpleNumber.rand@ is 'randomR' in (0,/n/).+rand :: (RandomGen g,Random n,Num n) => n -> g -> (n,g)+rand n = randomR (0,n)++-- | Construct variant of /f/ generating /k/ values.+kvariant :: Int -> (g->(a,g)) -> g->([a],g)+kvariant k f =+    let go x i g = case i of+                     0 -> (x,g)+                     _ -> let (y,g') = f g+                          in go (y:x) (i - 1) g'+    in go [] k++-- | Variant of 'rand' generating /k/ values.+nrand :: (RandomGen g,Random n,Num n) => Int -> n -> g -> ([n],g)+nrand k = kvariant k . rand++-- | @SimpleNumber.rand2@ is 'randomR' in (-/n/,/n/).+rand2 :: (RandomGen g,Random n,Num n) => n -> g -> (n,g)+rand2 n = randomR (-n,n)++-- | Variant of 'rand2' generating /k/ values.+nrand2 :: (RandomGen g,Random a,Num a) => Int -> a -> g -> ([a],g)+nrand2 k = kvariant k . rand2++-- | @SimpleNumber.rrand@ is 'curry' 'randomR'.+rrand :: (Random n, RandomGen g) => n -> n -> g -> (n,g)+rrand = curry randomR++-- | Variant of 'rrand' generating /k/ values.+nrrand :: (RandomGen g,Random a,Num a) => Int -> a -> a -> g -> ([a],g)+nrrand k l = kvariant k . rrand l++-- | @SequenceableCollection.choose@ selects an element at random.+choose :: RandomGen g => [a] -> g -> (a,g)+choose l g =+    let (i,g') = randomR (0,length l - 1) g+    in (l !! i,g')++-- | Variant of 'choose' generating /k/ values.+nchoose :: RandomGen g => Int -> [a] -> g -> ([a],g)+nchoose k = kvariant k . choose++-- | @SimpleNumber.exprand@ generates exponentially distributed random+-- number in the given interval.+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')++-- | Variant of 'exprand' generating /k/ values.+nexprand :: (Floating n,Random n,RandomGen g) =>+            Int -> n -> n -> g -> ([n],g)+nexprand k l = kvariant k . exprand l++-- | @SimpleNumber.coin@ is 'True' at given probability, which is in+-- range (0,1).+coin :: (RandomGen g, Random a, Ord a, Fractional a) => a -> g -> (Bool,g)+coin n g =+  let (i,g') = randomR (0.0,1.0) g+  in (i < n,g')++-- | Variant of 'coin' generating /k/ values.+--+-- > fst (ncoin 5 0.5 (mkStdGen 0)) == [True,True,False,True,False]+ncoin :: (RandomGen g, Random a, Ord a, Fractional a) => Int -> a -> g -> ([Bool],g)+ncoin k = kvariant k . coin++-- | @List.scramble@ shuffles the elements.+--+-- > fst (scramble [1..5] (mkStdGen 0)) == [1,5,2,3,4]+scramble :: RandomGen g => [t] -> g -> ([t],g)+scramble k g =+    let (_,g') = next g+    in (shuffle' k (length k) g,g')++-- | @ArrayedCollection.windex@ takes a list of probabilities, which+-- should sums to /n/, and returns the an index value given a (0,/n/)+-- input.+--+-- > map (windex [0.1,0.3,0.6]) [0,0.1 .. 0.4] == [Just 0,Just 1,Just 1,Just 1,Just 2]+windex :: (Ord a,Num a) => [a] -> a -> Maybe Int+windex w n = findIndex (n <) (C.integrate w)++-- | @SequenceableCollection.wchoose@ selects an element from a list+-- given a list of weights which sum to @1@.+wchoose :: (RandomGen g,Random a,Ord a,Fractional a) => [b] -> [a] -> g -> (b,g)+wchoose l w g =+  let (i,g') = randomR (0.0,1.0) g+      n = fromMaybe (error "wchoose: windex") (windex w i)+  in (l !! n,g')+

@@ -0,0 +1,49 @@+-- | 'getStdRandom' based @sclang@ random number functions.+module Sound.SC3.Lang.Random.IO where++import Sound.SC3.Lang.Random.Gen as R+import System.Random {- random -}++-- | @SimpleNumber.rand@ is 'randomRIO' in (0,/n/).+rand :: (Random n,Num n) => n -> IO n+rand n = randomRIO (0,n)++-- | @SimpleNumber.rand2@ is 'randomRIO' in (-/n/,/n/).+rand2 :: (Random n,Num n) => n -> IO n+rand2 n = randomRIO (-n,n)++-- | Variant of 'rand2' generating /k/ values.+nrand2 :: (Random a, Num a) => Int -> a -> IO [a]+nrand2 n = getStdRandom . R.nrand2 n++-- | @SimpleNumber.rrand@ is 'curry' 'randomRIO'.+rrand :: (Random n) => n -> n -> IO n+rrand = curry randomRIO++-- | Variant of 'rrand' generating /k/ values.+nrrand :: (Random a, Num a) => Int -> a -> a -> IO [a]+nrrand n l = getStdRandom . R.nrrand n l++-- | @SequenceableCollection.choose@ selects an element at random.+choose :: [a] -> IO a+choose = getStdRandom . R.choose++-- | @SimpleNumber.exprand@ generates exponentially distributed random+-- number in the given interval.+exprand :: (Floating n,Random n) => n -> n -> IO n+exprand l = getStdRandom . R.exprand l++-- | @SimpleNumber.coin@ is 'True' at given probability, which is in+-- range (0,1).+coin :: (Random n,Fractional n,Ord n) => n -> IO Bool+coin = getStdRandom . R.coin++-- | @List.scramble@ shuffles the elements.+scramble :: [t] -> IO [t]+scramble = getStdRandom . R.scramble++-- | @SequenceableCollection.wchoose@ selects an element from a list+-- given a list of weights which sum to @1@.+wchoose :: (Random a,Ord a,Fractional a) => [b] -> [a] -> IO b+wchoose l = getStdRandom . R.wchoose l+

@@ -0,0 +1,73 @@+-- | 'Rand' monad based @sclang@ random number functions.+module Sound.SC3.Lang.Random.Monad where++import Control.Monad+import Control.Monad.Random {- MonadRandom -}+import qualified Sound.SC3.Lang.Math as M++-- | @SimpleNumber.rand@ is 'getRandomR' in (0,/n/).+--+-- > evalRand (replicateM 2 (rand 10)) (mkStdGen 6) == [5,8]+rand :: (RandomGen g,Random n,Num n) => n -> Rand g n+rand n = getRandomR (0,n)++-- | Variant of 'rand' generating /k/ values.+--+-- > evalRand (nrand 3 10) (mkStdGen 6) == [5,8,1]+nrand :: (RandomGen g,Random n,Num n) => Int -> n -> Rand g [n]+nrand k = replicateM k . rand++-- | @SimpleNumber.rand2@ is 'getRandomR' in (-/n/,/n/).+--+-- > evalRand (replicateM 2 (rand2 10)) (mkStdGen 5) == [7,-6]+rand2 :: (RandomGen g,Random n,Num n) => n -> Rand g n+rand2 n = getRandomR (-n,n)++-- | Variant of 'rand2' generating /k/ values.+--+-- > evalRand (nrand2 3 10) (mkStdGen 5) == [7,-6,9]+nrand2 :: (RandomGen g,Random n,Num n) => Int -> n -> Rand g [n]+nrand2 k = replicateM k . rand2++-- | @SimpleNumber.rrand@ is 'curry' 'getRandomR'.+--+-- > evalRand (replicateM 2 (rrand 3 9)) (mkStdGen 1) == [5,8]+rrand :: (RandomGen g,Random n,Num n) => n -> n -> Rand g n+rrand l r = getRandomR (l,r)++-- | Variant of 'rrand' generating /k/ values.+--+-- > evalRand (nrrand 4 3 9) (mkStdGen 1) == [5,8,9,6]+nrrand :: (RandomGen g,Random n,Num n) => Int -> n -> n -> Rand g [n]+nrrand k l = replicateM k . rrand l++-- | @SequenceableCollection.choose@ selects an element at random.+--+-- > evalRand (choose [3..9]) (mkStdGen 1) == 5+choose :: RandomGen g => [a] -> Rand g a+choose l = do+  i <- rand (length l - 1)+  return (l !! i)++-- | Variant of 'choose' generating /k/ values.+--+-- > evalRand (nchoose 4 [3..9]) (mkStdGen 1) == [5,8,9,6]+nchoose :: (RandomGen g) => Int -> [a] -> Rand g [a]+nchoose k = replicateM k . choose++-- | @SimpleNumber.exprand@ generates exponentially distributed random+-- number in the given interval.+--+-- > let r = replicateM 3 (exprand 10 100 >>= return.floor)+-- > in evalRand r (mkStdGen 1) == [22,21,13]+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)++-- | Variant of 'exprand' generating /k/ values.+--+-- > let r = nexprand 3 10 100 >>= return . map floor+-- > in evalRand r (mkStdGen 1) == [22,21,13]+nexprand :: (Floating n,Random n,RandomGen g) => Int -> n -> n -> Rand g [n]+nexprand k l = replicateM k . exprand l

@@ -1,5 +1,5 @@ Name:              hsc3-lang-Version:           0.9+Version:           0.11 Synopsis:          Haskell SuperCollider Language Description:       Haskell library defining operations from the                    SuperCollider language class library@@ -10,29 +10,41 @@ Maintainer:        rd@slavepianos.org Stability:         Experimental Homepage:          http://slavepianos.org/rd/?t=hsc3-lang-Tested-With:       GHC == 6.12.1+Tested-With:       GHC == 7.2.2 Build-Type:        Simple-Cabal-Version:     >= 1.6+Cabal-Version:     >= 1.8  Data-files:        README-                   Help/Collection/*.help.lhs-                   Help/Math/*.help.lhs-                   Help/Pattern/List/*.help.lhs-                   Help/Pattern/Step/*.help.lhs  Library   Build-Depends:   array,                    base == 4.*,                    containers,+                   data-default,+                   hosc == 0.11.*,+                   hsc3 == 0.11.*,+                   MonadRandom,                    split,-                   random+                   random,+                   random-shuffle   GHC-Options:     -Wall -fwarn-tabs-  Exposed-modules: Sound.SC3.Lang.Collection.Collection-                   Sound.SC3.Lang.Collection.Numerical-                   Sound.SC3.Lang.Collection.SequenceableCollection-                   Sound.SC3.Lang.Math.Pitch+  Exposed-modules: Sound.SC3.Lang.Collection+                   Sound.SC3.Lang.Collection.Extension+                   Sound.SC3.Lang.Collection.Numerical.Extending+                   Sound.SC3.Lang.Collection.Numerical.Truncating+                   Sound.SC3.Lang.Collection.Universal.Datum+                   Sound.SC3.Lang.Control.Duration+                   Sound.SC3.Lang.Control.Event+                   Sound.SC3.Lang.Control.Instrument+                   Sound.SC3.Lang.Control.Pitch+                   Sound.SC3.Lang.Control.OverlapTexture+                   Sound.SC3.Lang.Data.Vowel+                   Sound.SC3.Lang.Math+                   Sound.SC3.Lang.Pattern.ID                    Sound.SC3.Lang.Pattern.List-                   Sound.SC3.Lang.Pattern.Step+                   Sound.SC3.Lang.Random.Gen+                   Sound.SC3.Lang.Random.IO+                   Sound.SC3.Lang.Random.Monad  Source-Repository  head   Type:            darcs