diff --git a/Help/Collection/collection.help.lhs b/Help/Collection/collection.help.lhs --- a/Help/Collection/collection.help.lhs +++ b/Help/Collection/collection.help.lhs @@ -42,3 +42,44 @@ > [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/Pattern/List/pappend.help.lhs b/Help/Pattern/List/pappend.help.lhs new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/pappend.help.lhs @@ -0,0 +1,20 @@ +(++) :: [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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/pbool.help.lhs @@ -0,0 +1,8 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/pclutch.help.lhs @@ -0,0 +1,21 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/pcollect.help.lhs @@ -0,0 +1,8 @@ +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) diff --git a/Help/Pattern/List/pcountpre.help.lhs b/Help/Pattern/List/pcountpre.help.lhs new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/pcountpre.help.lhs @@ -0,0 +1,12 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/pcycle.help.lhs @@ -0,0 +1,11 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/pdegreeToKey.help.lhs @@ -0,0 +1,26 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/pdrop.help.lhs @@ -0,0 +1,9 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/pempty.help.lhs @@ -0,0 +1,9 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/pfilter.help.lhs @@ -0,0 +1,9 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/pfin.help.lhs @@ -0,0 +1,19 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/pgeom.help.lhs @@ -0,0 +1,15 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/phead.help.lhs @@ -0,0 +1,12 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/pinterleave.help.lhs @@ -0,0 +1,15 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/pn.help.lhs @@ -0,0 +1,7 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/prand.help.lhs @@ -0,0 +1,25 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/preject.help.lhs @@ -0,0 +1,9 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/prepeat.help.lhs @@ -0,0 +1,11 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/prsd.help.lhs @@ -0,0 +1,10 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/pseq.help.lhs @@ -0,0 +1,35 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/pser.help.lhs @@ -0,0 +1,13 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/pseries.help.lhs @@ -0,0 +1,13 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/pstutter.help.lhs @@ -0,0 +1,19 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/pswitch.help.lhs @@ -0,0 +1,11 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/pswitch1.help.lhs @@ -0,0 +1,18 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/ptail.help.lhs @@ -0,0 +1,14 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/ptake.help.lhs @@ -0,0 +1,10 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/ptrigger.help.lhs @@ -0,0 +1,22 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/pwhite.help.lhs @@ -0,0 +1,35 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/List/pzip.help.lhs @@ -0,0 +1,12 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pappend.help.lhs @@ -0,0 +1,12 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pclutch.help.lhs @@ -0,0 +1,29 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pcollect.help.lhs @@ -0,0 +1,9 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pcontinue.help.lhs @@ -0,0 +1,3 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pcountpre.help.lhs @@ -0,0 +1,10 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pcycle.help.lhs @@ -0,0 +1,9 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pdegreeToKey.help.lhs @@ -0,0 +1,26 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pdrop.help.lhs @@ -0,0 +1,8 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pempty.help.lhs @@ -0,0 +1,10 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pexprand.help.lhs @@ -0,0 +1,13 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pfilter.help.lhs @@ -0,0 +1,9 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pfin.help.lhs @@ -0,0 +1,26 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pfix.help.lhs @@ -0,0 +1,18 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pgeom.help.lhs @@ -0,0 +1,17 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/phead.help.lhs @@ -0,0 +1,14 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pif.help.lhs @@ -0,0 +1,34 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pinterleave.help.lhs @@ -0,0 +1,12 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pn.help.lhs @@ -0,0 +1,16 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/ppatlace.help.lhs @@ -0,0 +1,30 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/prand.help.lhs @@ -0,0 +1,21 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/preject.help.lhs @@ -0,0 +1,10 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/prepeat.help.lhs @@ -0,0 +1,10 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/prorate.help.lhs @@ -0,0 +1,11 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/prp.help.lhs @@ -0,0 +1,37 @@ +> 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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/prsd.help.lhs @@ -0,0 +1,8 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pscan.help.lhs @@ -0,0 +1,33 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pscanl.help.lhs @@ -0,0 +1,28 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pseq.help.lhs @@ -0,0 +1,48 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pser.help.lhs @@ -0,0 +1,16 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pseries.help.lhs @@ -0,0 +1,15 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pstutter.help.lhs @@ -0,0 +1,26 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pswitch.help.lhs @@ -0,0 +1,11 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pswitch1.help.lhs @@ -0,0 +1,22 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/ptail.help.lhs @@ -0,0 +1,10 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/ptake.help.lhs @@ -0,0 +1,7 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/ptrigger.help.lhs @@ -0,0 +1,17 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pwhite.help.lhs @@ -0,0 +1,36 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pwrap.help.lhs @@ -0,0 +1,17 @@ +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 new file mode 100644 --- /dev/null +++ b/Help/Pattern/Step/pxrand.help.lhs @@ -0,0 +1,9 @@ +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/Help/Pattern/pattern.help.lhs b/Help/Pattern/pattern.help.lhs deleted file mode 100644 --- a/Help/Pattern/pattern.help.lhs +++ /dev/null @@ -1,251 +0,0 @@ -> import Sound.SC3.Lang.Pattern - -* Beginning - -| One goal of separating the synthesis engine and -| the language in SC Server is to make it possible -| to explore implementing in other languages the -| concepts expressed in the SuperCollider language -| and class library. (McCartney, 2000) - -Patterns in supercollider language provide -a concise and expressive notation for writing -complex processes. - -In a strict language the distinction between -data and process is quite clear. - -In non-strict and purely functional languages -ordinary data types may be of indefinite extent. - -> let ones = 1 : ones -> in take 5 ones - -Since there is no mutation in haskell the -pattern and stream distinction is less -clear. - -> let { a = [1,2,3] ++ a -> ; b = drop 2 (fmap negate a) } -> in take 5 (zip a b) - -However, as was noted in relation to the noise -and related unit generators, a notation for -describing indeterminate structures presents -some interesting questions. - -* Patterns are abstract - -The type of a pattern is abstract. - -> data P a - -(P a) is the abstract data type of a pattern -with elements of type a. - -Patterns are constructed, manipulated and destructured -using the functions provided. - -* Patterns are Monoids - -> class Monoid a where -> mempty :: a -> mappend :: a -> a -> a - -Patterns are instances of monoid. mempty is the -empty pattern, and mappend makes a sequence of two -patterns. - -> pempty :: P a -> pappend :: P a -> P a -> P a - -* Patterns are Functors - -> class Functor f -> where fmap :: (a -> b) -> f a -> f b - -Patterns are an instance of Functor. fmap applies -a function to each element of a pattern. - -> pmap :: (a -> b) -> P a -> P b - -* Patterns are Applicative - -> class (Functor f) => Applicative f where -> pure :: a -> f a -> (<*>) :: f (a -> b) -> f a -> f b - -Patterns are instances of Applicative (McBride and -Paterson, 2007). The pure function lifts a value -into an infinite pattern of itself. The (<*>) -function applies a pattern of functions to a -pattern of values. - -> ppure :: a -> P a -> papply :: P (a -> b) -> P a -> P b - -Consider summing two patterns: - -> import Control.Applicative - -> let { p = pseq [1, 3, 5] 1 -> ; q = pseq [6, 4, 2] 1 } -> in evalP 0 (pure (+) <*> p <*> q) - -* Patterns are Monads - -> class Monad m where -> (>>=) :: m a -> (a -> m b) -> m b -> return :: a -> m a - -Patterns are an instance of the Monad class -(Wadler, 1990). The (>>=) function, pronounced -bind, is the mechanism for processing a monadic -value. The return function places a value into -the monad, for the pattern case it creates a -single element pattern. - -> pbind :: P x -> (x -> P a) -> P a -> preturn :: a -> P a - -The monad instance for Patterns follows the -standard monad instance for lists, for example: - -> evalP 0 (pseq [1, 2] 1 >>= \x -> -> pseq [3, 4, 5] 1 >>= \y -> -> return (x, y)) - -which may be written using the haskell do notation -as: - -> evalP 0 (do { x <- pseq [1, 2] 1 -> ; y <- pseq [3, 4, 5] 1 -> ; return (x, y) }) - -denotes the pattern having elements (1,3), (1,4), -(1,5), (2,3), (2,4) and (2,5). - -* Patterns are numerical - -Patterns are instances of both Num: - -> class (Eq a, Show a) => Num a where -> (+) :: a -> a -> a -> (*) :: a -> a -> a -> (-) :: a -> a -> a -> negate :: a -> a -> abs :: a -> a -> signum :: a -> a -> fromInteger :: Integer -> a - -and fractional: - -> class (Num a) => Fractional a where -> (/) :: a -> a -> a -> recip :: a -> a -> fromRational :: Rational -> a - -Summing two patterns does not require using the -applicative notation above, and the numerical -pattern (return x) can be written as the literal -'x': - -> let { p = pseq [1, 3, 5] 1 -> ; q = pseq [6, 4, 2] 1 } -> in evalP 0 (p + q) - -The numerical instances are written using the -applicative functions pure and <*>. - -* Intederminacy, Randomness - -A pattern may be given by a function from -a random number generator to a duple of -a pattern and a derived random number -generator. - -> prp :: (StdGen -> (P a, StdGen)) -> P a - -pfix makes a pattern determinate by seeding -the random number generator for the pattern. - -> type Seed = Int -> pfix :: Seed -> P a -> P a - -* Accumulation, Threading - -pscan is an accumulator. It provides a mechanism -for state to be threaded through a pattern. It can -be used to write a function to remove succesive -duplicates from a pattern, to count the distance -between occurences of an element in a pattern and -so on. - -> pscan :: (x -> y -> (x, a)) -> (x -> a) -> x -> P y -> P a - -* Continuing - -pcontinue provides a mechanism to destructure a -pattern and generate a new pattern based on the -first element and the 'rest' of the pattern. - -> pcontinue :: P x -> (x -> P x -> P a) -> P a - -The bind instance of monad is written in relation -to pcontinue. - -> pbind p f = pcontinue p (\x q -> f x `mappend` pbind q f) - -pcontinue can be used to write pfilter the -basic pattern filter, ptail which discards -the front elment of a pattern, and so on. - -* Destructuring, folding - -A pattern has an ordinary right fold, with the -additional requirement of a seed value for the -random number generator. - -> pfoldr :: Seed -> (a -> b -> b) -> b -> P a -> b - -pfoldr is the primitive traversal function for -a pattern. - -Right folding with the list constructor (:) and -the empty list transforms a pattern into a list. - -> let p = pser [1, 2, 3] 5 + pseq [0, 10] 3 -> in pfoldr 0 (:) [] p - -* Extension - -The haskell patterns follow the normal haskell -behavior when operating pointwise on sequences of -different length - the longer sequence is -truncated. - -The haskell expression: - -> zip [1, 2] [3, 4, 5] - -describes a list of two elements, being (1, 3) and -(2, 4). - -This differs from the ordinary supercollider -language behaviour, where the shorter sequence is -extended in a cycle, so that the expression: - -| [[1, 2], [3, 4, 5]].flop - -computes a list of three elements, [1, 3], [2, 4] -and [1, 5]. - -* References - -+ C. McBride and R. Paterson. Applicative - Programming with Effects. Journal of Functional - Programming, 17(4), 2007. - -+ P. Wadler. Comprehending Monads. In Conference - on Lisp and Funcional Programming, Nice, France, - June 1990. ACM. diff --git a/Help/Pattern/pclutch.help.lhs b/Help/Pattern/pclutch.help.lhs deleted file mode 100644 --- a/Help/Pattern/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 - -> let { p = pseq [1, 2, 3, 4, 5] 3 -> ; q = pseq [1, 0, 1, 0, 0, 0, 1, 1] 1 } -> in evalP 0 (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 0 (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 0 (pclutch p q) diff --git a/Help/Pattern/pcollect.help.lhs b/Help/Pattern/pcollect.help.lhs deleted file mode 100644 --- a/Help/Pattern/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 - -> let p = pcollect (* 3) (pseq [1, 2, 3] 3) -> in evalP 0 p diff --git a/Help/Pattern/pcountpre.help.lhs b/Help/Pattern/pcountpre.help.lhs deleted file mode 100644 --- a/Help/Pattern/pcountpre.help.lhs +++ /dev/null @@ -1,10 +0,0 @@ -pcountpre :: P Bool -> P Int -pcountpost :: P Bool -> P Int - -> import Sound.SC3.Lang.Pattern - -> let p = pbool (pseq [0, 0, 1, 0, 0, 0, 1, 1] 1) -> in evalP 0 (pcountpre p) - -> let p = pbool (pseq [1, 0, 1, 0, 0, 0, 1, 1] 1) -> in evalP 0 (pcountpost p) diff --git a/Help/Pattern/pdegreeToKey.help.lhs b/Help/Pattern/pdegreeToKey.help.lhs deleted file mode 100644 --- a/Help/Pattern/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 - -> 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 0 (pdegreeToKey p q r) - -> let { p = pseq [0, 1, 2, 3, 4, 3, 2, 1, 0, 2, 4, 7, 4, 2] 2 -> ; q = pseq [preturn [0, 2, 4, 5, 7, 9, 11] -> ,preturn [0, 2, 3, 5, 7, 8, 11]] 1 -> ; r = prepeat 12 } -> in evalP 0 (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/pdrop.help.lhs b/Help/Pattern/pdrop.help.lhs deleted file mode 100644 --- a/Help/Pattern/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 - -> let p = pseq [1, 2, 3] 4 -> in evalP 0 (pdrop 7 p) diff --git a/Help/Pattern/pexprand.help.lhs b/Help/Pattern/pexprand.help.lhs deleted file mode 100644 --- a/Help/Pattern/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 - -> let p = pexprand 0.01 0.99 12 -> in evalP 0 p - -> let { l = pseq [1, 11] 1 -> ; r = pseq [2, 12] 1 -> ; p = pexprand l r 12 } -> in evalP 0 p diff --git a/Help/Pattern/pfilter.help.lhs b/Help/Pattern/pfilter.help.lhs deleted file mode 100644 --- a/Help/Pattern/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 - -> let { p = pseq [1, 2, 3] 3 -> ; q = pfilter (< 3) p } -> in evalP 0 q diff --git a/Help/Pattern/pfin.help.lhs b/Help/Pattern/pfin.help.lhs deleted file mode 100644 --- a/Help/Pattern/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 - -> let p = pseq [1, 2, 3] pinf -> in evalP 0 (pfin 5 p) - -There is a variant where the count not a pattern. - -> let p = pseq [1, 2, 3] 1 -> in evalP 0 (pfin_ 5 p) - -Note that pfin does not extend the input pattern, -unlike pser. - -> let p = pseq [1, 2, 3] 1 -> in evalP 0 (pser [p] 5) diff --git a/Help/Pattern/pgeom.help.lhs b/Help/Pattern/pgeom.help.lhs deleted file mode 100644 --- a/Help/Pattern/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 - -> let p = pgeom 1 2 12 -> in evalP 0 p - -Real numbers work as well. - -> let p = pgeom 1.0 1.1 6 -> in evalP 0 p diff --git a/Help/Pattern/pif.help.lhs b/Help/Pattern/pif.help.lhs deleted file mode 100644 --- a/Help/Pattern/pif.help.lhs +++ /dev/null @@ -1,41 +0,0 @@ -pif :: Int -> P Bool -> P a -> P a -> P a -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 - -The primary form requires a seed to allow the -condition pattern to be fixed. The variant form -provides a zero seed, and allows one to indicate -that the condition pattern is deterministic (or -that the seed is not important). - -> import Sound.SC3.Lang.Pattern - -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 0 (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 0 (pif 3 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 0 (pzipWith3 if_f c p q) diff --git a/Help/Pattern/pinterleave.help.lhs b/Help/Pattern/pinterleave.help.lhs deleted file mode 100644 --- a/Help/Pattern/pinterleave.help.lhs +++ /dev/null @@ -1,13 +0,0 @@ -pinterleave :: P a -> P a -> P a - -Interleave elements from two patterns. - -> import Sound.SC3.Lang.Pattern - -> let { p = pseq [1, 2, 3] 3 -> ; q = pseq [4, 5, 6, 7] 2 } -> in evalP 0 (pinterleave p q) - -> let p = pinterleave (pwhite 1 9 5) (pseries 10 1 10) -> in evalP 1317 p - diff --git a/Help/Pattern/pn.help.lhs b/Help/Pattern/pn.help.lhs deleted file mode 100644 --- a/Help/Pattern/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 - -> let p = pn (pseq [1, 2, 3] 1) 4 -> in evalP 0 p - -There is a variant with the arguments -reversed. - -> let p = preplicate 4 (pseq [1, 2, 3] 1) -> in evalP 0 p - diff --git a/Help/Pattern/prand.help.lhs b/Help/Pattern/prand.help.lhs deleted file mode 100644 --- a/Help/Pattern/prand.help.lhs +++ /dev/null @@ -1,19 +0,0 @@ -prand :: [P a] -> P Int -> P a - -Returns one item from the list at random for each repeat. - -> import Sound.SC3.Lang - -> let p = prand [1, 2, 3, 4, 5] 6 -> in evalP 9 p - -> let p = prand [ pseq [1, 2] 1 -> , pseq [3, 4] 1 -> , pseq [5, 6] 1 ] 9 -> in evalP 3 p - -> let p = pseq [prand [pempty, pseq [24, 31, 36, 43, 48, 55] 1] 1 -> ,pseq [60, prand [63, 65] 1 -> ,67, prand [70, 72, 74] 1] (prrand 2 5) -> ,prand [74, 75, 77, 79, 81] (prrand 3 9)] pinf -> in take 24 (evalP 7 p) diff --git a/Help/Pattern/preject.help.lhs b/Help/Pattern/preject.help.lhs deleted file mode 100644 --- a/Help/Pattern/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 - -> let { p = pseq [1, 2, 3] 3 -> ; q = preject (== 1) p } -> in evalP 0 q diff --git a/Help/Pattern/prorate.help.lhs b/Help/Pattern/prorate.help.lhs deleted file mode 100644 --- a/Help/Pattern/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 0 p diff --git a/Help/Pattern/prsd.help.lhs b/Help/Pattern/prsd.help.lhs deleted file mode 100644 --- a/Help/Pattern/prsd.help.lhs +++ /dev/null @@ -1,8 +0,0 @@ -prsd :: (Eq a) => P a -> P a - -Remove successive duplicates. - -> import Sound.SC3.Lang.Pattern - -> let p = pfix 0 (prand [1,2,3] 9) -> in evalP 0 (pzip (prsd p) p) diff --git a/Help/Pattern/pseq.help.lhs b/Help/Pattern/pseq.help.lhs deleted file mode 100644 --- a/Help/Pattern/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 - -> let a = pseq [1, 2, 3] 2 -> in evalP 0 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 0 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 evalP 7 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 (evalP 94 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 0 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 0 p) - -There is a variant with a true integer repeat count. - -> let p = pseq_ [1, 2, 3] 5 -> in evalP 0 p diff --git a/Help/Pattern/pser.help.lhs b/Help/Pattern/pser.help.lhs deleted file mode 100644 --- a/Help/Pattern/pser.help.lhs +++ /dev/null @@ -1,14 +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. - -> let p = pser [1, 2, 3] 5 -> in evalP 0 p - -> let p = pser [1, pser [100, 200] 3, 3] 9 -> in evalP 0 p - -> let p = pser [1, 2, 3] 5 *. 3 -> in evalP 0 p diff --git a/Help/Pattern/pseries.help.lhs b/Help/Pattern/pseries.help.lhs deleted file mode 100644 --- a/Help/Pattern/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 - -> let p = pseries 0 2 24 -> in evalP 0 p - -> let p = pseries 1.0 0.1 24 -> in evalP 0 p diff --git a/Help/Pattern/pstutter.help.lhs b/Help/Pattern/pstutter.help.lhs deleted file mode 100644 --- a/Help/Pattern/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 - -> let p = pstutter 2 (pseq [1, 2, 3] pinf) -> in take 13 (evalP 0 p) - -> let { p = pseq [1, 2] pinf -> ; q = pseq [1, 2, 3] pinf -> ; r = pstutter p q } -> in take 13 (evalP 0 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 0 p) - -> let p = pstutter' (pseq [2,3] 1) (pseq [1, 2, 3] pinf) -> in evalP 0 p diff --git a/Help/Pattern/pswitch.help.lhs b/Help/Pattern/pswitch.help.lhs deleted file mode 100644 --- a/Help/Pattern/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 - -> 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 0 c) diff --git a/Help/Pattern/pswitch1.help.lhs b/Help/Pattern/pswitch1.help.lhs deleted file mode 100644 --- a/Help/Pattern/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 - -> 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 0 r) diff --git a/Help/Pattern/ptail.help.lhs b/Help/Pattern/ptail.help.lhs deleted file mode 100644 --- a/Help/Pattern/ptail.help.lhs +++ /dev/null @@ -1,10 +0,0 @@ -ptail :: P a -> P a - -Drop first element from pattern. - -> import Sound.SC3.Lang.Pattern - -> let p = pseq [1, 2, 3] 1 -> in evalP 0 (ptail p) - -> evalP 0 (ptail pempty) diff --git a/Help/Pattern/ptrigger.help.lhs b/Help/Pattern/ptrigger.help.lhs deleted file mode 100644 --- a/Help/Pattern/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 - -> let { p = pseq [1, 2, 3, 4, 5] 3 -> ; t = pbool (pseq [0, 0, 1, 0, 0, 0, 1, 1] 1) } -> in evalP 0 (ptrigger t p) diff --git a/Help/Pattern/pwhite.help.lhs b/Help/Pattern/pwhite.help.lhs deleted file mode 100644 --- a/Help/Pattern/pwhite.help.lhs +++ /dev/null @@ -1,20 +0,0 @@ -pwhite :: (Random a) => P a -> P a -> P Int -> P a - -Uniform linear distribution in given range. - -> import Sound.SC3.Lang.Pattern - -> let p = pwhite 0.0 1.0 12 -> in evalP 0 p - -> let { l = pseq [0.0, 10.0] 1 -> ; r = pseq [1.0, 11.0] 1 -> ; p = pwhite l r 12 } -> in evalP 0 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 evalP 0 p diff --git a/Help/Pattern/pwrap.help.lhs b/Help/Pattern/pwrap.help.lhs deleted file mode 100644 --- a/Help/Pattern/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 - -> let { p = pseries 6 2 9 -> ; q = pwrap p 2 10 } -> in evalP 0 q - -> let { p = pseries 6 2 9 -> ; q = pwrap p 1 11 } -> in evalP 0 q diff --git a/Help/Pattern/pxrand.help.lhs b/Help/Pattern/pxrand.help.lhs deleted file mode 100644 --- a/Help/Pattern/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 - -> let p = pxrand [1,2,3] 10 -> in evalP 0 p diff --git a/README b/README --- a/README +++ b/README @@ -8,5 +8,5 @@ http://haskell.org/ http://audiosynth.com/ -(c) rohan drape, 2007-2009 +(c) rohan drape, 2007-2010 gpl, http://gnu.org/copyleft/ diff --git a/Sound/SC3/Lang.hs b/Sound/SC3/Lang.hs --- a/Sound/SC3/Lang.hs +++ b/Sound/SC3/Lang.hs @@ -1,8 +1,6 @@ module Sound.SC3.Lang ( module Sound.SC3.Lang.Collection - , module Sound.SC3.Lang.Math - , module Sound.SC3.Lang.Pattern ) where + , module Sound.SC3.Lang.Math ) where import Sound.SC3.Lang.Collection import Sound.SC3.Lang.Math -import Sound.SC3.Lang.Pattern diff --git a/Sound/SC3/Lang/Collection/SequenceableCollection.hs b/Sound/SC3/Lang/Collection/SequenceableCollection.hs --- a/Sound/SC3/Lang/Collection/SequenceableCollection.hs +++ b/Sound/SC3/Lang/Collection/SequenceableCollection.hs @@ -2,6 +2,7 @@ import Control.Monad import Data.List +import Data.List.Split import Data.Maybe import Sound.SC3.Lang.Collection.Collection import System.Random @@ -54,34 +55,41 @@ -- | Collection is sorted, index of nearest element. indexIn :: (Ord a, Num a) => a -> [a] -> Int -indexIn e l = maybe (size l - 1) f (indexOfGreaterThan e l) - where f 0 = 0 - f j = if (e - left) < (right - e) then i else j - where i = j - 1 - right = l !! j - left = l !! i +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 = maybe (fromIntegral (size l) - 1) f (indexOfGreaterThan e l) - where f 0 = 0 - f j = if d == 0 then i else ((e - a) / d) + i - 1 - where i = fromIntegral j - a = l !! (j - 1) - b = l !! j - d = b - 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 | n < 0 = fromMaybe l (find (\e -> length e == negate n) (tails l)) - | otherwise = take n l +keep n l = + if n < 0 + then drop (length l + n) l + else take n l drop' :: Int -> [a] -> [a] -drop' n l | n < 0 = take (length l + n) l - | otherwise = drop n l +drop' n l = + if n < 0 + then take (length l + n) l + else drop n l extendSequences :: [[a]] -> [[a]] -extendSequences l = map (take n . cycle) l - where n = maximum (map length l) +extendSequences l = + let n = maximum (map length l) + in map (take n . cycle) l flop :: [[a]] -> [[a]] flop = transpose . extendSequences @@ -90,31 +98,35 @@ 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 x1 `g` separateAt f (x2:xs) - where g e (l,r) = (e:l, r) +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 = if null r then [e] else e : separate f r - where (e, r) = separateAt f l +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 n l = if null r then [e] else e : clump n r - where (e, r) = splitAt n l +clump = splitEvery clumps :: [Int] -> [a] -> [[a]] -clumps m s = f (cycle m) s - where f [] _ = undefined - f (n:ns) l = if null r then [e] else e :clumps ns r - where (e, r) = splitAt n l +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) = x : snd (mapAccumL f x xs) - where f p c = (p + c, p + c) +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] @@ -122,21 +134,24 @@ -- | 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 +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 +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 = g a b (False, False) - where 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 +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/Math/Pitch.hs b/Sound/SC3/Lang/Math/Pitch.hs --- a/Sound/SC3/Lang/Math/Pitch.hs +++ b/Sound/SC3/Lang/Math/Pitch.hs @@ -38,18 +38,21 @@ 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_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) +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 = (n * fromIntegral (d' `div` l)) + (s !! (d' `mod` l)) + a - where l = length s - d' = round d - a = (d - fromIntegral d') * 10.0 * (n / 12.0) +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 diff --git a/Sound/SC3/Lang/Pattern.hs b/Sound/SC3/Lang/Pattern.hs deleted file mode 100644 --- a/Sound/SC3/Lang/Pattern.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Sound.SC3.Lang.Pattern ( module Sound.SC3.Lang.Pattern.Pattern - , module Sound.SC3.Lang.Pattern.Control - , module Sound.SC3.Lang.Pattern.Extend - , module Sound.SC3.Lang.Pattern.List - , module Sound.SC3.Lang.Pattern.Random ) where - -import Sound.SC3.Lang.Pattern.Pattern -import Sound.SC3.Lang.Pattern.Control -import Sound.SC3.Lang.Pattern.Extend -import Sound.SC3.Lang.Pattern.List -import Sound.SC3.Lang.Pattern.Random diff --git a/Sound/SC3/Lang/Pattern/Control.hs b/Sound/SC3/Lang/Pattern/Control.hs deleted file mode 100644 --- a/Sound/SC3/Lang/Pattern/Control.hs +++ /dev/null @@ -1,168 +0,0 @@ -module Sound.SC3.Lang.Pattern.Control where - -import Control.Applicative -import Control.Monad -import Data.List -import Data.Maybe -import Data.Monoid -import Sound.SC3.Lang.Math.Pitch -import Sound.SC3.Lang.Pattern.Pattern - -pfilter :: (a -> Bool) -> P a -> P a -pfilter f p = pcontinue p (\x p' -> if f x - then mappend (return x) (pfilter f p') - else pfilter f p') - -plist :: [P a] -> P a -plist = foldr mappend mempty - -pcons :: a -> P a -> P a -pcons = mappend . return - -preplicate_ :: Int -> P a -> P a -preplicate_ n p | n > 0 = mappend p (preplicate_ (n - 1) p) - | otherwise = mempty - -preplicate :: P Int -> P a -> P a -preplicate n p = n >>= (\x -> preplicate_ x p) - -pn :: P a -> P Int -> P a -pn = flip preplicate - -pn_ :: P a -> Int -> P a -pn_ = flip preplicate_ - --- | 'n' initial values at 'p'. -ptake_ :: Int -> P a -> P a -ptake_ n p = pzipWith const p (preplicate_ n (return undefined)) - -ptake :: P Int -> P a -> P a -ptake n p = pzipWith const p (preplicate n (return undefined)) - --- | 'n' initial values at pcycle of 'p'. -prestrict_ :: Int -> P a -> P a -prestrict_ n = ptake_ n . pcycle - -prestrict :: P Int -> P a -> P a -prestrict n = ptake n . pcycle - -pmapMaybe :: (a -> Maybe b) -> P a -> P b -pmapMaybe f = fmap fromJust . pfilter isJust . fmap f - -preject :: (a -> Bool) -> P a -> P a -preject f = pfilter (not . f) - -pzipWith3 :: (a -> b -> c -> d) -> P a -> P b -> P c -> P d -pzipWith3 f p q = (<*>) (pure f <*> p <*> q) - -pzip :: P a -> P b -> P (a,b) -pzip = pzipWith (,) - -pseries :: (Num a) => a -> a -> Int -> P a -pseries i s n = plist (unfoldr f (i, n)) - where f (_, 0) = Nothing - f (j, m) = Just (return j, (j + s, m - 1)) - -pgeom :: (Num a) => a -> a -> Int -> P a -pgeom i s n = plist (unfoldr f (i, n)) - where f (_, 0) = Nothing - f (j, m) = Just (return j, (j * s, m - 1)) - -pstutter' :: P Int -> P a -> P a -pstutter' n p = - let f :: Int -> a -> P a - f i e = preplicate (return i) (return e) - in psequence (pzipWith f n p) - -pstutter :: P Int -> P a -> P a -pstutter = pstutter' . pcycle - --- | Count false values preceding each true value. -pcountpre :: P Bool -> P Int -pcountpre p = pmapMaybe id (pscan f Nothing 0 p) - where f x e = if e then (0, Just x) else (x + 1, Nothing) - --- | Count false values following each true value. -pcountpost :: P Bool -> P Int -pcountpost p = ptail (pmapMaybe id (pscan f (Just Just) 0 p)) - where f x e = if e then (0, Just x) else (x + 1, Nothing) - -pclutch' :: P a -> P Bool -> P a -pclutch' p q = pstutter' r p - where r = fmap (+ 1) (pcountpost q) - -pbool :: (Ord a, Num a) => P a -> P Bool -pbool = fmap (> 0) - -pclutch :: (Num b, Ord b) => P a -> P b -> P a -pclutch p = pclutch' p . pbool - -pcollect :: (a -> b) -> P a -> P b -pcollect = fmap - -pdegreeToKey :: (RealFrac a) => P a -> P [a] -> P a -> P a -pdegreeToKey = pzipWith3 degree_to_key - -pfin :: P Int -> P a -> P a -pfin = ptake - -pfin_ :: Int -> P a -> P 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 a -> P a -> P a -> P a -pwrap x l r = pzipWith3 f x (pcycle l) (pcycle r) - where f x' l' r' = wrap l' r' x' - --- | Remove successive duplicates. -prsd :: (Eq a) => P a -> P a -prsd p = pmapMaybe id (pscan f Nothing Nothing p) - where f Nothing a = (Just a, Just a) - f (Just x) a = (Just a, if a == x then Nothing else Just a) - -psequence :: P (P a) -> P a -psequence = join - -pduple :: (a, a) -> P a -pduple (x, y) = return x `mappend` return y - -pinterleave :: P a -> P a -> P a -pinterleave p = psequence . fmap pduple . pzip p - -ptrigger :: P Bool -> P a -> P (Maybe a) -ptrigger p q = join (pzipWith f r q) - where r = pcountpre p - f i = mappend (preplicate_ i (return Nothing)) . return . Just - -pif :: Int -> P Bool -> P a -> P a -> P a -pif s b p q = pzipWith f p' q' - where b' = pfix s b - p' = ptrigger b' p - q' = ptrigger (fmap not b') q - f (Just x) Nothing = x - f Nothing (Just x) = x - f _ _ = undefined - -pif' :: P Bool -> P a -> P a -> P a -pif' = pif 0 - -phead :: P a -> P a -phead p = pcontinue p (\x _ -> return x) - -ptail :: P a -> P a -ptail p = pcontinue p (\_ p' -> p') - -pdrop :: P Int -> P a -> P a -pdrop n p = n >>= (\x -> if x > 0 - then pdrop (return (x-1)) (ptail p) - else p) - -pscanl :: (a -> y -> a) -> a -> P y -> P a -pscanl f i p = pcons i (pscan g Nothing i p) - where g x y = let r = f x y in (r, r) diff --git a/Sound/SC3/Lang/Pattern/Extend.hs b/Sound/SC3/Lang/Pattern/Extend.hs deleted file mode 100644 --- a/Sound/SC3/Lang/Pattern/Extend.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Sound.SC3.Lang.Pattern.Extend where - -import Sound.SC3.Lang.Pattern.Pattern - -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 (/) - -(-.) :: Num a => P a -> P a -> P a -(-.) = pzipWith_c (-) 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,51 +1,335 @@ module Sound.SC3.Lang.Pattern.List where -import qualified Data.IntMap as M -import Data.List -import Data.Monoid -import Sound.SC3.Lang.Pattern.Pattern -import Sound.SC3.Lang.Pattern.Control +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 -pseq_ :: [P a] -> Int -> P a -pseq_ l n = plist (concat (replicate n l)) +data P a = P { unP :: [a] } -pseq :: [P a] -> P Int -> P a -pseq l n = n >>= (\x -> plist (concat (replicate x l))) +-- * Instances --- | 'n' values from the infinite cycle of the streams at l. -pser_ :: [P a] -> Int -> P a -pser_ l n = prestrict_ n (plist l) +instance A.Alternative P where + empty = pempty + (<|>) = pappend +instance A.Applicative P where + pure = M.return + (<*>) = M.ap + +instance F.Foldable P where + foldr = pfoldr + +instance (Fractional a) => Fractional (P a) where + (/) = pzipWith (/) + recip = fmap recip + fromRational = return . fromRational + +instance Functor P where + fmap f = P . fmap f . unP + +instance (Eq a) => Eq (P a) where + (P p) == (P q) = p == q + +instance Monad P where + m >>= f = pconcatMap f m + return x = P [x] + +instance M.MonadPlus P where + mzero = pempty + mplus = pappend + +instance M.Monoid (P a) where + mempty = pempty + mappend = pappend + +instance (Num a) => Num (P a) where + (+) = pzipWith (+) + (-) = pzipWith (-) + (*) = pzipWith (*) + abs = fmap abs + signum = fmap signum + fromInteger = return . fromInteger + negate = fmap negate + +instance (Show a) => Show (P a) where + show = show . unP + +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) + +-- * Basic constructors + +pinf :: P Int +pinf = return 83886028 -- 2 ^^ 23 + +-- * List functions + +bool :: (Functor f, Ord a, Num a) => f a -> f Bool +bool = fmap (> 0) + +clutch :: [a] -> [Bool] -> [a] +clutch p q = + let r = fmap (+ 1) (countpost q) + in stutter r p + +-- | Count false values following each true value. +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 + 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 + in f 0 + +interleave :: [a] -> [a] -> [a] +interleave p [] = p +interleave [] q = q +interleave (p:ps) (q:qs) = p : q : interleave ps qs + +-- | 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 + +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 l n = prestrict n (plist l) +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 !!) -pswitch1m :: M.IntMap (P a) -> P Int -> P a -pswitch1m m is = let f i js = let h = phead (m M.! i) - t = ptail (m M.! i) - in h `mappend` pswitch1m (M.insert i t m) js - in pcontinue is f - pswitch1 :: [P a] -> P Int -> P a -pswitch1 = pswitch1m . M.fromList . zip [0..] +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 -ppatlace :: [P a] -> P Int -> P a -ppatlace ps n = let is = pseq (map return [0 .. length ps - 1]) pinf - in ptake n (pswitch1 ps is) +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 -Neither the definition above or the variant below are correct. -Both deadlock once all patterns are empty. pswitch1 has the -same problem. +ptrigger :: P Bool -> P a -> P (Maybe a) +ptrigger (P p) (P q) = P (trigger p q) -ppatlacea :: P (P a) -> P 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 --} +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 (/) + +(-.) :: Num a => P a -> P a -> P a +(-.) = pzipWith_c (-) diff --git a/Sound/SC3/Lang/Pattern/Pattern.hs b/Sound/SC3/Lang/Pattern/Pattern.hs deleted file mode 100644 --- a/Sound/SC3/Lang/Pattern/Pattern.hs +++ /dev/null @@ -1,167 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} - -module Sound.SC3.Lang.Pattern.Pattern - ( P - , pfoldr, evalP - , pfix - , pcontinue - , pmap -- Prelude.fmap - , punfoldr -- Data.List.unfoldr - , preturn -- Control.Monad.return - , pbind -- Control.Monad.(>>=) - , pempty -- Data.Monoid.mempty - , pappend -- Data.Monoid.mappend - , ppure -- Control.Applicative.pure - , papply -- Control.Applicative.(<*>) - , prp - , pscan - , pinf - , pzipWith - , pcycle - , prepeat ) where - -import Control.Applicative -import Data.Monoid -import System.Random - -data P a = Empty - | Value a - | RP (StdGen -> (P a, StdGen)) - | Append (P a) (P a) - | Fix StdGen (P a) - | forall x . Unfoldr (x -> Maybe (a, x)) x - | forall x . Continue (P x) (x -> P x -> P a) - | forall x . Apply (P (x -> a)) (P x) - | forall x y . Scan (x -> y -> (x, a)) (Maybe (x -> a)) x (P y) - -data Result a = Result StdGen a (P a) - | Done StdGen - -step :: StdGen -> P a -> Result a -step g Empty = Done g -step g (Value a) = Result g a pempty -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 (Fix fg p) = case step fg p of - Done _ -> Done g - Result fg' x p' -> Result g x (Fix fg' p') -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') - -pfoldr' :: StdGen -> (a -> b -> b) -> b -> P 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') - -pfoldr :: Seed -> (a -> b -> b) -> b -> P a -> b -pfoldr = pfoldr' . mkStdGen - -evalP :: Int -> P a -> [a] -evalP n = pfoldr n (:) [] - -instance (Show a) => Show (P a) where - show _ = show "a pattern" - -instance (Eq a) => Eq (P a) where - _ == _ = False - --- | Apply `f' pointwise to elements of `p' and `q'. -pzipWith :: (a -> b -> c) -> P a -> P b -> P c -pzipWith f p = (<*>) (pure f <*> p) - -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 - -pcycle :: P a -> P a -pcycle x = x `mappend` pcycle x - -prepeat :: a -> P a -prepeat = pcycle . return - -pmap :: (a -> b) -> P a -> P b -pmap = (<*>) . prepeat - -instance Functor P where - fmap = pmap - -instance Monad P where - (>>=) = pbind - return = preturn - -instance Monoid (P a) where - mempty = pempty - mappend = pappend - -ppure :: a -> P a -ppure = prepeat - -instance Applicative P where - pure = ppure - (<*>) = papply - --- * Basic constructors - -pempty :: P a -pempty = Empty - -preturn :: a -> P a -preturn = Value - -prp :: (StdGen -> (P a, StdGen)) -> P a -prp = RP - -pinf :: P Int -pinf = return 83886028 -- 2 ^^ 23 - -pappend :: P a -> P a -> P a -pappend = Append - -type Seed = Int - -pfix :: Seed -> P a -> P a -pfix = Fix . mkStdGen - -pcontinue :: P x -> (x -> P x -> P a) -> P a -pcontinue = Continue - -pbind :: P x -> (x -> P a) -> P a -pbind p f = pcontinue p (\x q -> f x `mappend` pbind q f) - -papply :: P (a -> b) -> P a -> P b -papply = Apply - -pscan :: (x -> y -> (x, a)) -> Maybe (x -> a) -> x -> P y -> P a -pscan = Scan - -punfoldr :: (x -> Maybe (a, x)) -> x -> P a -punfoldr = Unfoldr diff --git a/Sound/SC3/Lang/Pattern/Random.hs b/Sound/SC3/Lang/Pattern/Random.hs deleted file mode 100644 --- a/Sound/SC3/Lang/Pattern/Random.hs +++ /dev/null @@ -1,43 +0,0 @@ -module Sound.SC3.Lang.Pattern.Random where - -import Control.Monad -import Data.Array -import Data.List -import Sound.SC3.Lang.Pattern.Pattern -import Sound.SC3.Lang.Pattern.Control -import Sound.SC3.Lang.Pattern.List -import System.Random - --- Random numbers - -prrandf :: (Random a) => (a -> a -> a -> a) -> a -> a -> P a -prrandf f l r = prp (\g -> let (x, g') = randomR (l,r) g - in (preturn (f l r x), g')) - -prrand :: (Random a) => a -> a -> P a -prrand = prrandf (\_ _ x -> x) - -prrandexp :: (Floating a, Random a) => a -> a -> P a -prrandexp = prrandf (\l r x -> l * (log (r / l) * x)) - -pchoosea :: Array Int (P a) -> P a -pchoosea r = prp (\g -> let (i, g') = randomR (bounds r) g - in (r ! i, g')) - -pchoose :: [P a] -> P a -pchoose l = pchoosea (listArray (0, length l - 1) l) - -prand :: [P a] -> P Int -> P a -prand p = pseq [pchoose p] - -pwhite :: (Random a) => P a -> P a -> P Int -> P a -pwhite l r n = prestrict n (join (pzipWith prrand l r)) - -pexprand :: (Floating a, Random a) => P a -> P a -> P Int -> P a -pexprand l r n = prestrict n (join (pzipWith prrandexp l r)) - -pxrand :: (Eq a) => [P a] -> P Int -> P a -pxrand p n = ptake n (prsd (pseq [pchoose p] pinf)) - -pwrand :: [P a] -> [P a] -> P Int -> P a -pwrand = undefined diff --git a/Sound/SC3/Lang/Pattern/Step.hs b/Sound/SC3/Lang/Pattern/Step.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Pattern/Step.hs @@ -0,0 +1,440 @@ +{-# 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/hsc3-lang.cabal b/hsc3-lang.cabal --- a/hsc3-lang.cabal +++ b/hsc3-lang.cabal @@ -1,70 +1,42 @@ Name: hsc3-lang -Version: 0.7 +Version: 0.8 Synopsis: Haskell SuperCollider Language Description: Haskell library defining operations from the SuperCollider language class library License: GPL Category: Sound -Copyright: (c) Rohan Drape, 2007-2009 +Copyright: (c) Rohan Drape, 2007-2010 Author: Rohan Drape Maintainer: rd@slavepianos.org Stability: Experimental -Homepage: http://slavepianos.org/rd/f/649352/ -Tested-With: GHC == 6.8.2 +Homepage: http://slavepianos.org/rd/?t=hsc3-lang +Tested-With: GHC == 6.10.3 Build-Type: Simple Cabal-Version: >= 1.6 Data-files: README - -- The below is appended by: - -- find Help -name "*.*hs" | sort | \ - -- sed "s/^/ /" >> hsc3-lang.cabal - Help/Collection/collection.help.lhs - Help/Math/pitch.help.lhs - Help/Pattern/pattern.help.lhs - Help/Pattern/pclutch.help.lhs - Help/Pattern/pcollect.help.lhs - Help/Pattern/pcountpre.help.lhs - Help/Pattern/pdegreeToKey.help.lhs - Help/Pattern/pdrop.help.lhs - Help/Pattern/pexprand.help.lhs - Help/Pattern/pfilter.help.lhs - Help/Pattern/pfin.help.lhs - Help/Pattern/pgeom.help.lhs - Help/Pattern/pif.help.lhs - Help/Pattern/pinterleave.help.lhs - Help/Pattern/pn.help.lhs - Help/Pattern/prand.help.lhs - Help/Pattern/preject.help.lhs - Help/Pattern/prorate.help.lhs - Help/Pattern/prsd.help.lhs - Help/Pattern/pseq.help.lhs - Help/Pattern/pser.help.lhs - Help/Pattern/pseries.help.lhs - Help/Pattern/pstutter.help.lhs - Help/Pattern/pswitch1.help.lhs - Help/Pattern/pswitch.help.lhs - Help/Pattern/ptail.help.lhs - Help/Pattern/ptrigger.help.lhs - Help/Pattern/pwhite.help.lhs - Help/Pattern/pwrap.help.lhs - Help/Pattern/pxrand.help.lhs + Help/Collection/*.help.lhs + Help/Math/*.help.lhs + Help/Pattern/List/*.help.lhs + Help/Pattern/Step/*.help.lhs Library Build-Depends: array, - base == 3.*, + base == 4.*, containers, + split, random GHC-Options: -Wall -fwarn-tabs Exposed-modules: Sound.SC3.Lang Sound.SC3.Lang.Collection - Sound.SC3.Lang.Math - Sound.SC3.Lang.Pattern - Other-modules: Sound.SC3.Lang.Collection.Collection + Sound.SC3.Lang.Collection.Collection Sound.SC3.Lang.Collection.Numerical Sound.SC3.Lang.Collection.SequenceableCollection + Sound.SC3.Lang.Math Sound.SC3.Lang.Math.Pitch - Sound.SC3.Lang.Pattern.Pattern - Sound.SC3.Lang.Pattern.Extend - Sound.SC3.Lang.Pattern.Control Sound.SC3.Lang.Pattern.List - Sound.SC3.Lang.Pattern.Random + Sound.SC3.Lang.Pattern.Step + +Source-Repository head + Type: darcs + Location: http://slavepianos.org/~rd/sw/hsc3-lang/