diff --git a/Help/Collection/collection.help.lhs b/Help/Collection/collection.help.lhs deleted file mode 100644 --- a/Help/Collection/collection.help.lhs +++ /dev/null @@ -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]] - diff --git a/Help/Math/pitch.help.lhs b/Help/Math/pitch.help.lhs deleted file mode 100644 --- a/Help/Math/pitch.help.lhs +++ /dev/null @@ -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) diff --git a/Help/Pattern/List/pappend.help.lhs b/Help/Pattern/List/pappend.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/pappend.help.lhs +++ /dev/null @@ -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) diff --git a/Help/Pattern/List/pbool.help.lhs b/Help/Pattern/List/pbool.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/pbool.help.lhs +++ /dev/null @@ -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] diff --git a/Help/Pattern/List/pclutch.help.lhs b/Help/Pattern/List/pclutch.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/pclutch.help.lhs +++ /dev/null @@ -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 diff --git a/Help/Pattern/List/pcollect.help.lhs b/Help/Pattern/List/pcollect.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/pcollect.help.lhs +++ /dev/null @@ -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) diff --git a/Help/Pattern/List/pcountpre.help.lhs b/Help/Pattern/List/pcountpre.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/pcountpre.help.lhs +++ /dev/null @@ -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]) diff --git a/Help/Pattern/List/pcycle.help.lhs b/Help/Pattern/List/pcycle.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/pcycle.help.lhs +++ /dev/null @@ -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] - diff --git a/Help/Pattern/List/pdegreeToKey.help.lhs b/Help/Pattern/List/pdegreeToKey.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/pdegreeToKey.help.lhs +++ /dev/null @@ -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] diff --git a/Help/Pattern/List/pdrop.help.lhs b/Help/Pattern/List/pdrop.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/pdrop.help.lhs +++ /dev/null @@ -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) diff --git a/Help/Pattern/List/pempty.help.lhs b/Help/Pattern/List/pempty.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/pempty.help.lhs +++ /dev/null @@ -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 diff --git a/Help/Pattern/List/pfilter.help.lhs b/Help/Pattern/List/pfilter.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/pfilter.help.lhs +++ /dev/null @@ -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 diff --git a/Help/Pattern/List/pfin.help.lhs b/Help/Pattern/List/pfin.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/pfin.help.lhs +++ /dev/null @@ -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) diff --git a/Help/Pattern/List/pgeom.help.lhs b/Help/Pattern/List/pgeom.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/pgeom.help.lhs +++ /dev/null @@ -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 diff --git a/Help/Pattern/List/phead.help.lhs b/Help/Pattern/List/phead.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/phead.help.lhs +++ /dev/null @@ -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 diff --git a/Help/Pattern/List/pinterleave.help.lhs b/Help/Pattern/List/pinterleave.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/pinterleave.help.lhs +++ /dev/null @@ -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)) diff --git a/Help/Pattern/List/pn.help.lhs b/Help/Pattern/List/pn.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/pn.help.lhs +++ /dev/null @@ -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 diff --git a/Help/Pattern/List/prand.help.lhs b/Help/Pattern/List/prand.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/prand.help.lhs +++ /dev/null @@ -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 - diff --git a/Help/Pattern/List/preject.help.lhs b/Help/Pattern/List/preject.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/preject.help.lhs +++ /dev/null @@ -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 diff --git a/Help/Pattern/List/prepeat.help.lhs b/Help/Pattern/List/prepeat.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/prepeat.help.lhs +++ /dev/null @@ -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] - diff --git a/Help/Pattern/List/prsd.help.lhs b/Help/Pattern/List/prsd.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/prsd.help.lhs +++ /dev/null @@ -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] diff --git a/Help/Pattern/List/pseq.help.lhs b/Help/Pattern/List/pseq.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/pseq.help.lhs +++ /dev/null @@ -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) diff --git a/Help/Pattern/List/pser.help.lhs b/Help/Pattern/List/pser.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/pser.help.lhs +++ /dev/null @@ -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 diff --git a/Help/Pattern/List/pseries.help.lhs b/Help/Pattern/List/pseries.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/pseries.help.lhs +++ /dev/null @@ -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 diff --git a/Help/Pattern/List/pstutter.help.lhs b/Help/Pattern/List/pstutter.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/pstutter.help.lhs +++ /dev/null @@ -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] diff --git a/Help/Pattern/List/pswitch.help.lhs b/Help/Pattern/List/pswitch.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/pswitch.help.lhs +++ /dev/null @@ -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 diff --git a/Help/Pattern/List/pswitch1.help.lhs b/Help/Pattern/List/pswitch1.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/pswitch1.help.lhs +++ /dev/null @@ -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 diff --git a/Help/Pattern/List/ptail.help.lhs b/Help/Pattern/List/ptail.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/ptail.help.lhs +++ /dev/null @@ -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 [] diff --git a/Help/Pattern/List/ptake.help.lhs b/Help/Pattern/List/ptake.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/ptake.help.lhs +++ /dev/null @@ -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] diff --git a/Help/Pattern/List/ptrigger.help.lhs b/Help/Pattern/List/ptrigger.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/ptrigger.help.lhs +++ /dev/null @@ -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 diff --git a/Help/Pattern/List/pwhite.help.lhs b/Help/Pattern/List/pwhite.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/pwhite.help.lhs +++ /dev/null @@ -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 diff --git a/Help/Pattern/List/pzip.help.lhs b/Help/Pattern/List/pzip.help.lhs deleted file mode 100644 --- a/Help/Pattern/List/pzip.help.lhs +++ /dev/null @@ -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)] diff --git a/Help/Pattern/Step/pappend.help.lhs b/Help/Pattern/Step/pappend.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pappend.help.lhs +++ /dev/null @@ -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) diff --git a/Help/Pattern/Step/pclutch.help.lhs b/Help/Pattern/Step/pclutch.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pclutch.help.lhs +++ /dev/null @@ -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) diff --git a/Help/Pattern/Step/pcollect.help.lhs b/Help/Pattern/Step/pcollect.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pcollect.help.lhs +++ /dev/null @@ -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 diff --git a/Help/Pattern/Step/pcontinue.help.lhs b/Help/Pattern/Step/pcontinue.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pcontinue.help.lhs +++ /dev/null @@ -1,3 +0,0 @@ -pcontinue :: P x -> (x -> P x -> P a) -> P a - -> import Sound.SC3.Lang.Pattern.Step diff --git a/Help/Pattern/Step/pcountpre.help.lhs b/Help/Pattern/Step/pcountpre.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pcountpre.help.lhs +++ /dev/null @@ -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) diff --git a/Help/Pattern/Step/pcycle.help.lhs b/Help/Pattern/Step/pcycle.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pcycle.help.lhs +++ /dev/null @@ -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] diff --git a/Help/Pattern/Step/pdegreeToKey.help.lhs b/Help/Pattern/Step/pdegreeToKey.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pdegreeToKey.help.lhs +++ /dev/null @@ -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] diff --git a/Help/Pattern/Step/pdrop.help.lhs b/Help/Pattern/Step/pdrop.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pdrop.help.lhs +++ /dev/null @@ -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) diff --git a/Help/Pattern/Step/pempty.help.lhs b/Help/Pattern/Step/pempty.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pempty.help.lhs +++ /dev/null @@ -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) diff --git a/Help/Pattern/Step/pexprand.help.lhs b/Help/Pattern/Step/pexprand.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pexprand.help.lhs +++ /dev/null @@ -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 diff --git a/Help/Pattern/Step/pfilter.help.lhs b/Help/Pattern/Step/pfilter.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pfilter.help.lhs +++ /dev/null @@ -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 diff --git a/Help/Pattern/Step/pfin.help.lhs b/Help/Pattern/Step/pfin.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pfin.help.lhs +++ /dev/null @@ -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) diff --git a/Help/Pattern/Step/pfix.help.lhs b/Help/Pattern/Step/pfix.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pfix.help.lhs +++ /dev/null @@ -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)) diff --git a/Help/Pattern/Step/pgeom.help.lhs b/Help/Pattern/Step/pgeom.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pgeom.help.lhs +++ /dev/null @@ -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 diff --git a/Help/Pattern/Step/phead.help.lhs b/Help/Pattern/Step/phead.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/phead.help.lhs +++ /dev/null @@ -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) diff --git a/Help/Pattern/Step/pif.help.lhs b/Help/Pattern/Step/pif.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pif.help.lhs +++ /dev/null @@ -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) diff --git a/Help/Pattern/Step/pinterleave.help.lhs b/Help/Pattern/Step/pinterleave.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pinterleave.help.lhs +++ /dev/null @@ -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 diff --git a/Help/Pattern/Step/pn.help.lhs b/Help/Pattern/Step/pn.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pn.help.lhs +++ /dev/null @@ -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 - diff --git a/Help/Pattern/Step/ppatlace.help.lhs b/Help/Pattern/Step/ppatlace.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/ppatlace.help.lhs +++ /dev/null @@ -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. diff --git a/Help/Pattern/Step/prand.help.lhs b/Help/Pattern/Step/prand.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/prand.help.lhs +++ /dev/null @@ -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) diff --git a/Help/Pattern/Step/preject.help.lhs b/Help/Pattern/Step/preject.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/preject.help.lhs +++ /dev/null @@ -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 diff --git a/Help/Pattern/Step/prepeat.help.lhs b/Help/Pattern/Step/prepeat.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/prepeat.help.lhs +++ /dev/null @@ -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] - diff --git a/Help/Pattern/Step/prorate.help.lhs b/Help/Pattern/Step/prorate.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/prorate.help.lhs +++ /dev/null @@ -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 diff --git a/Help/Pattern/Step/prp.help.lhs b/Help/Pattern/Step/prp.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/prp.help.lhs +++ /dev/null @@ -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) } diff --git a/Help/Pattern/Step/prsd.help.lhs b/Help/Pattern/Step/prsd.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/prsd.help.lhs +++ /dev/null @@ -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) diff --git a/Help/Pattern/Step/pscan.help.lhs b/Help/Pattern/Step/pscan.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pscan.help.lhs +++ /dev/null @@ -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] diff --git a/Help/Pattern/Step/pscanl.help.lhs b/Help/Pattern/Step/pscanl.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pscanl.help.lhs +++ /dev/null @@ -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] diff --git a/Help/Pattern/Step/pseq.help.lhs b/Help/Pattern/Step/pseq.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pseq.help.lhs +++ /dev/null @@ -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 diff --git a/Help/Pattern/Step/pser.help.lhs b/Help/Pattern/Step/pser.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pser.help.lhs +++ /dev/null @@ -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 diff --git a/Help/Pattern/Step/pseries.help.lhs b/Help/Pattern/Step/pseries.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pseries.help.lhs +++ /dev/null @@ -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 diff --git a/Help/Pattern/Step/pstutter.help.lhs b/Help/Pattern/Step/pstutter.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pstutter.help.lhs +++ /dev/null @@ -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 diff --git a/Help/Pattern/Step/pswitch.help.lhs b/Help/Pattern/Step/pswitch.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pswitch.help.lhs +++ /dev/null @@ -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) diff --git a/Help/Pattern/Step/pswitch1.help.lhs b/Help/Pattern/Step/pswitch1.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pswitch1.help.lhs +++ /dev/null @@ -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) diff --git a/Help/Pattern/Step/ptail.help.lhs b/Help/Pattern/Step/ptail.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/ptail.help.lhs +++ /dev/null @@ -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) diff --git a/Help/Pattern/Step/ptake.help.lhs b/Help/Pattern/Step/ptake.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/ptake.help.lhs +++ /dev/null @@ -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)) diff --git a/Help/Pattern/Step/ptrigger.help.lhs b/Help/Pattern/Step/ptrigger.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/ptrigger.help.lhs +++ /dev/null @@ -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) diff --git a/Help/Pattern/Step/pwhite.help.lhs b/Help/Pattern/Step/pwhite.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pwhite.help.lhs +++ /dev/null @@ -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 diff --git a/Help/Pattern/Step/pwrap.help.lhs b/Help/Pattern/Step/pwrap.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pwrap.help.lhs +++ /dev/null @@ -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 diff --git a/Help/Pattern/Step/pxrand.help.lhs b/Help/Pattern/Step/pxrand.help.lhs deleted file mode 100644 --- a/Help/Pattern/Step/pxrand.help.lhs +++ /dev/null @@ -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 diff --git a/README b/README --- a/README +++ b/README @@ -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/ diff --git a/Sound/SC3/Lang/Collection.hs b/Sound/SC3/Lang/Collection.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Collection.hs @@ -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 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 diff --git a/Sound/SC3/Lang/Collection/Collection.hs b/Sound/SC3/Lang/Collection/Collection.hs deleted file mode 100644 --- a/Sound/SC3/Lang/Collection/Collection.hs +++ /dev/null @@ -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 diff --git a/Sound/SC3/Lang/Collection/Extension.hs b/Sound/SC3/Lang/Collection/Extension.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Collection/Extension.hs @@ -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 (-) diff --git a/Sound/SC3/Lang/Collection/Numerical.hs b/Sound/SC3/Lang/Collection/Numerical.hs deleted file mode 100644 --- a/Sound/SC3/Lang/Collection/Numerical.hs +++ /dev/null @@ -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 diff --git a/Sound/SC3/Lang/Collection/Numerical/Extending.hs b/Sound/SC3/Lang/Collection/Numerical/Extending.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Collection/Numerical/Extending.hs @@ -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 diff --git a/Sound/SC3/Lang/Collection/Numerical/Truncating.hs b/Sound/SC3/Lang/Collection/Numerical/Truncating.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Collection/Numerical/Truncating.hs @@ -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 +-} diff --git a/Sound/SC3/Lang/Collection/SequenceableCollection.hs b/Sound/SC3/Lang/Collection/SequenceableCollection.hs deleted file mode 100644 --- a/Sound/SC3/Lang/Collection/SequenceableCollection.hs +++ /dev/null @@ -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 (,) diff --git a/Sound/SC3/Lang/Collection/Universal/Datum.hs b/Sound/SC3/Lang/Collection/Universal/Datum.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Collection/Universal/Datum.hs @@ -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 +-} diff --git a/Sound/SC3/Lang/Control/Duration.hs b/Sound/SC3/Lang/Control/Duration.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Control/Duration.hs @@ -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} diff --git a/Sound/SC3/Lang/Control/Event.hs b/Sound/SC3/Lang/Control/Event.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Control/Event.hs @@ -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) diff --git a/Sound/SC3/Lang/Control/Instrument.hs b/Sound/SC3/Lang/Control/Instrument.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Control/Instrument.hs @@ -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)) diff --git a/Sound/SC3/Lang/Control/OverlapTexture.hs b/Sound/SC3/Lang/Control/OverlapTexture.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Control/OverlapTexture.hs @@ -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) diff --git a/Sound/SC3/Lang/Control/Pitch.hs b/Sound/SC3/Lang/Control/Pitch.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Control/Pitch.hs @@ -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 diff --git a/Sound/SC3/Lang/Data/Vowel.hs b/Sound/SC3/Lang/Data/Vowel.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Data/Vowel.hs @@ -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 diff --git a/Sound/SC3/Lang/Math.hs b/Sound/SC3/Lang/Math.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Math.hs @@ -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' diff --git a/Sound/SC3/Lang/Math/Pitch.hs b/Sound/SC3/Lang/Math/Pitch.hs deleted file mode 100644 --- a/Sound/SC3/Lang/Math/Pitch.hs +++ /dev/null @@ -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 diff --git a/Sound/SC3/Lang/Pattern/ID.hs b/Sound/SC3/Lang/Pattern/ID.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Pattern/ID.hs @@ -0,0 +1,1102 @@ +{-# Language FlexibleInstances #-} +-- | @sclang@ pattern library functions. +-- See 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)) + diff --git a/Sound/SC3/Lang/Pattern/List.hs b/Sound/SC3/Lang/Pattern/List.hs --- a/Sound/SC3/Lang/Pattern/List.hs +++ b/Sound/SC3/Lang/Pattern/List.hs @@ -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 (-) diff --git a/Sound/SC3/Lang/Pattern/Step.hs b/Sound/SC3/Lang/Pattern/Step.hs deleted file mode 100644 --- a/Sound/SC3/Lang/Pattern/Step.hs +++ /dev/null @@ -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 (-) diff --git a/Sound/SC3/Lang/Random/Gen.hs b/Sound/SC3/Lang/Random/Gen.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Random/Gen.hs @@ -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') + diff --git a/Sound/SC3/Lang/Random/IO.hs b/Sound/SC3/Lang/Random/IO.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Random/IO.hs @@ -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 + diff --git a/Sound/SC3/Lang/Random/Monad.hs b/Sound/SC3/Lang/Random/Monad.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Random/Monad.hs @@ -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 diff --git a/hsc3-lang.cabal b/hsc3-lang.cabal --- a/hsc3-lang.cabal +++ b/hsc3-lang.cabal @@ -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