diff --git a/README b/README --- a/README +++ b/README @@ -5,7 +5,7 @@ module that defines a subset of functions from the [SuperCollider Language][sc3] class library. -© [rohan drape][rd], 2007-2012, [gpl][gpl]. +© [rohan drape][rd], 2007-2013, [gpl][gpl]. [hs]: http://haskell.org/ [sc3]: http://audiosynth.com/ diff --git a/Sound/SC3/Lang/Collection.hs b/Sound/SC3/Lang/Collection.hs --- a/Sound/SC3/Lang/Collection.hs +++ b/Sound/SC3/Lang/Collection.hs @@ -3,23 +3,23 @@ -- becomes @m i j c@. module Sound.SC3.Lang.Collection where -import Data.List.Split {- split -} -import Data.List as L -import Data.Maybe +import qualified Data.List.Split as S {- split -} +import Data.List as L {- base -} +import Data.Maybe {- base -} -- * Collection -- | @Collection.*fill@ is 'map' over indices to /n/. -- -- > fill 4 (* 2) == [0,2,4,6] -fill :: Int -> (Int -> a) -> [a] +fill :: (Enum n,Num n) => n -> (n -> a) -> [a] fill n f = map f [0 .. n - 1] -- | @Collection.size@ is 'length'. -- -- > size [1,2,3,4] == 4 -size :: [a] -> Int -size = length +size :: Integral n => [a] -> n +size = genericLength -- | @Collection.isEmpty@ is 'null'. -- @@ -30,40 +30,40 @@ -- | Function equal to 'const' of /f/ of /e/. -- -- > select (ignoringIndex even) [1,2,3,4] == [2,4] -ignoringIndex :: (a -> b) -> a -> Int -> b +ignoringIndex :: (a -> b) -> a -> z -> b ignoringIndex f e = const (f e) -- | @Collection.collect@ is 'map' with element indices. -- -- > collect (\i _ -> i + 10) [1,2,3,4] == [11,12,13,14] -- > collect (\_ j -> j + 11) [1,2,3,4] == [11,12,13,14] -collect :: (a -> Int -> b) -> [a] -> [b] +collect :: Integral i => (a -> i -> b) -> [a] -> [b] collect f l = zipWith f l [0..] -- | @Collection.select@ is 'filter' with element indices. -- -- > select (\i _ -> even i) [1,2,3,4] == [2,4] -- > select (\_ j -> even j) [1,2,3,4] == [1,3] -select :: (a -> Int -> Bool) -> [a] -> [a] +select :: Integral i => (a -> i -> Bool) -> [a] -> [a] select f l = map fst (filter (uncurry f) (zip l [0..])) -- | @Collection.reject@ is negated 'filter' with element indices. -- -- > reject (\i _ -> even i) [1,2,3,4] == [1,3] -- > reject (\_ j -> even j) [1,2,3,4] == [2,4] -reject :: (a -> Int -> Bool) -> [a] -> [a] +reject :: Integral i => (a -> i -> Bool) -> [a] -> [a] reject f l = map fst (filter (not . uncurry f) (zip l [0..])) -- | @Collection.detect@ is 'first' '.' 'select'. -- -- > detect (\i _ -> even i) [1,2,3,4] == Just 2 -detect :: (a -> Int -> Bool) -> [a] -> Maybe a +detect :: Integral i => (a -> i -> Bool) -> [a] -> Maybe a detect f l = fmap fst (find (uncurry f) (zip l [0..])) -- | @Collection.detectIndex@ is the index locating variant of 'detect'. -- -- > detectIndex (\i _ -> even i) [1,2,3,4] == Just 1 -detectIndex :: (a -> Int -> Bool) -> [a] -> Maybe Int +detectIndex :: Integral i => (a -> i -> Bool) -> [a] -> Maybe i detectIndex f l = fmap snd (find (uncurry f) (zip l [0..])) -- | @Collection.inject@ is a variant on 'foldl'. @@ -76,13 +76,13 @@ -- | @Collection.any@ is 'True' if 'detect' is not 'Nothing'. -- -- > any' (\i _ -> even i) [1,2,3,4] == True -any' :: (a -> Int -> Bool) -> [a] -> Bool +any' :: Integral i => (a -> i -> Bool) -> [a] -> Bool any' f = isJust . detect f -- | @Collection.every@ is 'True' if /f/ applies at all elements. -- -- > every (\i _ -> even i) [1,2,3,4] == False -every :: (a -> Int -> Bool) -> [a] -> Bool +every :: Integral i => (a -> i -> Bool) -> [a] -> Bool every f = let g e = not . f e in not . any' g @@ -90,32 +90,32 @@ -- | @Collection.count@ is 'length' '.' 'select'. -- -- > count (\i _ -> even i) [1,2,3,4] == 2 -count :: (a -> Int -> Bool) -> [a] -> Int -count f = length . select f +count :: Integral i => (a -> i -> Bool) -> [a] -> i +count f = genericLength . select f -- | @Collection.occurencesOf@ is an '==' variant of 'count'. -- -- > occurencesOf 2 [1,2,3,4] == 1 -- > occurencesOf 't' "test" == 2 -occurencesOf :: (Eq a) => a -> [a] -> Int +occurencesOf :: (Integral i,Eq a) => a -> [a] -> i occurencesOf k = count (\e _ -> e == k) -- | @Collection.sum@ is 'sum' '.' 'collect'. -- -- > sum' (ignoringIndex (* 2)) [1,2,3,4] == 20 -sum' :: (Num a) => (b -> Int -> a) -> [b] -> a +sum' :: (Num a,Integral i) => (b -> i -> a) -> [b] -> a sum' f = sum . collect f -- | @Collection.maxItem@ is 'maximum' '.' 'collect'. -- -- > maxItem (ignoringIndex (* 2)) [1,2,3,4] == 8 -maxItem :: (Ord b) => (a -> Int -> b) -> [a] -> b +maxItem :: (Ord b,Integral i) => (a -> i -> b) -> [a] -> b maxItem f = maximum . collect f -- | @Collection.minItem@ is 'maximum' '.' 'collect'. -- -- > minItem (ignoringIndex (* 2)) [1,2,3,4] == 2 -minItem :: (Ord b) => (a -> Int -> b) -> [a] -> b +minItem :: (Integral i,Ord b) => (a -> i -> b) -> [a] -> b minItem f = minimum . collect f -- | Variant of 'zipWith' that cycles the shorter input. @@ -129,7 +129,7 @@ g (a0 : aN) (b0 : bN) e = f a0 b0 : g aN bN e in g a b (False,False) --- | 'zipWith_c' base variant of 'zip'. +-- | 'zipWith_c' variant of 'zip'. -- -- > zip_c [1,2] [3,4,5] == [(1,3),(2,4),(1,5)] zip_c :: [a] -> [b] -> [(a,b)] @@ -162,15 +162,15 @@ -- | @SequenceableCollection.*series@ is an arithmetic series with -- arguments /size/, /start/ and /step/. -- --- > Array.series(5,10,2) == [10,12,14,16,18] +-- > > Array.series(5,10,2) == [10,12,14,16,18] -- > series 5 10 2 == [10,12 .. 18] -- -- Note that this is quite different from the SimpleNumber.series -- method, which is equal to 'enumFromThenTo'. -- --- > 5.series(7,10) == [5,7,9] +-- > > 5.series(7,10) == [5,7,9] -- > enumFromThenTo 5 7 10 == [5,7,9] -series :: (Num a) => Int -> a -> a -> [a] +series :: (Num a,Integral i) => i -> a -> a -> [a] series n i j = case n of 0 -> [] @@ -179,9 +179,9 @@ -- | @SequenceableCollection.*geom@ is a geometric series with arguments -- /size/, /start/ and /grow/. -- --- > Array.geom(5,3,6) == [3,18,108,648,3888] +-- > > Array.geom(5,3,6) == [3,18,108,648,3888] -- > geom 5 3 6 == [3,18,108,648,3888] -geom :: (Num a) => Int -> a -> a -> [a] +geom :: (Integral i,Num a) => i -> a -> a -> [a] geom n i j = case n of 0 -> [] @@ -191,9 +191,9 @@ -- is number of elements, /i/ is the initial step and /j/ the initial -- value. -- --- > Array.fib(5,2,32) == [32,34,66,100,166] +-- > > Array.fib(5,2,32) == [32,34,66,100,166] -- > fib 5 2 32 == [32,34,66,100,166] -fib :: (Num a) => Int -> a -> a -> [a] +fib :: (Integral i,Num a) => i -> a -> a -> [a] fib n i j = case n of 0 -> [] @@ -201,11 +201,11 @@ -- | @SequenceableCollection.first@ is a total variant of 'L.head'. -- --- > [3,4,5].first == 3 +-- > > [3,4,5].first == 3 -- > first [3,4,5] == Just 3 -- > first' [3,4,5] == 3 -- --- > [].first == nil +-- > > [].first == nil -- > first [] == Nothing first :: [t] -> Maybe t first xs = @@ -219,11 +219,11 @@ -- | Total variant of 'L.last'. -- --- > (1..5).last == 5 +-- > > (1..5).last == 5 -- > lastM [1..5] == Just 5 -- > L.last [1..5] == 5 -- --- > [].last == nil +-- > > [].last == nil -- > lastM [] == Nothing lastM :: [t] -> Maybe t lastM xs = @@ -243,7 +243,7 @@ -- | @SequenceableCollection.indexOf@ is a variant of 'elemIndex' with -- reversed arguments. -- --- > [3,4,100,5].indexOf(100) == 2 +-- > > [3,4,100,5].indexOf(100) == 2 -- > indexOf [3,4,100,5] 100 == Just 2 indexOf :: Eq a => [a] -> a -> Maybe Int indexOf = flip elemIndex @@ -287,43 +287,43 @@ b = l !! j d = b - a in if d == 0 then i else ((e - a) / d) + i - 1 - in maybe (fromIntegral (size l) - 1) f (indexOfGreaterThan e l) + in maybe (fromInteger (size l) - 1) f (indexOfGreaterThan e l) -- | @SequenceableCollection.keep@ is, for positive /n/ a synonym for --- 'take', and for negative /n/ a variant on 'L.drop' based on the +-- 'L.take', and for negative /n/ a variant on 'L.drop' based on the -- 'length' of /l/. -- --- > [1,2,3,4,5].keep(3) == [1,2,3] +-- > > [1,2,3,4,5].keep(3) == [1,2,3] -- > keep 3 [1,2,3,4,5] == [1,2,3] -- --- > [1,2,3,4,5].keep(-3) == [3,4,5] +-- > > [1,2,3,4,5].keep(-3) == [3,4,5] -- > keep (-3) [1,2,3,4,5] == [3,4,5] -- --- > [1,2].keep(-4) == [1,2] +-- > > [1,2].keep(-4) == [1,2] -- > keep (-4) [1,2] == [1,2] -keep :: Int -> [a] -> [a] +keep :: Integral i => i -> [a] -> [a] keep n l = if n < 0 - then L.drop (length l + n) l - else take n l + then L.genericDrop (genericLength l + n) l + else genericTake n l -- | @SequenceableCollection.drop@ is, for positive /n/ a synonym for --- 'L.drop', for negative /n/ a variant on 'take' based on the --- 'length' of /l/. +-- 'L.drop', for negative /n/ a variant on 'L.take' based on the +-- 'L.length' of /l/. -- --- > [1,2,3,4,5].drop(3) == [4,5] --- > drop 3 [1,2,3,4,5] == [4,5] +-- > > [1,2,3,4,5].drop(3) == [4,5] +-- > L.drop 3 [1,2,3,4,5] == [4,5] -- --- > [1,2,3,4,5].drop(-3) == [1,2] --- > drop (-3) [1,2,3,4,5] == [1,2] +-- > > [1,2,3,4,5].drop(-3) == [1,2] +-- > Sound.SC3.Lang.Collection.drop (-3) [1,2,3,4,5] == [1,2] -- --- > [1,2].drop(-4) == [] --- > drop (-4) [1,2] == [] -drop :: Int -> [a] -> [a] +-- > > [1,2].drop(-4) == [] +-- > Sound.SC3.Lang.Collection.drop (-4) [1,2] == [] +drop :: Integral i => i -> [a] -> [a] drop n l = if n < 0 - then take (length l + n) l - else L.drop n l + then L.genericTake (L.genericLength l + n) l + else L.genericDrop n l -- | Function to calculate a list equal in length to the longest input -- list, therefore being productive over infinite lists. @@ -340,15 +340,15 @@ -- | @SequenceableCollection.flop@ is a variant of 'transpose' that -- cycles input sequences and extends rather than truncates. -- --- > [(1..3),(4..5),(6..9)].flop == [[1,4,6],[2,5,7],[3,4,8],[1,5,9]] +-- > > [(1..3),(4..5),(6..9)].flop == [[1,4,6],[2,5,7],[3,4,8],[1,5,9]] -- > flop [[1..3],[4..5],[6..9]] == [[1,4,6],[2,5,7],[3,4,8],[1,5,9]] -- --- > [[1,2,3],[4,5,6],[7,8]].flop == [[1,4,7],[2,5,8],[3,6,7]] +-- > > [[1,2,3],[4,5,6],[7,8]].flop == [[1,4,7],[2,5,8],[3,6,7]] -- > flop [[1,2,3],[4,5,6],[7,8]] == [[1,4,7],[2,5,8],[3,6,7]] -- -- The null case at 'flop' is not handled equivalently to SC3 -- --- > [].flop == [[]] +-- > > [].flop == [[]] -- > flop [] /= [[]] -- > flop [] == [] -- @@ -362,56 +362,24 @@ let l' = map cycle l in zipWith (\_ x -> x) (extension l) (transpose l') --- * List and Array - --- | @List.lace@ is a concatenated transposition of cycled --- subsequences. --- --- > [[1,2,3],[6],[8,9]].lace(12) == [1,6,8,2,6,9,3,6,8,1,6,9] --- > lace 12 [[1,2,3],[6],[8,9]] == [1,6,8,2,6,9,3,6,8,1,6,9] -lace :: Int -> [[a]] -> [a] -lace n = take n . concat . transpose . map cycle - --- | @List.wrapExtend@ extends a sequence by --- /cycling/. 'wrapExtend' is in terms of 'take' and 'cycle'. +-- | @SequenceableCollection.integrate@ is the incremental sum of +-- elements. -- --- > [1,2,3,4,5].wrapExtend(9) == [1,2,3,4,5,1,2,3,4] --- > wrapExtend 9 [1,2,3,4,5] == [1,2,3,4,5,1,2,3,4] -wrapExtend :: Int -> [a] -> [a] -wrapExtend n = take n . cycle - --- | Infinite variant of 'foldExtend'. -cycleFold :: [a] -> [a] -cycleFold = cycle . mirror1 +-- > > [3,4,1,1].integrate == [3,7,8,9] +-- > integrate [3,4,1,1] == [3,7,8,9] +integrate :: (Num a) => [a] -> [a] +integrate = scanl1 (+) --- | @List.foldExtend@ extends sequence by /folding/ backwards at end. --- 'foldExtend' is in terms of 'cycleFold', which is in terms of --- 'mirror1'. +-- | @SequenceableCollection.differentiate@ is the pairwise difference +-- between elements, with an implicit @0@ at the start. -- --- > [1,2,3,4,5].foldExtend(10) --- > foldExtend 10 [1,2,3,4,5] == [1,2,3,4,5,4,3,2,1,2] -foldExtend :: Int -> [a] -> [a] -foldExtend n = take n . cycleFold - --- | @Array.clipExtend@ extends sequence by repeating last element. +-- > > [3,4,1,1].differentiate == [3,1,-3,0] +-- > differentiate [3,4,1,1] == [3,1,-3,0] -- --- > [1,2,3,4,5].clipExtend(9) == [1,2,3,4,5,5,5,5,5] --- > clipExtend 9 [1,2,3,4,5] == [1,2,3,4,5,5,5,5,5] -clipExtend :: Int -> [a] -> [a] -clipExtend n = take n . cycleClip - --- | Infinite variant of 'clipExtend'. -cycleClip :: [a] -> [a] -cycleClip l = - case lastM l of - Nothing -> [] - Just e -> l ++ repeat e - --- | Cycle input sequences to 'extension' of input. -extendSequences :: [[a]] -> [[a]] -extendSequences l = - let f = zipWith (\_ x -> x) (extension l) . cycle - in map f l +-- > > [0,3,1].differentiate == [0,3,-2] +-- > differentiate [0,3,1] == [0,3,-2] +differentiate :: (Num a) => [a] -> [a] +differentiate l = zipWith (-) l (0:l) -- | Variant of 'separate' that performs initial separation. separateAt :: (a -> a -> Bool) -> [a] -> ([a],[a]) @@ -428,10 +396,10 @@ -- each adjacent pair of elements at /l/. If the predicate is 'True', -- then a separation is made between the elements. -- --- > [3,2,1,2,3,2].separate({|a,b| a > [3,2,1,2,3,2].separate({|a,b| a separate (<) [3,2,1,2,3,2] == [[3,2,1],[2],[3,2]] -- --- > [1,2,3,5,6,8].separate({|a,b| (b - a) > 1}) == [[1,2,3],[5,6],[8]] +-- > > [1,2,3,5,6,8].separate({|a,b| (b - a) > 1}) == [[1,2,3],[5,6],[8]] -- > separate (\a b -> (b - a) > 1) [1,2,3,5,6,8] == [[1,2,3],[5,6],[8]] separate :: (a -> a -> Bool) -> [a] -> [[a]] separate f l = @@ -439,17 +407,17 @@ in if null r then [e] else e : separate f r -- | @SequenceableCollection.clump@ is a synonym for --- 'Data.List.Split.splitEvery'. +-- 'Data.List.Split.chunksOf'. -- --- > [1,2,3,4,5,6,7,8].clump(3) == [[1,2,3],[4,5,6],[7,8]] +-- > > [1,2,3,4,5,6,7,8].clump(3) == [[1,2,3],[4,5,6],[7,8]] -- > clump 3 [1,2,3,4,5,6,7,8] == [[1,2,3],[4,5,6],[7,8]] clump :: Int -> [a] -> [[a]] -clump = chunksOf +clump = S.chunksOf -- | @SequenceableCollection.clumps@ is a synonym for -- 'Data.List.Split.splitPlaces'. -- --- > [1,2,3,4,5,6,7,8].clumps([1,2]) == [[1],[2,3],[4],[5,6],[7],[8]] +-- > > [1,2,3,4,5,6,7,8].clumps([1,2]) == [[1],[2,3],[4],[5,6],[7],[8]] -- > clumps [1,2] [1,2,3,4,5,6,7,8] == [[1],[2,3],[4],[5,6],[7],[8]] clumps :: [Int] -> [a] -> [[a]] clumps m s = @@ -460,39 +428,62 @@ [] -> [] _ -> f (cycle m) s --- | @SequenceableCollection.integrate@ is the incremental sum of --- elements. +-- * List and Array + +-- | @List.lace@ is a concatenated transposition of cycled +-- subsequences. -- --- > integrate [3,4,1,1] == [3,7,8,9] -integrate :: (Num a) => [a] -> [a] -integrate = scanl1 (+) +-- > > [[1,2,3],[6],[8,9]].lace(12) == [1,6,8,2,6,9,3,6,8,1,6,9] +-- > lace 12 [[1,2,3],[6],[8,9]] == [1,6,8,2,6,9,3,6,8,1,6,9] +lace :: Integral i => i -> [[a]] -> [a] +lace n = genericTake n . concat . transpose . map cycle --- | @SequenceableCollection.differentiate@ is the pairwise difference --- between elements. +-- | @List.wrapExtend@ extends a sequence by +-- /cycling/. 'wrapExtend' is in terms of 'take' and 'cycle'. -- --- > differentiate [3,4,1,1] == [3,1,-3,0] -differentiate :: (Num a) => [a] -> [a] -differentiate l = zipWith (-) l (0:l) +-- > > [1,2,3,4,5].wrapExtend(9) == [1,2,3,4,5,1,2,3,4] +-- > wrapExtend 9 [1,2,3,4,5] == [1,2,3,4,5,1,2,3,4] +wrapExtend :: Integral i => i -> [a] -> [a] +wrapExtend n = genericTake n . cycle --- | Rotate /n/ places to the left. +-- | Infinite variant of 'foldExtend'. +cycleFold :: [a] -> [a] +cycleFold = cycle . mirror1 + +-- | @List.foldExtend@ extends sequence by /folding/ backwards at end. +-- 'foldExtend' is in terms of 'cycleFold', which is in terms of +-- 'mirror1'. -- --- > rotateLeft 3 [1..7] == [4,5,6,7,1,2,3] -rotateLeft :: Int -> [a] -> [a] -rotateLeft n p = - let (b,a) = splitAt n p - in a ++ b +-- > > [1,2,3,4,5].foldExtend(10) +-- > foldExtend 10 [1,2,3,4,5] == [1,2,3,4,5,4,3,2,1,2] +foldExtend :: Integral i => i -> [a] -> [a] +foldExtend n = genericTake n . cycleFold --- | Rotate /n/ places to the right. +-- | @Array.clipExtend@ extends sequence by repeating last element. -- --- > rotateRight 3 [1..7] == [5,6,7,1,2,3,4] -rotateRight :: Int -> [a] -> [a] -rotateRight n p = - let k = length p - (b,a) = splitAt (k - n) p - in a ++ b +-- > > [1,2,3,4,5].clipExtend(9) == [1,2,3,4,5,5,5,5,5] +-- > clipExtend 9 [1,2,3,4,5] == [1,2,3,4,5,5,5,5,5] +clipExtend :: Integral i => i -> [a] -> [a] +clipExtend n = genericTake n . cycleClip +-- | Infinite variant of 'clipExtend'. +cycleClip :: [a] -> [a] +cycleClip l = + case lastM l of + Nothing -> [] + Just e -> l ++ repeat e + +-- | Cycle input sequences to 'extension' of input. +-- +-- > extendSequences [[1],[2,3],[4,5,6]] == [[1,1,1],[2,3,2],[4,5,6]] +extendSequences :: [[a]] -> [[a]] +extendSequences l = + let f = zipWith (\_ x -> x) (extension l) . cycle + in map f l + -- | @ArrayedCollection.normalizeSum@ ensures sum of elements is one. -- +-- > > [1,2,3].normalizeSum == [1/6,1/3,0.5] -- > normalizeSum [1,2,3] == [1/6,2/6,3/6] normalizeSum :: (Fractional a) => [a] -> [a] normalizeSum l = @@ -502,30 +493,30 @@ -- | @List.slide@ is an identity window function with subsequences of -- length /w/ and stride of /n/. -- --- > [1,2,3,4,5,6].slide(3,1) +-- > > [1,2,3,4,5,6].slide(3,1) -- > slide 3 1 [1,2,3,4,5,6] == [1,2,3,2,3,4,3,4,5,4,5,6] -- --- > [1,2,3,4,5,6].slide(3,2) +-- > > [1,2,3,4,5,6].slide(3,2) -- > slide 3 2 [1,2,3,4,5,6] == [1,2,3,3,4,5] -- --- > [1,2,3,4,5,6].slide(4,2) +-- > > [1,2,3,4,5,6].slide(4,2) -- > slide 4 2 [1,2,3,4,5,6] == [1,2,3,4,3,4,5,6] -slide :: Int -> Int -> [a] -> [a] +slide :: Integral i => i -> i -> [a] -> [a] slide w n l = - let k = length l - in concatMap (\i -> take w (L.drop i l)) [0,n .. k-w] + let k = genericLength l + in concatMap (\i -> genericTake w (L.genericDrop i l)) [0,n .. k-w] -- | @List.mirror@ concatentates with 'tail' of 'reverse' to make a -- palindrome. -- --- > [1,2,3,4].mirror == [1,2,3,4,3,2,1] +-- > > [1,2,3,4].mirror == [1,2,3,4,3,2,1] -- > mirror [1,2,3,4] == [1,2,3,4,3,2,1] mirror :: [a] -> [a] mirror l = l ++ tail (reverse l) -- | @List.mirror1@ is as 'mirror' but with last element removed. -- --- > [1,2,3,4].mirror1 == [1,2,3,4,3,2] +-- > > [1,2,3,4].mirror1 == [1,2,3,4,3,2] -- > mirror1 [1,2,3,4] == [1,2,3,4,3,2] mirror1 :: [a] -> [a] mirror1 l = @@ -537,31 +528,50 @@ -- | @List.mirror2@ concatenate with 'reverse' to make a palindrome, -- as 'mirror' does, but with the center element duplicated. -- --- > [1,2,3,4].mirror2 == [1,2,3,4,4,3,2,1] +-- > > [1,2,3,4].mirror2 == [1,2,3,4,4,3,2,1] -- > mirror2 [1,2,3,4] == [1,2,3,4,4,3,2,1] mirror2 :: [a] -> [a] mirror2 l = l ++ reverse l -- | @List.stutter@ repeats each element /n/ times. -- --- > [1,2,3].stutter(2) == [1,1,2,2,3,3] +-- > > [1,2,3].stutter(2) == [1,1,2,2,3,3] -- > stutter 2 [1,2,3] == [1,1,2,2,3,3] -stutter :: Int -> [a] -> [a] -stutter n = concatMap (replicate n) +stutter :: Integral i => i -> [a] -> [a] +stutter n = concatMap (genericReplicate n) +-- | Rotate /n/ places to the left. +-- +-- > rotateLeft 1 [1..5] == [2,3,4,5,1] +-- > rotateLeft 3 [1..7] == [4,5,6,7,1,2,3] +rotateLeft :: Integral i => i -> [a] -> [a] +rotateLeft n p = + let (b,a) = genericSplitAt n p + in a ++ b + +-- | Rotate /n/ places to the right. +-- +-- > rotateRight 1 [1..5] == [5,1,2,3,4] +-- > rotateRight 3 [1..7] == [5,6,7,1,2,3,4] +rotateRight :: Integral i => i -> [a] -> [a] +rotateRight n p = + let k = genericLength p + (b,a) = genericSplitAt (k - n) p + in a ++ b + -- | @Array.rotate@ is in terms of 'rotateLeft' and 'rotateRight', -- where negative /n/ rotates left and positive /n/ rotates right. -- --- > (1..5).rotate(1) == [5,1,2,3,4] +-- > > (1..5).rotate(1) == [5,1,2,3,4] -- > rotate 1 [1..5] == [5,1,2,3,4] -- --- > (1..5).rotate(-1) == [2,3,4,5,1] +-- > > (1..5).rotate(-1) == [2,3,4,5,1] -- > rotate (-1) [1..5] == [2,3,4,5,1] -- --- > (1..5).rotate(3) == [3,4,5,1,2] +-- > > (1..5).rotate(3) == [3,4,5,1,2] -- > rotate 3 [1..5] == [3,4,5,1,2] -rotate :: Int -> [a] -> [a] -rotate n = if n < 0 then rotateLeft n else rotateRight n +rotate :: Integral i => i -> [a] -> [a] +rotate n = if n < 0 then rotateLeft (- n) else rotateRight n -- | @ArrayedCollection.windex@ takes a list of probabilities, which -- should sum to /n/, and returns the an index value given a (0,/n/) @@ -576,19 +586,18 @@ -- | List of 2-tuples of elements at distance (stride) /n/. -- -- > t2_window 3 [1..9] == [(1,2),(4,5),(7,8)] -t2_window :: Int -> [t] -> [(t,t)] +t2_window :: Integral i => i -> [t] -> [(t,t)] t2_window n x = case x of - i:j:_ -> (i,j) : t2_window n (L.drop n x) + i:j:_ -> (i,j) : t2_window n (L.genericDrop n x) _ -> [] - -- | List of 2-tuples of adjacent elements. -- -- > t2_adjacent [1..6] == [(1,2),(3,4),(5,6)] -- > t2_adjacent [1..5] == [(1,2),(3,4)] t2_adjacent :: [t] -> [(t,t)] -t2_adjacent = t2_window 2 +t2_adjacent = t2_window (2::Int) -- | List of 2-tuples of overlapping elements. -- @@ -620,7 +629,7 @@ -- element, or zero at the final element. Properly wavetables are -- only of power of two element signals. -- --- > Signal[0,0.5,1,0.5].asWavetable == Wavetable[-0.5,0.5,0,0.5,1.5,-0.5,1,-0.5] +-- > > Signal[0,0.5,1,0.5].asWavetable == Wavetable[-0.5,0.5,0,0.5,1.5,-0.5,1,-0.5] -- -- > to_wavetable [0,0.5,1,0.5] == [-0.5,0.5,0,0.5,1.5,-0.5,1,-0.5] to_wavetable :: Num a => [a] -> [a] diff --git a/Sound/SC3/Lang/Collection/Universal/Datum.hs b/Sound/SC3/Lang/Collection/Universal/Datum.hs --- a/Sound/SC3/Lang/Collection/Universal/Datum.hs +++ b/Sound/SC3/Lang/Collection/Universal/Datum.hs @@ -1,196 +1,325 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Functions to allow using the "Sound.OpenSoundControl" 'Datum' as -- a /universal/ data type. In addition to the functions defined --- below it provides instances for 'IsString', 'Num', 'Fractional', --- 'Floating', 'Real', 'RealFrac', 'Ord', 'Enum' and 'Random'. +-- below it provides instances for: +-- +-- 'Datum' are 'IsString' +-- +-- > :set -XOverloadedStrings +-- > "string" :: Datum +-- +-- 'Datum' are 'EqE' +-- +-- > Int32 5 /=* Int32 6 == Int32 1 +-- > Double 5 ==* Double 5 == Double 1 +-- +-- 'Datum' are 'Num' +-- +-- > 5 :: Datum +-- > 5 + 4 :: Datum +-- > negate 5 :: Datum +-- +-- 'Datum' are 'Fractional' +-- +-- > 5.0 :: Datum +-- > (5 / 4) :: Datum +-- +-- 'Datum' are 'Floating' +-- +-- > pi :: Datum +-- > sqrt (Int32 4) == Double 2 +-- > (2.0 ** 3.0) :: Datum +-- +-- 'Datum' are 'Real' +-- +-- > toRational (Double 1.5) == (3/2 :: Rational) +-- > (realToFrac (1.5 :: Double) :: Datum) == Double 1.5 +-- > (realToFrac (Double 1.5) :: Datum) == Double 1.5 +-- > (realToFrac (Double 1.5) :: Double) == 1.5 +-- +-- 'Datum' are 'RealFrac' +-- +-- > round (Double 1.4) == 1 +-- +-- 'Datum' are 'RealFracE' +-- +-- > roundE (Double 1.4) == Double 1 +-- > ceilingE (Double 1.4) == Double 2 +-- +-- 'Datum' are 'RealFloat' +-- +-- > isNaN (sqrt (negate (Int32 1))) == True +-- +-- 'Datum' are 'Ord' +-- +-- > Double 7.5 > Int32 7 +-- > string "because" > string "again" +-- +-- 'Datum' are 'OrdE' +-- +-- > Int32 7 >* Int32 7 == Int32 0 +-- > Double 7.5 >* Int32 7 == Double 1 +-- +-- 'Datum' are 'Enum' +-- +-- > [Int32 0 .. Int32 4] == [Int32 0,Int32 1,Int32 2,Int32 3,Int32 4] +-- > [Double 1 .. Double 3] == [Double 1,Double 2,Double 3] +-- +-- 'Datum' are 'Random' +-- +-- > System.Random.randomRIO (Int32 0,Int32 9):: IO Datum +-- > System.Random.randomRIO (Float 0,Float 1):: IO Datum module Sound.SC3.Lang.Collection.Universal.Datum where -import Data.Ratio -import GHC.Exts (IsString(..)) -import Sound.OpenSoundControl.Type -import System.Random +import qualified Data.ByteString.Char8 as C {- bytestring -} +import Data.Int {- base -} +import Data.Ratio {- base -} +import Data.String {- base -} +import Sound.OSC {- hosc -} +import Sound.SC3 {- hsc3 -} +import System.Random {- random -} -instance IsString Datum where - fromString = String +-- * Lifting --- | Lift an equivalent set of 'Int' and 'Double' unary functions to --- 'Datum'. --- --- > map (datum_lift negate negate) [Int 5,Float 5] == [Int (-5),Float (-5)] -datum_lift :: (Int -> Int) -> (Double -> Double) -> Datum -> Datum -datum_lift fi fd d = - case d of - Int n -> Int (fi n) - Float n -> Float (fd n) - Double n -> Double (fd n) - _ -> error "datum_lift" +-- | Unary operator. +type UOp n = (n -> n) --- | Promote 'Int' and 'Float' 'Datum' to 'Double' 'Datum'. +-- | Lift an equivalent set of 'Int32', 'Int64', 'Float' and 'Double' unary +-- functions to 'Datum'. -- --- > map datum_promote [Int 5,Float 5] == [Double 5,Double 5] -datum_promote :: Datum -> Datum -datum_promote d = +-- > map (liftD abs abs abs abs) [Int32 5,Float (-5)] == [Int32 5,Float 5] +liftD :: UOp Int32 -> UOp Int64 -> UOp Float -> UOp Double -> UOp Datum +liftD fi fh ff fd d = case d of - Int n -> Double (fromIntegral n) - Float n -> Double n - _ -> d + Int32 n -> Int32 (fi n) + Int64 n -> Int64 (fh n) + Float n -> Float (ff n) + Double n -> Double (fd n) + _ -> error "liftD: NaN" -- | Lift a 'Double' unary operator to 'Datum' via 'datum_promote'. -- --- > datum_lift' negate (Int 5) == Double (-5) -datum_lift' :: (Double -> Double) -> Datum -> Datum -datum_lift' f = datum_lift (error "datum_lift:non integral") f . - datum_promote - --- | An 'Int' binary operator. -type I_Binop = Int -> Int -> Int +-- > liftD' negate (Int 5) == Double (-5) +liftD' :: UOp Double -> UOp Datum +liftD' fd = + liftD (error "liftD'") (error "liftD'") (error "liftD'") fd . + datum_promote --- | A 'Double' binary operator. -type F_Binop = Double -> Double -> Double +-- | A binary operator. +type BinOp n = (n -> n -> n) --- | Given 'Int' and 'Double' binary operators generate 'Datum' --- operator. If 'Datum' are of equal type result type is equal, else --- result type is 'Double'. +-- | Given 'Int32', 'Int64', 'Float' and 'Double' binary operators +-- generate 'Datum' operator. If 'Datum' are of equal type result +-- type is equal, else result type is 'Double'. -- --- > datum_lift2 (+) (+) (Float 1) (Float 2) == Float 3 --- > datum_lift2 (*) (*) (Int 3) (Float 4) == Double 12 -datum_lift2 :: I_Binop -> F_Binop -> Datum -> Datum -> Datum -datum_lift2 fi fd d1 d2 = +-- > liftD2 (+) (+) (+) (+) (Float 1) (Float 2) == Float 3 +-- > liftD2 (*) (*) (*) (*) (Int32 3) (Float 4) == Double 12 +liftD2 :: BinOp Int32 -> BinOp Int64 -> + BinOp Float -> BinOp Double -> + BinOp Datum +liftD2 fi fh ff fd d1 d2 = case (d1,d2) of - (Int n1,Int n2) -> Int (fi n1 n2) - (Float n1,Float n2) -> Float (fd n1 n2) + (Int32 n1,Int32 n2) -> Int32 (fi n1 n2) + (Int64 n1,Int64 n2) -> Int64 (fh n1 n2) + (Float n1,Float n2) -> Float (ff n1 n2) (Double n1,Double n2) -> Double (fd n1 n2) - _ -> case (datum_real d1,datum_real d2) of + _ -> case (datum_floating d1,datum_floating d2) of (Just n1,Just n2) -> Double (fd n1 n2) - _ -> error "datum_lift2" + _ -> error "liftD2: NaN" --- | A 'datum_promote' variant of 'datum_lift2'. +-- | A 'datum_promote' variant of 'liftD2'. -- --- > datum_lift2' (+) (Float 1) (Float 2) == Double 3 -datum_lift2' :: F_Binop -> Datum -> Datum -> Datum -datum_lift2' f d1 = +-- > liftD2' (+) (Float 1) (Float 2) == Double 3 +liftD2' :: BinOp Double -> BinOp Datum +liftD2' f d1 = let d1' = datum_promote d1 - in datum_lift2 (error "datum_lift2:non integral") f d1' . + in liftD2 (error "liftD2'") (error "liftD2'") (error "liftD2'") f d1' . datum_promote +-- * At + +-- | Direct unary 'Int32', 'Int64', 'Float' and 'Double' functions at +-- 'Datum' fields, or 'error'. +-- +-- > atD show show show show (Int 5) == "5" +atD :: (Int32 -> a) -> (Int64 -> a) -> + (Float -> a) -> (Double -> a) -> + Datum -> a +atD fi fh ff fd d = + case d of + Int32 n -> fi n + Int64 n -> fh n + Float n -> ff n + Double n -> fd n + _ -> error "atD: NaN" + +-- | Lift a 'Double' /at/ operator to 'Datum' via 'datum_promote'. +-- +-- > atD' floatRadix (Int 5) == 2 +atD' :: (Double -> a) -> Datum -> a +atD' f = f . d_double . datum_promote + +-- | Binary /at/ function. +type BinAt n a = (n -> n -> a) + +-- | Direct binary 'Int', 'Float' and 'Double' functions at 'Datum' +-- fields, or 'error'. +atD2 :: BinAt Int32 a -> BinAt Int64 a -> + BinAt Float a -> BinAt Double a -> + BinAt Datum a +atD2 fi fh ff fd d1 d2 = + case (d1,d2) of + (Int32 n1,Int32 n2) -> fi n1 n2 + (Int64 n1,Int64 n2) -> fh n1 n2 + (Float n1,Float n2) -> ff n1 n2 + (Double n1,Double n2) -> fd n1 n2 + _ -> error "atD2: NaN" + +-- | Ternary /at/ function. +type TriAt n a = (n -> n -> n -> a) + +-- | Direct ternary 'Int', 'Float' and 'Double' functions at 'Datum' +-- fields, or 'error'. +atD3 :: TriAt Int32 a -> TriAt Int64 a -> + TriAt Float a -> TriAt Double a -> + TriAt Datum a +atD3 fi fh ff fd d1 d2 d3 = + case (d1,d2,d3) of + (Int32 n1,Int32 n2,Int32 n3) -> fi n1 n2 n3 + (Int64 n1,Int64 n2,Int64 n3) -> fh n1 n2 n3 + (Float n1,Float n2,Float n3) -> ff n1 n2 n3 + (Double n1,Double n2,Double n3) -> fd n1 n2 n3 + _ -> error "atD3: NaN" + +instance IsString Datum where + fromString = ASCII_String . C.pack + +instance EqE Datum where + (==*) = liftD2 (==*) (==*) (==*) (==*) + (/=*) = liftD2 (/=*) (/=*) (/=*) (/=*) + instance Num Datum where - negate = datum_lift negate negate - (+) = datum_lift2 (+) (+) - (-) = datum_lift2 (-) (-) - (*) = datum_lift2 (*) (*) - abs = datum_lift abs abs - signum = datum_lift signum signum - fromInteger n = Int (fromInteger n) + negate = liftD negate negate negate negate + (+) = liftD2 (+) (+) (+) (+) + (-) = liftD2 (-) (-) (-) (-) + (*) = liftD2 (*) (*) (*) (*) + abs = liftD abs abs abs abs + signum = liftD signum signum signum signum + fromInteger n = Int64 (fromInteger n) instance Fractional Datum where - recip = datum_lift' recip - (/) = datum_lift2' (/) + recip = liftD' recip + (/) = liftD2' (/) fromRational n = Double (fromRational n) instance Floating Datum where pi = Double pi - exp = datum_lift' exp - log = datum_lift' log - sqrt = datum_lift' sqrt - (**) = datum_lift2' (**) - logBase = datum_lift2' logBase - sin = datum_lift' sin - cos = datum_lift' cos - tan = datum_lift' tan - asin = datum_lift' asin - acos = datum_lift' acos - atan = datum_lift' atan - sinh = datum_lift' sinh - cosh = datum_lift' cosh - tanh = datum_lift' tanh - asinh = datum_lift' asinh - acosh = datum_lift' acosh - atanh = datum_lift' atanh + exp = liftD' exp + log = liftD' log + sqrt = liftD' sqrt + (**) = liftD2' (**) + logBase = liftD2' logBase + sin = liftD' sin + cos = liftD' cos + tan = liftD' tan + asin = liftD' asin + acos = liftD' acos + atan = liftD' atan + sinh = liftD' sinh + cosh = liftD' cosh + tanh = liftD' tanh + asinh = liftD' asinh + acosh = liftD' acosh + atanh = liftD' atanh instance Real Datum where toRational d = case d of - Int n -> fromIntegral n % 1 + Int32 n -> fromIntegral n % 1 + Int64 n -> fromIntegral n % 1 Float n -> toRational n Double n -> toRational n - _ -> error "datum,real,partial" + _ -> error "Datum.toRational: NaN" instance RealFrac Datum where properFraction d = - let (i,j) = properFraction (datum_real_err d) + let (i,j) = properFraction (d_double d) in (i,Double j) - truncate = truncate . datum_real_err - round = round . datum_real_err - ceiling = ceiling . datum_real_err - floor = floor . datum_real_err + truncate = atD' truncate + round = atD' round + ceiling = atD' ceiling + floor = atD' floor -instance Ord Datum where - p < q = case (datum_real p,datum_real q) of - (Just i,Just j) -> i < j - _ -> error "datum,ord,partial" +instance RealFracE Datum where + truncateE = liftD undefined undefined truncateE truncateE + roundE = liftD undefined undefined roundE roundE + ceilingE = liftD undefined undefined ceilingE ceilingE + floorE = liftD undefined undefined floorE floorE --- | Direct unary 'Int' and 'Double' functions at 'Datum' fields, or --- 'error'. --- --- > at_d1 show show (Int 5) == "5" -at_d1 :: (Int -> a) -> (Double -> a) -> Datum -> a -at_d1 fi fr d = - case d of - Int n -> fi n - Float n -> fr n - Double n -> fr n - _ -> error "at_d1,partial" +instance RealFloat Datum where + floatRadix = atD' floatRadix + floatDigits = atD' floatDigits + floatRange = atD' floatRange + decodeFloat = atD' decodeFloat + encodeFloat i = Double . encodeFloat i + exponent = atD' exponent + significand = liftD' significand + scaleFloat i = liftD' (scaleFloat i) + isNaN = atD' isNaN + isInfinite = atD' isInfinite + isDenormalized = atD' isDenormalized + isNegativeZero = atD' isNegativeZero + isIEEE = atD' isIEEE + atan2 = liftD2' atan2 --- | Direct binary 'Int' and 'Double' functions at 'Datum' fields, or --- 'error'. -at_d2 :: (Int -> Int -> a) -> - (Double -> Double -> a) -> - Datum -> Datum -> a -at_d2 fi fr d1 d2 = - case (d1,d2) of - (Int n1,Int n2) -> fi n1 n2 - (Float n1,Float n2) -> fr n1 n2 - (Double n1,Double n2) -> fr n1 n2 - _ -> error "at_d2,partial" +instance Ord Datum where + compare p q = + case (datum_promote p,datum_promote q) of + (Double i, Double j) -> compare i j + (ASCII_String i,ASCII_String j) -> compare i j + (TimeStamp i,TimeStamp j) -> compare i j + _ -> error "Datum.compare" --- | Direct ternary 'Int' and 'Double' functions at 'Datum' fields, or --- 'error'. -at_d3 :: (Int -> Int -> Int -> a) -> - (Double -> Double -> Double -> a) -> - Datum -> Datum -> Datum -> a -at_d3 fi fr d1 d2 d3 = - case (d1,d2,d3) of - (Int n1,Int n2,Int n3) -> fi n1 n2 n3 - (Float n1,Float n2,Float n3) -> fr n1 n2 n3 - (Double n1,Double n2,Double n3) -> fr n1 n2 n3 - _ -> error "at_d3,partial" +instance OrdE Datum where + (>*) = liftD2 (>*) (>*) (>*) (>*) + (>=*) = liftD2 (>=*) (>=*) (>=*) (>=*) + (<*) = liftD2 (<*) (<*) (<*) (<*) + (<=*) = liftD2 (<=*) (<=*) (<=*) (<=*) instance Enum Datum where - fromEnum = at_d1 fromEnum fromEnum - enumFrom = at_d1 (map Int . enumFrom) (map Double . enumFrom) - enumFromThen = at_d2 (\a -> map Int . enumFromThen a) - (\a -> map Double . enumFromThen a) - enumFromTo = at_d2 (\a -> map Int . enumFromTo a) - (\a -> map Double . enumFromTo a) - enumFromThenTo = at_d3 (\a b -> map Int . enumFromThenTo a b) - (\a b -> map Double . enumFromThenTo a b) - toEnum = Int + fromEnum = atD fromEnum fromEnum fromEnum fromEnum + enumFrom = + atD + (map Int32 . enumFrom) + (map Int64 . enumFrom) + (map Float . enumFrom) + (map Double . enumFrom) + enumFromThen = + atD2 + (\a -> map Int32 . enumFromThen a) + (\a -> map Int64 . enumFromThen a) + (\a -> map Float . enumFromThen a) + (\a -> map Double . enumFromThen a) + enumFromTo = + atD2 + (\a -> map Int32 . enumFromTo a) + (\a -> map Int64 . enumFromTo a) + (\a -> map Float . enumFromTo a) + (\a -> map Double . enumFromTo a) + enumFromThenTo = + atD3 + (\a b -> map Int32 . enumFromThenTo a b) + (\a b -> map Int64 . enumFromThenTo a b) + (\a b -> map Float . enumFromThenTo a b) + (\a b -> map Double . enumFromThenTo a b) + toEnum = Int64 . fromIntegral instance Random Datum where randomR i g = case i of - (Int l,Int r) -> let (n,g') = randomR (l,r) g in (Int n,g') + (Int32 l,Int32 r) -> let (n,g') = randomR (l,r) g in (Int32 n,g') + (Int64 l,Int64 r) -> let (n,g') = randomR (l,r) g in (Int64 n,g') (Float l,Float r) -> let (n,g') = randomR (l,r) g in (Float n,g') (Double l,Double r) -> let (n,g') = randomR (l,r) g in (Double n,g') - _ -> error "randomR,datum,partial" + _ -> error "Datum.randomR: NaN" random g = let (n,g') = randomR (0::Double,1::Double) g in (Double n,g') - -{- -5 :: Datum -(5 + 4) :: Datum -(2.0 ** 3.0) :: Datum -(negate 5) :: Datum -(negate 5.0) :: Datum -:set -XOverloadedStrings -"string" :: Datum --} diff --git a/Sound/SC3/Lang/Control/Duration.hs b/Sound/SC3/Lang/Control/Duration.hs --- a/Sound/SC3/Lang/Control/Duration.hs +++ b/Sound/SC3/Lang/Control/Duration.hs @@ -1,66 +1,81 @@ -- | The @SC3@ duration model. module Sound.SC3.Lang.Control.Duration where --- | The @SC3@ 'Duration' model. -data Duration a = - Duration {tempo :: a -- ^ Tempo (in pulses per minute) - ,dur :: a -- ^ Duration (in pulses) - ,stretch :: a -- ^ Stretch multiplier - ,legato :: a -- ^ Legato multipler - ,sustain_f :: Duration a -> a -- ^ Sustain time calculation - ,delta_f :: Duration a -> a -- ^ Delta time calculation - ,lag :: a -- ^ Lag value - ,fwd' :: Maybe a -- ^ Possible non-sequential delta time field - } +import Data.Maybe {- base -} --- | Run 'delta_f' for 'Duration'. This is the interval from the --- start of the current event to the start of the next event. --- --- > delta (defaultDuration {dur = 2,stretch = 2}) == 4 -delta :: Duration a -> a -delta d = delta_f d d +-- * Durational --- | Run 'sustain_f' for 'Duration'. This is the /sounding/ duration --- of the event. +-- | Values that have duration. -- --- > sustain defaultDuration == 0.8 -sustain :: Duration a -> a -sustain d = sustain_f d d - --- | If 'fwd'' field is set at 'Duration' extract value and multiply --- by 'stretch', else calculate 'delta'. +-- @occ@ is the interval from the start through to the end of the +-- current event, ie. the time span the event /occupies/. -- --- > fwd (defaultDuration {fwd' = Just 0}) == 0 -fwd :: Num a => Duration a -> a -fwd d = - case fwd' d of - Nothing -> delta d - Just n -> n * stretch d - --- | The default 'delta_f' field for 'Duration'. Equal to 'dur' '*' --- 'stretch' '*' (@60@ '/' 'tempo'). +-- @delta@ is the interval from the start of the current event to the +-- start of the next /sequential/ event. -- --- > default_delta_f (defaultDuration {legato = 1.2}) == 1.0 -default_delta_f :: (Num a,Fractional a) => Duration a -> a -default_delta_f d = dur d * stretch d * (60 / tempo d) +-- @fwd@ is the interval from the start of the current event to the +-- start of the next /parallel/ event. +class Durational d where + occ :: d -> Double + delta :: d -> Double + delta = occ + fwd :: d -> Double + fwd = occ --- | The default 'sustain_f' field for 'Duration'. This is equal to --- 'delta' '*' 'legato'. +-- * Dur + +-- | Variant of the @SC3@ 'Duration' model. -- --- > default_sustain_f (defaultDuration {legato = 1.2}) == 1.2 -default_sustain_f :: (Num a,Fractional a) => Duration a -> a -default_sustain_f d = delta d * legato d +-- > delta (defaultDur {dur = 2,stretch = 2}) == 4 +-- > occ defaultDur == 0.8 +-- > let d = defaultDur {fwd' = Just 0} in (delta d,fwd d) == (1,0) +data Dur = + Dur {tempo :: Double -- ^ Tempo (in pulses per minute) + ,dur :: Double -- ^ Duration (in pulses) + ,stretch :: Double -- ^ Stretch multiplier + ,legato :: Double -- ^ Legato multipler + ,sustain' :: Maybe Double -- ^ Sustain time + ,delta' :: Maybe Double -- ^ Delta time + ,lag :: Double -- ^ Lag value + ,fwd' :: Maybe Double -- ^ Possible non-sequential delta time field + } + deriving (Eq,Show) --- | Default 'Duration' value, equal to one second. +instance Durational Dur where + occ d = fromMaybe (delta d * legato d) (sustain' d) + delta d = fromMaybe (dur d * stretch d * (60 / tempo d)) (delta' d) + fwd d = maybe (delta d) (* stretch d) (fwd' d) + +-- | Default 'Dur' value, equal to one second. -- --- > delta defaultDuration == 1 -defaultDuration :: (Num a,Fractional a) => Duration a -defaultDuration = - Duration {tempo = 60 - ,dur = 1 - ,stretch = 1 - ,legato = 0.8 - ,sustain_f = default_sustain_f - ,delta_f = default_delta_f - ,lag = 0.1 - ,fwd' = Nothing} +-- > delta defaultDur == 1 +defaultDur :: Dur +defaultDur = + Dur {tempo = 60 + ,dur = 1 + ,stretch = 1 + ,legato = 0.8 + ,sustain' = Nothing + ,delta' = Nothing + ,lag = 0.1 + ,fwd' = Nothing} + +-- * OptDur + +-- | Eight tuple. +type T8 n = (n,n,n,n,n,n,n,n) + +-- | 'Dur' represented as an eight-tuple of optional values. +type OptDur = T8 (Maybe Double) + +-- | Translate 'OptDur' to 'Dur'. +optDur :: OptDur -> Dur +optDur (t,d,s,l,s',d',l',f) = + Dur {tempo = fromMaybe 60 t + ,dur = fromMaybe 1 d + ,stretch = fromMaybe 1 s + ,legato = fromMaybe 0.8 l + ,sustain' = s' + ,delta' = d' + ,lag = fromMaybe 0.1 l' + ,fwd' = f} diff --git a/Sound/SC3/Lang/Control/Event.hs b/Sound/SC3/Lang/Control/Event.hs --- a/Sound/SC3/Lang/Control/Event.hs +++ b/Sound/SC3/Lang/Control/Event.hs @@ -1,301 +1,763 @@ --- | An 'Event' is a ('Key','Value') map. +-- | An 'Event' is a ('Key','Field') map. module Sound.SC3.Lang.Control.Event where -import qualified Data.Map as M -import Data.Maybe -import qualified Sound.OpenSoundControl as O -import qualified Sound.SC3.Server as S +import Data.List {- base -} +import qualified Data.Map as Map {- containers -} +import Data.Maybe {- base -} +import Data.Monoid {- base -} +import Data.String {- base -} +import Sound.OSC {- hosc -} +import Sound.SC3 {- hsc3 -} +import System.Random {- base -} + +import qualified Sound.SC3.Lang.Collection as C import qualified Sound.SC3.Lang.Control.Duration as D import qualified Sound.SC3.Lang.Control.Instrument as I import qualified Sound.SC3.Lang.Control.Pitch as P +import qualified Sound.SC3.Lang.Math as M --- | The type of the /key/ at an 'Event'. -type Key = String +-- * Field --- | The type of the /value/ at an 'Event'. -type Value = Double +-- | Event field. +-- +-- 'Field's are 'Num'. +-- +-- > 5 :: Field +-- > 4 + 5 :: Field +-- > negate 5 :: Field +-- > f_array [2,3] + f_array [4,5] == f_array [6,8] +-- > f_array [1,2,3] + f_array [4,5] == f_array [5,7,7] +-- > 4 + f_array [5,6] == f_array [9,10] +data Field = F_Double {f_double :: Double} + | F_Vector {f_vector :: [Field]} + | F_String {f_string :: String} + | F_Instr {f_instr :: I.Instr} + deriving (Eq,Show) --- | The /type/ of an 'Event'. -data Type = E_s_new | E_n_set | E_rest deriving (Eq,Show) +-- | Set of types that can be lifted to 'Field'. +class F_Value a where toF :: a -> Field +instance F_Value Bool where toF = F_Double . fromIntegral . fromEnum +instance F_Value Int where toF = F_Double . fromIntegral +instance F_Value Double where toF = F_Double +instance F_Value I.Instr where toF = F_Instr +instance F_Value Field where toF = id --- | An 'Event' has a 'Type', possibly an integer identifier, possibly --- an 'I.Instrument' and a map of ('Key','Value') pairs. -data Event = Event {e_type :: Type - ,e_id :: Maybe Int - ,e_instrument :: Maybe I.Instrument - ,e_map :: M.Map Key Value} - deriving (Eq,Show) +-- | Numeric 'F_Value' types. +class F_Value a => F_Num a where +instance F_Num Int +instance F_Num Double +instance F_Num Field --- | The /default/ empty event. -defaultEvent :: Event -defaultEvent = - Event {e_type = E_s_new - ,e_id = Nothing - ,e_instrument = Nothing - ,e_map = M.empty} +-- | Maybe variant of 'f_double'. +f_double_m :: Field -> Maybe Double +f_double_m f = case f of {F_Double n -> Just n;_ -> Nothing;} --- | Lookup /k/ in /e/. +-- | Variant of /reader/ with specified error message. +f_reader_err :: String -> String -> (Field -> Maybe a) -> Field -> a +f_reader_err nm err f x = + let s = nm ++ ": " ++ err ++ " (" ++ show x ++ ")" + in fromMaybe (error s) (f x) + +-- | Variant of 'f_double' with specified error message. +f_double_err :: String -> Field -> Double +f_double_err err = f_reader_err "f_double" err f_double_m + +-- | Run '>' @0@ at 'f_double'. +f_bool_err :: String -> Field -> Bool +f_bool_err err = (> 0) . f_reader_err "f_bool" err f_double_m + +-- | Run 'round' at 'f_double'. +f_int_err :: String -> Field -> Int +f_int_err err = round . f_reader_err "f_int" err f_double_m + +-- | Single element 'F_Vector' constructor. -- --- > lookup_m "k" defaultEvent == Nothing -lookup_m :: Key -> Event -> Maybe Value -lookup_m k e = M.lookup k (e_map e) +-- > f_ref 1 == f_array [1] +f_ref :: Field -> Field +f_ref = F_Vector . return --- | Variant of 'lookup_m' with a default value /v/. +-- | Uniform vector constructor. -- --- > lookup_v 1 "k" defaultEvent == 1 -lookup_v :: Value -> Key -> Event -> Value -lookup_v v k e = fromMaybe v (lookup_m k e) +-- > f_array [1,2] == F_Vector [F_Double 1,F_Double 2] +f_array :: [Double] -> Field +f_array = F_Vector . map F_Double --- | Variant of 'lookup_v' with a transformation function. +-- | Maybe variant of 'f_vector'. +f_vector_m :: Field -> Maybe [Field] +f_vector_m f = case f of {F_Vector v -> Just v;_ -> Nothing;} + +-- | 'length' of 'f_vector_m'. -- --- > lookup_t 1 negate "k" defaultEvent == 1 --- > lookup_t 1 negate "k" (insert "k" 1 defaultEvent) == -1 -lookup_t :: t -> (Value -> t) -> Key -> Event -> t -lookup_t v f k e = - case lookup_m k e of - Nothing -> v - Just v' -> f v' +-- > f_vector_length (f_array [1..5]) == Just 5 +f_vector_length :: Field -> Maybe Int +f_vector_length = fmap length . f_vector_m --- | Lookup 'Pitch' model parameters at /e/ and construct a 'Pitch' --- value. -pitch :: Event -> P.Pitch Double -pitch e = - let get_r v k = lookup_v v k e - get_m v k = lookup_t v const k e - in P.Pitch {P.mtranspose = get_r 0 "mtranspose" - ,P.gtranspose = get_r 0 "gtranspose" - ,P.ctranspose = get_r 0 "ctranspose" - ,P.octave = get_r 5 "octave" - ,P.root = get_r 0 "root" - ,P.degree = get_r 0 "degree" - ,P.scale = [0, 2, 4, 5, 7, 9, 11] - ,P.stepsPerOctave = get_r 12 "stepsPerOctave" - ,P.detune = get_r 0 "detune" - ,P.harmonic = get_r 1 "harmonic" - ,P.freq_f = get_m P.default_freq_f "freq" - ,P.midinote_f = get_m P.default_midinote_f "midinote" - ,P.note_f = get_m P.default_note_f "note"} +-- | Indexed variant of 'f_double_err'. +-- +-- > f_double_err_ix "" Nothing 1 == 1 +-- > f_double_err_ix "" (Just 1) (f_array [0,1]) == 1 +f_double_err_ix :: String -> Maybe Int -> Field -> Double +f_double_err_ix err n = + case n of + Nothing -> f_double_err err + Just i -> f_double_err err . (!! i) . f_vector --- | Lookup 'D.Duration' model parameters at an 'Event' and construct a --- 'D.Duration' value. -duration :: Event -> D.Duration Double -duration e = - let get_r v k = lookup_v v k e - get_m v k = lookup_t v const k e - get_o k = lookup_m k e - in D.Duration {D.tempo = get_r 60 "tempo" - ,D.dur = get_r 1 "dur" - ,D.stretch = get_r 1 "stretch" - ,D.legato = get_r 0.8 "legato" - ,D.sustain_f = get_m D.default_sustain_f "sustain" - ,D.delta_f = get_m D.default_delta_f "delta" - ,D.lag = get_r 0.1 "lag" - ,D.fwd' = get_o "fwd'"} +-- | Maybe variant of 'f_instr'. +f_instr_m :: Field -> Maybe I.Instr +f_instr_m f = case f of {F_Instr n -> Just n;_ -> Nothing;} --- | Insert (/k/,/v/) into /e/. +-- | Variant of 'f_instr' with specified error message. +f_instr_err :: String -> Field -> I.Instr +f_instr_err err = fromMaybe (error ("f_instr: " ++ err)) . f_instr_m + +-- | Map /fn/ over vector elements at /f/. -- --- > lookup_m "k" (insert "k" 1 defaultEvent) == Just 1 -insert :: Key -> Value -> Event -> Event -insert k v e = e {e_map = M.insert k v (e_map e)} +-- > f_map negate (f_array [0,1]) == f_array [0,-1] +f_map :: (Field -> Field) -> Field -> Field +f_map fn f = + case f of + F_Vector l -> F_Vector (map fn l) + _ -> error ("f_map: " ++ show f) --- | Lookup /db/ field of 'Event', the default value is @-20db@. -db :: Event -> Value -db = lookup_v (-20) "db" +-- | Numerical unary operator. +-- +-- > f_uop negate (F_Double 1) == F_Double (-1) +-- > f_uop negate (F_Vector [F_Double 0,F_Double 1]) == f_array [0,-1] +f_uop :: (Double -> Double) -> Field -> Field +f_uop f p = + case p of + F_Double n -> F_Double (f n) + F_Vector v -> F_Vector (map (f_uop f) v) + _ -> error ("f_uop: " ++ show p) --- | Function to convert from decibels to linear amplitude. -dbAmp' :: Floating a => a -> a -dbAmp' a = 10 ** (a * 0.05) +-- | Numerical binary operator. +-- +-- > f_binop (+) (F_Double 1) (F_Double 2) == F_Double 3 +-- > f_binop (*) (f_array [1,2,3]) (f_array [3,4,5]) == f_array [3,8,15] +-- > f_binop (/) (F_Double 9) (F_Double 3) == F_Double 3 +f_binop :: (Double -> Double -> Double) -> Field -> Field -> Field +f_binop f p q = + case (p,q) of + (F_Double m,F_Double n) -> F_Double (f m n) + (F_Vector v,F_Vector w) -> F_Vector (C.zipWith_c (f_binop f) v w) + (F_Double _,F_Vector w) -> F_Vector (C.zipWith_c (f_binop f) [p] w) + (F_Vector v,F_Double _) -> F_Vector (C.zipWith_c (f_binop f) v [q]) + _ -> error ("f_binop: " ++ show (p,q)) --- | The linear amplitude of the amplitude model at /e/. +-- | At floating branch of 'Field'. +f_atf :: (Double -> a) -> Field -> a +f_atf f = f . f_double + +-- | At floating branches of 'Field's. +f_atf2 :: (Double -> Double -> a) -> Field -> Field -> a +f_atf2 f p q = + case (p,q) of + (F_Double n1,F_Double n2) -> f n1 n2 + _ -> error ("f_atf2: " ++ show (p,q)) + +-- | At floating branches of 'Field's. +f_atf3 :: (Double -> Double -> Double -> a) -> Field -> Field -> Field -> a +f_atf3 f p q r = + case (p,q,r) of + (F_Double n1,F_Double n2,F_Double n3) -> f n1 n2 n3 + _ -> error ("f_atf3: " ++ show (p,q,r)) + +-- | Extend to 'Field' to /n/. -- --- > amp (event [("db",-20)]) == 0.1 -amp :: Event -> Value -amp e = lookup_v (dbAmp' (db e)) "amp" e +-- > f_mce_extend 3 (f_array [1,2]) == f_array [1,2,1] +-- > f_mce_extend 3 1 == f_array [1,1,1] +f_mce_extend :: Int -> Field -> Field +f_mce_extend n f = + case f of + F_Vector v -> F_Vector (take n (cycle v)) + _ -> F_Vector (replicate n f) --- | The /fwd/ value of the duration model at /e/. +instance IsString Field where + fromString = F_String + +instance Num Field where + (+) = f_binop (+) + (*) = f_binop (*) + negate = f_uop negate + abs = f_uop abs + signum = f_uop signum + fromInteger = F_Double . fromInteger + +instance Fractional Field where + recip = f_uop recip + (/) = f_binop (/) + fromRational n = F_Double (fromRational n) + +instance Floating Field where + pi = F_Double pi + exp = f_uop exp + log = f_uop log + sqrt = f_uop sqrt + (**) = f_binop (**) + logBase = f_binop logBase + sin = f_uop sin + cos = f_uop cos + tan = f_uop tan + asin = f_uop asin + acos = f_uop acos + atan = f_uop atan + sinh = f_uop sinh + cosh = f_uop cosh + tanh = f_uop tanh + asinh = f_uop asinh + acosh = f_uop acosh + atanh = f_uop atanh + +instance Real Field where + toRational d = + case d of + F_Double n -> toRational n + _ -> error ("Field.toRational: " ++ show d) + +instance RealFrac Field where + properFraction d = + let (i,j) = properFraction (f_double d) + in (i,F_Double j) + truncate = f_atf truncate + round = f_atf round + ceiling = f_atf ceiling + floor = f_atf floor + +instance RealFloat Field where + floatRadix = f_atf floatRadix + floatDigits = f_atf floatDigits + floatRange = f_atf floatRange + decodeFloat = f_atf decodeFloat + encodeFloat i = F_Double . encodeFloat i + exponent = f_atf exponent + significand = f_uop significand + scaleFloat i = f_uop (scaleFloat i) + isNaN = f_atf isNaN + isInfinite = f_atf isInfinite + isDenormalized = f_atf isDenormalized + isNegativeZero = f_atf isNegativeZero + isIEEE = f_atf isIEEE + atan2 = f_binop atan2 + +instance Ord Field where + compare p q = + case (p,q) of + (F_Double m,F_Double n) -> compare m n + _ -> error ("Field.compare: " ++ show (p,q)) + +instance Enum Field where + fromEnum = f_atf fromEnum + enumFrom = f_atf (map F_Double . enumFrom) + enumFromThen = f_atf2 (\a -> map F_Double . enumFromThen a) + enumFromTo = f_atf2 (\a -> map F_Double . enumFromTo a) + enumFromThenTo = f_atf3 (\a b -> map F_Double . enumFromThenTo a b) + toEnum = F_Double . fromIntegral + +instance Random Field where + randomR i g = + case i of + (F_Double l,F_Double r) -> + let (n,g') = randomR (l,r) g + in (F_Double n,g') + _ -> error ("Field.randomR: " ++ show i) + random g = let (n,g') = randomR (0::Double,1::Double) g + in (F_Double n,g') + +instance EqE Field +instance OrdE Field +instance RealFracE Field +instance UnaryOp Field +instance BinaryOp Field + +-- * Key + +-- | The type of the /key/ at an 'Event'. -- --- > fwd (event [("dur",1),("stretch",2)]) == 2 -fwd :: Event -> Double -fwd = D.fwd . duration +-- > :set -XOverloadedStrings +-- > [K_dur,"pan"] == [K_dur,K_param "pan"] +data Key = K_degree | K_mtranspose | K_scale | K_stepsPerOctave + | K_gtranspose | K_note | K_octave | K_root + | K_ctranspose | K_harmonic | K_midinote + | K_detune | K_freq + | K_delta | K_dur | K_lag | K_legato | K_fwd' | K_stretch | K_sustain | K_tempo + | K_db | K_amp + | K_rest + | K_instr | K_id | K_type | K_latency + | K_param String + deriving (Eq,Ord,Show) --- | The /latency/ to compensate for when sending messages based on --- the event. Defaults to @0.1@. -latency :: Event -> Double -latency = lookup_v 0.1 "latency" +instance IsString Key where + fromString = K_param --- | List of 'Key's used in pitch, duration and amplitude models. +-- | SC3 name of 'Key'. -- --- > ("degree" `elem` model_keys) == True -model_keys :: [Key] -model_keys = - ["amp","db" - ,"delta","dur","legato","fwd'","stretch","sustain","tempo" - ,"ctranspose","degree","freq","midinote","mtranspose","note","octave" - ,"rest"] +-- > map k_name [K_freq,K_dur,K_param "pan"] == ["freq","dur","pan"] +k_name :: Key -> String +k_name k = + case k of + K_param nm -> nm + _ -> drop 2 (show k) -- | List of reserved 'Key's used in pitch, duration and amplitude -- models. These are keys that may be provided explicitly, but if not -- will be calculated implicitly. -- --- > ("freq" `elem` reserved) == True -reserved :: [Key] -reserved = ["freq","midinote","note" - ,"delta","sustain" - ,"amp"] +-- > (K_freq `elem` k_reserved) == True +k_reserved :: [Key] +k_reserved = [K_freq,K_midinote,K_note + ,K_delta,K_sustain + ,K_amp + ,K_instr,K_id,K_type,K_latency,K_rest] --- | If 'Key' is 'reserved' then 'Nothing', else 'id'. -parameters' :: (Key,Value) -> Maybe (Key,Value) -parameters' (k,v) = - if k `elem` reserved - then Nothing - else Just (k,v) +k_vector :: [Key] +k_vector = [K_scale] --- | Extract non-'reserved' 'Keys' from 'Event'. -parameters :: Event -> [(Key,Value)] -parameters = mapMaybe parameters' . M.toList . e_map +-- | Is 'Key' /not/ 'k_reserved', and /not/ 'k_vector'. +-- +-- > k_is_parameter (K_param "pan",0) == True +k_is_parameter :: (Key,a) -> Bool +k_is_parameter (k,_) = k `notElem` (k_reserved ++ k_vector) --- | 'Value' editor for 'Key' at 'Event', with default value in case --- 'Key' is not present. -edit_v :: Key -> Value -> (Value -> Value) -> Event -> Event -edit_v k v f e = - case lookup_m k e of - Just n -> insert k (f n) e - Nothing -> insert k (f v) e +-- * Event --- | Variant of 'edit_v' with no default value. -edit :: Key -> (Value -> Value) -> Event -> Event -edit k f e = - case lookup_m k e of - Just n -> insert k (f n) e - Nothing -> e +-- | An 'Event' is a ('Key','Field') map. +type Event = Map.Map Key Field --- | Basic 'Event' constructor function with 'e_map' given as a list. -from_list :: Type -> Maybe Int -> Maybe I.Instrument -> [(Key,Value)] -> Event -from_list t n i l = - Event {e_type = t - ,e_id = n - ,e_instrument = i - ,e_map = M.fromList l} +-- | Insert (/k/,/v/) into /e/. +-- +-- > e_get K_id (e_insert K_id 1 mempty) == Just 1 +e_insert :: Key -> Field -> Event -> Event +e_insert k v = Map.insert k v --- | Construct an 'Event' from a list of (/key/,/value/) pairs. +-- | Event from association list. -- --- > lookup_m "k" (event [("k",1)]) == Just 1 -event :: [(Key,Value)] -> Event -event l = - Event {e_type = E_s_new - ,e_id = Nothing - ,e_instrument = Nothing - ,e_map = M.fromList l} +-- > e_get K_id (e_from_list [(K_id,1)]) == Just 1 +e_from_list :: [(Key,Field)] -> Event +e_from_list = Map.fromList --- | Extract 'I.Instrument' name from 'Event', or @default@. -instrument_name :: Event -> String -instrument_name e = - case e_instrument e of - Nothing -> "default" - Just (I.InstrumentDef s _) -> S.synthdefName s - Just (I.InstrumentName s _) -> s +-- | Event from association list. +-- +-- > let a = [(K_id,1)] in e_to_list (e_from_list a) == a +e_to_list :: Event -> [(Key,Field)] +e_to_list = Map.toList --- | Extract 'I.Instrument' definition from 'Event' if present. -instrument_def :: Event -> Maybe S.Synthdef -instrument_def e = - case e_instrument e of - Nothing -> Nothing - Just (I.InstrumentDef s _) -> Just s - Just (I.InstrumentName _ _) -> Nothing +-- | Lookup /k/ in /e/. +-- +-- > e_get K_id mempty == Nothing +e_get :: Key -> Event -> Maybe Field +e_get k = Map.lookup k --- | 'I.send_release' of 'I.Instrument' at 'Event'. -instrument_send_release :: Event -> Bool -instrument_send_release e = - case e_instrument e of - Nothing -> True - Just i -> I.send_release i +-- | Immediate or vector element lookup. +-- +-- > e_get_ix Nothing K_id (e_from_list [(K_id,1)]) == Just 1 +-- +-- > let n = f_array [0,1,2] +-- > in e_get_ix Nothing K_id (e_from_list [(K_id,n)]) == Just n +-- +-- > let n = f_array [0..9] +-- > in e_get_ix (Just 5) K_id (e_from_list [(K_id,n)]) == Just 5 +e_get_ix :: Maybe Int -> Key -> Event -> Maybe Field +e_get_ix n k = + case n of + Nothing -> e_get k + Just i -> fmap ((!! i) . f_vector) . e_get k --- | Merge two sorted sequence of (/location/,/value/) pairs. +-- | Type specialised 'e_get'. +e_get_double :: Key -> Event -> Maybe Double +e_get_double k = fmap (f_double_err (k_name k)) . e_get k + +-- | Type specialised 'e_get_ix'. +e_get_double_ix :: Maybe Int -> Key -> Event -> Maybe Double +e_get_double_ix n k = fmap (f_double_err (k_name k)) . e_get_ix n k + +-- | Type specialised 'e_get'. +e_get_bool :: Key -> Event -> Maybe Bool +e_get_bool k = fmap (f_bool_err (k_name k)) . e_get k + +-- | Type specialised 'e_get'. +e_get_int :: Key -> Event -> Maybe Int +e_get_int k = fmap (f_int_err (k_name k)) . e_get k + +-- | Type specialised 'e_get_ix'. +e_get_int_ix :: Maybe Int -> Key -> Event -> Maybe Int +e_get_int_ix n k = fmap (f_int_err (k_name k)) . e_get_ix n k + +-- | Type specialised 'e_get'. +e_get_instr :: Key -> Event -> Maybe I.Instr +e_get_instr k = fmap (f_instr_err (k_name k)) . e_get k + +-- | Type specialised 'e_get_ix'. +e_get_instr_ix :: Maybe Int -> Key -> Event -> Maybe I.Instr +e_get_instr_ix n k = fmap (f_instr_err (k_name k)) . e_get_ix n k + +-- | Type specialised 'e_get'. +e_get_array :: Key -> Event -> Maybe [Double] +e_get_array k = fmap (map (f_double_err (k_name k)) . f_vector) . e_get k + +-- | Type specialised 'e_get_ix'. -- --- > let m = f_merge (zip [0,2..6] ['a'..]) (zip [0,3,6] ['A'..]) --- > in m == [(0,'a'),(0,'A'),(2,'b'),(3,'B'),(4,'c'),(6,'d'),(6,'C')] -f_merge :: Ord a => [(a,t)] -> [(a,t)] -> [(a,t)] -f_merge p q = - case (p,q) of - ([],_) -> q - (_,[]) -> p - ((t0,e0):r0,(t1,e1):r1) -> - if t0 <= t1 - then (t0,e0) : f_merge r0 q - else (t1,e1) : f_merge p r1 +-- > let e = e_from_list [(K_scale,f_array [0,2])] +-- > in e_get_array_ix Nothing K_scale e == Just [0,2] +-- +-- > let e = e_from_list [(K_scale,f_ref (f_array [0,2]))] +-- > in e_get_array_ix (Just 0) K_scale e == Just [0,2] +e_get_array_ix :: Maybe Int -> Key -> Event -> Maybe [Double] +e_get_array_ix n k = + fmap (map (f_double_err (k_name k)) . f_vector) . + e_get_ix n k --- | Times are /hosc/ (NTP) times. -type Time = O.Time +-- | 'Event' /type/. +-- +-- > e_type mempty == "s_new" +e_type :: Event -> String +e_type = fromMaybe "s_new" . fmap f_string . e_get K_type +-- | Match on event types, in sequence: s_new, n_set, rest. +e_type_match :: Event -> T3 (Event -> t) -> t +e_type_match e (f,g,h) = + case e_type e of + "s_new" -> f e + "n_set" -> g e + "rest" -> h e + _ -> error ("Event.type: " ++ show e) + +-- | 'const' variant of 'e_type_match'. +e_type_match' :: Event -> T3 t -> t +e_type_match' e (f,g,h) = e_type_match e (const f,const g,const h) + +-- | Generate 'D.Dur' from 'Event'. +-- +-- > D.delta (e_dur Nothing mempty) == 1 +-- > D.fwd (e_dur Nothing (e_from_list [(K_dur,1),(K_stretch,2)])) == 2 +-- +-- > let e = e_from_list [(K_dur,1),(K_legato,0.5)] +-- > in D.occ (e_dur Nothing e) == 0.5 +e_dur :: Maybe Int -> Event -> D.Dur +e_dur n e = + let f k = e_get_double_ix n k e + in D.optDur (f K_tempo + ,f K_dur + ,f K_stretch + ,f K_legato + ,f K_sustain + ,f K_delta + ,f K_lag + ,f K_fwd') + +-- | Generate 'Pitch' from 'Event'. +-- +-- > P.midinote (e_pitch Nothing mempty) == 60 +-- > P.freq (e_pitch Nothing (e_from_list [(K_degree,5)])) == 440 +-- +-- > let e = e_from_list [(K_degree,5),(K_scale,f_array [0,2,3,5,7,8,10])] +-- > in P.midinote (e_pitch Nothing e) == 68 +-- +-- > let e = e_from_list [(K_degree,5),(K_scale,f_ref (f_array [0,2,3,5,7,8,10]))] +-- > in P.midinote (e_pitch (Just 0) (e_mce_expand e)) == 68 +-- +-- > P.freq (e_pitch Nothing (e_from_list [(K_midinote,69)])) == 440 +e_pitch :: Maybe Int -> Event -> P.Pitch +e_pitch n e = + let f k = e_get_double_ix n k e + in P.optPitch (f K_mtranspose + ,f K_gtranspose + ,f K_ctranspose + ,f K_octave + ,f K_root + ,f K_degree + ,e_get_array_ix n K_scale e + ,f K_stepsPerOctave + ,f K_detune + ,f K_harmonic + ,f K_freq + ,f K_midinote + ,f K_note) + +-- | 'Event' identifier. +e_id :: Maybe Int -> Event -> Maybe Int +e_id n = e_get_int_ix n K_id + +-- | Lookup /db/ field of 'Event'. +-- +-- > e_db Nothing mempty == (-20) +e_db :: Maybe Int -> Event -> Double +e_db n = fromMaybe (-20) . e_get_double_ix n K_db + +-- | The linear amplitude of the amplitude model at /e/. +-- +-- > e_amp Nothing (e_from_list [(K_db,-60)]) == 0.001 +-- > e_amp Nothing (e_from_list [(K_amp,0.01)]) == 0.01 +-- > e_amp Nothing mempty == 0.1 +e_amp :: Maybe Int -> Event -> Double +e_amp n e = fromMaybe (M.dbamp (e_db n e)) (e_get_double_ix n K_amp e) + +-- | Message /latency/ of event. +-- +-- > e_latency mempty == 0.1 +e_latency :: Event -> Double +e_latency = fromMaybe 0.1 . e_get_double K_latency + +-- | Extract non-'reserved' 'Keys' from 'Event'. +-- +-- > let e = e_from_list [(K_freq,1),(K_param "p",1),(K_scale,f_ref (f_array [0,3,7]))] +-- > in e_parameters Nothing e == [("p",1)] +e_parameters :: Maybe Int -> Event -> [(String,Double)] +e_parameters n = + map (\(k,v) -> (k_name k,f_double_err_ix (k_name k) n v)) . + filter k_is_parameter . + Map.toList + +-- | 'Value' editor for 'Key' at 'Event', with default value in case +-- 'Key' is not present. +e_edit :: Key -> Field -> (Field -> Field) -> Event -> Event +e_edit k v f e = + case e_get k e of + Just n -> e_insert k (f n) e + Nothing -> e_insert k (f v) e + +-- | Variant of 'edit_v' with no default value. +e_edit' :: Key -> (Field -> Field) -> Event -> Event +e_edit' k f e = + case e_get k e of + Just n -> e_insert k (f n) e + Nothing -> e + +-- * Event temporal + -- | Merge two time-stamped 'Event' sequences. Note that this uses --- 'fwd' to calculate start times. -merge' :: (Time,[Event]) -> (Time,[Event]) -> [(Time,Event)] -merge' (pt,p) (qt,q) = - let p_st = map (+ pt) (0 : scanl1 (+) (map fwd p)) - q_st = map (+ qt) (0 : scanl1 (+) (map fwd q)) - in f_merge (zip p_st p) (zip q_st q) +-- 'D.fwd' to calculate start times. +e_merge' :: (Time,[Event]) -> (Time,[Event]) -> [(Time,Event)] +e_merge' (pt,p) (qt,q) = + let f = D.fwd . e_dur Nothing + p_st = map (+ pt) (0 : scanl1 (+) (map f p)) + q_st = map (+ qt) (0 : scanl1 (+) (map f q)) + in t_merge (zip p_st p) (zip q_st q) -- | Insert /fwd/ 'Key's into a time-stamped 'Event' sequence. -add_fwd :: [(Time,Event)] -> [Event] -add_fwd e = +e_add_fwd :: [(Time,Event)] -> [Event] +e_add_fwd e = case e of (t0,e0):(t1,e1):e' -> - insert "fwd'" (t1 - t0) e0 : add_fwd ((t1,e1):e') + e_insert K_fwd' (F_Double (t1 - t0)) e0 : e_add_fwd ((t1,e1):e') _ -> map snd e -- | Composition of 'add_fwd' and 'merge''. -merge :: (Time,[Event]) -> (Time,[Event]) -> [Event] -merge p q = add_fwd (merge' p q) +e_merge :: (Time,[Event]) -> (Time,[Event]) -> [Event] +e_merge p q = e_add_fwd (e_merge' p q) --- | Does 'Event' have a non-zero @rest@ key. -is_rest :: Event -> Bool -is_rest e = - case lookup_m "rest" e of - Just r -> r > 0 - Nothing -> False +-- | N-ary variant of 'e_merge'. +-- +-- > e_par [(0,repeat (e_from_list [(K_id,1)])) +-- > ,(0,repeat (e_from_list [(K_param "b",2)])) +-- > ,(0,repeat (e_from_list [(K_param "c",3)]))] +e_par :: [(Time,[Event])] -> [Event] +e_par l = + case l of + [] -> [] + [(_,p)] -> p + (pt,p):(qt,q):r -> e_par ((min pt qt,e_merge (pt,p) (qt,q)) : r) --- | Generate @SC3@ 'O.Bundle' messages describing 'Event'. Consults the --- 'instrument_send_release' in relation to gate command. -to_sc3_bundle :: Time -> Int -> Event -> Maybe (O.Bundle,O.Bundle) -to_sc3_bundle t j e = - let s = instrument_name e - sr = instrument_send_release e - p = pitch e - d = duration e - rt = D.sustain d {- rt = release time -} - f = P.detunedFreq p - pr = ("freq",f) : ("midinote",P.midinote p) : ("note",P.note p) : - ("delta",D.delta d) : ("sustain",rt) : - ("amp",amp e) : - parameters e - i = fromMaybe j (e_id e) - t' = t + latency e - in if is_rest e || isNaN f +-- | 'mempty' with /rest/. +e_rest :: Event +e_rest = e_from_list [(K_rest,1)] + +-- | Does 'Event' have a 'True' @rest@ key. +-- +-- > e_is_rest mempty == False +-- > e_is_rest (e_from_list [(K_rest,1)]) == True +e_is_rest :: Event -> Bool +e_is_rest = fromMaybe False . e_get_bool K_rest + +-- * MCE + +-- | Maximum vector length at 'Event'. +-- +-- > e_mce_depth (e_from_list [(K_id,1)]) == Nothing +-- > e_mce_depth (e_from_list [(K_id,1),(K_param "b",f_array [2,3])]) == Just 2 +e_mce_depth :: Event -> Maybe Int +e_mce_depth e = + let f = map snd (e_to_list e) + in case mapMaybe f_vector_length f of + [] -> Nothing + l -> Just (maximum l) + +-- | Extend vectors at 'Event' if required, returning 'e_mce_depth'. +-- +-- > let {e = e_from_list [(K_id,f_array [1,2]),(K_param "b",f_array [2,3,4])] +-- > ;r = e_from_list [(K_id,f_array [1,2,1]),(K_param "b",f_array [2,3,4])]} +-- > in e_mce_extend e == Just (3,r) +-- +-- > let e = e_from_list [(K_id,1)] +-- > in e_mce_extend e == Nothing +e_mce_extend :: Event -> Maybe (Int,Event) +e_mce_extend e = + let e' = e_to_list e + flds = map snd e' + f n = let flds' = map (f_mce_extend n) flds + in (n,e_from_list (zip (map fst e') flds')) + in fmap f (e_mce_depth e) + +-- | 'e_mce_extend' variant. +e_mce_expand :: Event -> Event +e_mce_expand e = maybe e snd (e_mce_extend e) + +-- | Parallel 'Event's, if required. +-- +-- > let {e = e_from_list [(K_id,1),(K_param "b",f_array [2,3])] +-- > ;r = [e_from_list [(K_id,1),(K_param "b",2)],e_from_list [(K_id,1),(K_param "b",3)]]} +-- > in e_un_mce e == Just r +-- +-- > let {e = e_from_list [(K_id,f_array [1,2]),(K_param "b",f_array [3,4,5])] +-- > ;r = e_from_list [(K_id,1),(K_param "b",5)]} +-- > in fmap (!! 2) (e_un_mce e) == Just r +-- +-- > e_un_mce (e_from_list [(K_id,1)]) == Nothing +e_un_mce :: Event -> Maybe [Event] +e_un_mce e = + let e' = e_to_list e + flds = map snd e' + f n = let flds' = transpose (map (f_vector . f_mce_extend n) flds) + in map (e_from_list . zip (map fst e')) flds' + in fmap f (e_mce_depth e) + +-- | 'e_un_mce' variant. +e_un_mce' :: Event -> [Event] +e_un_mce' e = fromMaybe [e] (e_un_mce e) + +-- * SC3 + +-- | Generate @SC3@ /(on,off)/ 'Message' sets describing 'Event'. +e_messages :: D.Dur -> Event -> Int -> Maybe Int -> Maybe (T2 [Message]) +e_messages d e n_id n = + let e_i = e_get_instr_ix n K_instr e + s = maybe "default" I.i_name e_i + sr = maybe True I.i_send_release e_i + p = e_pitch n e + rt = D.occ d {- rt = release time -} + f = P.freq p + pr = ("freq",f) + : ("midinote",P.midinote p) + : ("delta",D.delta d) + : ("sustain",rt) + : ("amp",e_amp n e) + : e_parameters n e + n_id' = fromMaybe n_id (e_id n e) + in if e_is_rest e || isNaN f then Nothing - else let m_on = case e_type e of - E_s_new -> [S.s_new s i S.AddToTail 1 pr] - E_n_set -> [S.n_set i pr] - E_rest -> [] + else let m_on = e_type_match' e ([s_new s n_id' AddToTail 1 pr] + ,[n_set n_id' pr] + ,[]) m_off = if not sr then [] - else case e_type e of - E_s_new -> [S.n_set i [("gate",0)]] - E_n_set -> [S.n_set i [("gate",0)]] - E_rest -> [] - in Just (O.Bundle t' m_on - ,O.Bundle (t' + rt) m_off) + else e_type_match' e ([n_set n_id' [("gate",0)]] + ,[n_set n_id' [("gate",0)]] + ,[]) + m_on' = case I.i_synthdef =<< e_i of + Just sy -> d_recv sy : m_on + Nothing -> m_on + in Just (m_on',m_off) -{- --- | The frequency of the 'pitch' of /e/. +-- | MCE variant of 'e_messages'. +e_messages_mce :: D.Dur -> Event -> Int -> (Maybe (T2 [Message]),Int) +e_messages_mce d e n_id = + let (r,n) = case e_mce_extend e of + Just (m,e') -> (zipWith (e_messages d e') [n_id ..] (map Just [0 .. m - 1]),m) + Nothing -> ([e_messages d e n_id Nothing],1) + in case unzip (catMaybes r) of + ([],[]) -> (Nothing,n_id) + (m_on,m_off) -> (Just (concat m_on,concat m_off),n_id + n) + +-- | Generate @SC3@ /(on,off)/ 'Bundle's describing 'Event'. +e_bundles :: Time -> Int -> D.Dur -> Event-> (Maybe (T2 Bundle),Int) +e_bundles t n_id d e = + let rt = D.occ d {- rt = release time -} + t' = t + realToFrac (e_latency e) + t'' = t' + realToFrac rt + in case e_messages_mce d e n_id of + (Nothing,n_id') -> (Nothing,n_id') + (Just (m_on,m_off),n_id') -> (Just (Bundle t' m_on,Bundle t'' m_off),n_id') + +-- | Ordered sequence of 'Event'. +newtype Event_Seq = Event_Seq {e_seq_events :: [Event]} + +-- | Transform 'Event_Seq' into a sequence of @SC3@ /(on,off)/ 'Bundles'. -- --- > freq (event [("degree",5)]) == 440 --- > freq (event [("midinote",69)]) == 440 -freq :: Event -> Double -freq = P.detunedFreq . pitch +-- > e_bundle_seq 0 (Event_Seq (replicate 5 mempty)) +e_bundle_seq :: Time -> Event_Seq -> [T2 Bundle] +e_bundle_seq st = + let rec t i l = + case l of + [] -> [] + e:l' -> let d = e_dur Nothing e + t' = t + D.fwd d + (b,i') = e_bundles t i d e + in b `mcons` rec t' i' l' + in rec st 1000 . e_seq_events --- | The /sustain/ value of the duration model at /e/. +-- | Transform (productively) an 'Event_Seq' into an 'NRT' score. -- --- > sustain (event [("dur",1),("legato",0.5)]) == 0.5 -sustain :: Event -> Double -sustain = D.sustain . duration --} +-- > let {n1 = nrt_bundles (e_nrt (Event_Seq (replicate 5 mempty))) +-- > ;n2 = take 10 (nrt_bundles (e_nrt (Event_Seq (repeat mempty))))} +-- > in n1 == n2 +e_nrt :: Event_Seq -> NRT +e_nrt = + let rec r l = + case l of + [] -> r + (o,c):l' -> let (c',r') = span (<= o) (insert o (insert c r)) + in c' ++ rec r' l' + in NRT . rec [] . e_bundle_seq 0 + +-- | Audition 'Event_Seq'. +e_play :: Transport m => Event_Seq -> m () +e_play l = do + st <- time + let f (p,q) = pauseThreadUntil (bundleTime p - 0.1) >> + sendBundle p >> + sendBundle q + mapM_ f (e_bundle_seq st l) + +instance Audible Event_Seq where play = e_play + +-- * Aliases + +-- | Type-specialised 'mempty'. +e_empty :: Event +e_empty = mempty + +-- | Type-specialised 'mappend'. +-- +-- > let {l = [(K_id,0)];r = [(K_degree,1)]} +-- > in e_from_list l <> e_from_list r == e_from_list (l <> r) +e_union :: Event -> Event -> Event +e_union = mappend + +-- * Temporal + +-- | Left-biased merge of two sorted sequence of temporal values. +-- +-- > let m = t_merge (zip [0,2,4,6] ['a'..]) (zip [0,3,6] ['A'..]) +-- > in m == [(0,'a'),(0,'A'),(2,'b'),(3,'B'),(4,'c'),(6,'d'),(6,'C')] +t_merge :: Ord t => [(t,a)] -> [(t,a)] -> [(t,a)] +t_merge p q = + case (p,q) of + ([],_) -> q + (_,[]) -> p + ((t0,e0):r0,(t1,e1):r1) -> + if t0 <= t1 + then (t0,e0) : t_merge r0 q + else (t1,e1) : t_merge p r1 + +-- * Tuple + +-- | Two tuple of /n/. +type T2 n = (n,n) + +-- | Three tuple of /n/. +type T3 n = (n,n,n) + +-- * List + +-- | 'Maybe' variant of ':'. +mcons :: Maybe a -> [a] -> [a] +mcons e l = case e of {Just e' -> e' : l;Nothing -> l} diff --git a/Sound/SC3/Lang/Control/Instrument.hs b/Sound/SC3/Lang/Control/Instrument.hs --- a/Sound/SC3/Lang/Control/Instrument.hs +++ b/Sound/SC3/Lang/Control/Instrument.hs @@ -1,29 +1,40 @@ -- | An instrument abstraction and a /default/ instrument for patterns. module Sound.SC3.Lang.Control.Instrument where -import Sound.SC3.ID +import Data.Default {- data-default -} +import Sound.SC3.ID {- hsc3 -} --- | An 'Instrument' is either a 'Synthdef' or the 'String' naming a +-- | An 'Instr' is either a 'Synthdef' or the 'String' naming a -- 'Synthdef'. -data Instrument = InstrumentDef {instrument_def :: Synthdef - ,send_release :: Bool} - | InstrumentName {instrument_name :: String - ,send_release :: Bool} - deriving (Eq,Show) +data Instr = Instr_Def {i_def :: Synthdef,i_send_release :: Bool} + | Instr_Ref {i_ref :: String,i_send_release :: Bool} + deriving (Eq,Show) --- | The SC3 /default/ instrument 'Synthdef'. -defaultInstrument :: Synthdef -defaultInstrument = - let f = control KR "freq" 440 - a = control KR "amp" 0.1 - p = control KR "pan" 0 - g = control KR "gate" 1 - e = linen g 0.01 0.7 0.3 RemoveSynth - f3 = mce [f,f + rand 'a' (-0.4) 0,f + rand 'b' 0 0.4] - l = xLine KR (rand 'c' 4000 5000) (rand 'd' 2500 3200) 1 DoNothing - z = lpf (mix (varSaw AR f3 0 0.3 * 0.3)) l * e - in synthdef "default" (out 0 (pan2 z p a)) +-- | All 'Instr' have a name. +i_name :: Instr -> String +i_name i = + case i of + Instr_Def s _ -> synthdefName s + Instr_Ref nm _ -> nm +-- | All 'Instr' may have a 'Synthdef'. +i_synthdef :: Instr -> Maybe Synthdef +i_synthdef i = + case i of + Instr_Def s _ -> Just s + Instr_Ref _ _ -> Nothing + +-- | If 'I_Def' subsequent are 'I_Ref', else all 'I_Ref'. +i_repeat :: Instr -> [Instr] +i_repeat i = + case i of + Instr_Def d sr -> i : repeat (Instr_Ref (synthdefName d) sr) + Instr_Ref _ _ -> repeat i + +-- | 'Instr' of 'defaultSynthdef', ie. 'def' of 'Synthdef'. +defaultInstr :: Instr +defaultInstr = Instr_Def def True + {- -withSC3 (\fd -> async fd (d_recv defaultInstrument)) +withSC3 (send (d_recv defaultSynthdef)) -} diff --git a/Sound/SC3/Lang/Control/Midi.hs b/Sound/SC3/Lang/Control/Midi.hs --- a/Sound/SC3/Lang/Control/Midi.hs +++ b/Sound/SC3/Lang/Control/Midi.hs @@ -1,18 +1,34 @@ -{-# LANGUAGE PackageImports #-} -- | For a single input controller, key events always arrive in --- sequence (ie. on->off), ie. for any key on message can allocate an --- ID and associate it with the key, an off message can retrieve the --- ID given the key. +-- sequence (ie. on->off), ie. for any key on message we can allocate +-- an ID and associate it with the key, an off message can retrieve +-- the ID given the key. module Sound.SC3.Lang.Control.Midi where -import qualified Control.Exception as E -import Control.Monad -import "mtl" Control.Monad.State -import Data.Bits +import qualified Control.Exception as E {- base -} +import Control.Monad {- base -} +import Control.Monad.IO.Class {- transformers -} +import Control.Monad.Trans.State {- transformers -} +import Data.Bits {- base -} import qualified Data.ByteString.Lazy as B {- bytestring -} import qualified Data.Map as M {- containers -} import Sound.OSC.FD {- hosc -} +-- * Bits + +-- | Join two 7-bit values into a 14-bit value. +-- +-- > map (uncurry b_join) [(0,0),(0,64),(127,127)] == [0,8192,16383] +b_join :: Bits a => a -> a -> a +b_join p q = p .|. shiftL q 7 + +-- | Inverse of 'b_join'. +-- +-- > map b_sep [0,8192,16383] == [(0,0),(0,64),(127,127)] +b_sep :: (Num t,Bits t) => t -> (t, t) +b_sep n = (0x7f .&. n,0xff .&. shiftR n 7) + +-- * Types + -- | data Midi_Message a = Chanel_Aftertouch a a | Control_Change a a a @@ -78,23 +94,13 @@ 127 -> Poly_Mode_On i _ -> Undefined --- | Join two 7-bit values into a 14-bit value. --- --- > map (uncurry b_join) [(0,0),(0,64),(127,127)] == [0,8192,16383] -b_join :: Bits a => a -> a -> a -b_join p q = p .|. shiftL q 7 - --- | Inverse of 'b_join'. --- --- > map b_sep [0,8192,16383] == [(0,0),(0,64),(127,127)] -b_sep :: (Num t,Bits t) => t -> (t, t) -b_sep n = (0x7f .&. n,0xff .&. shiftR n 7) +-- * OSC -- | Parse @midi-osc@ @/midi/@ message. parse_b :: Integral n => Message -> [n] parse_b m = case m of - Message "/midi" [Int _,Blob b] -> map fromIntegral (B.unpack b) + Message "/midi" [Int32 _,Blob b] -> map fromIntegral (B.unpack b) _ -> [] -- | Variant of 'parse_b' that give status byte as low and high. @@ -118,6 +124,8 @@ [0xe,i,j,k] -> Pitch_Bend i (b_join j k) x -> Unknown x +-- * SC3 + -- | @SC3@ node identifiers are integers. type Node_Id = Int @@ -144,6 +152,8 @@ (K m _) <- get return (m M.! n) +-- * IO + -- | The 'Midi_Receiver' is passed a 'Midi_Message' and a 'Node_Id'. -- For 'Note_On' and 'Note_Off' messages the 'Node_Id' is positive, -- for all other message it is @-1@. @@ -165,7 +175,7 @@ start_midi receiver = do s_fd <- openUDP "127.0.0.1" 57110 -- midi-osc m_fd <- openUDP "127.0.0.1" 57150 -- midi-osc - sendMessage m_fd (Message "/receive" [Int 0xffff]) + sendMessage m_fd (Message "/receive" [Int32 0xffff]) let step = liftIO (recvMessages m_fd) >>= midi_act (receiver s_fd) . head ex e = print ("start_midi",show (e::E.AsyncException)) >> diff --git a/Sound/SC3/Lang/Control/OverlapTexture.hs b/Sound/SC3/Lang/Control/OverlapTexture.hs --- a/Sound/SC3/Lang/Control/OverlapTexture.hs +++ b/Sound/SC3/Lang/Control/OverlapTexture.hs @@ -7,10 +7,12 @@ -- post-processing stage. module Sound.SC3.Lang.Control.OverlapTexture where -import Data.List +import Control.Applicative {- base -} +import Data.List {- base -} import Sound.OSC {- hosc -} import Sound.SC3 {- hsc3 -} -import Sound.SC3.Lang.Control.Event as E {- hsc3-lang -} + +import Sound.SC3.Lang.Control.Event import Sound.SC3.Lang.Control.Instrument import Sound.SC3.Lang.Pattern.ID @@ -36,6 +38,7 @@ -- overlaping (simultaneous) nodes and 4. number of nodes altogether. type OverlapTexture = (Double,Double,Double,Int) +-- | Record of 'OverlapTexture'. data OverlapTexture_ = OverlapTexture {sustain_time :: Double ,transition_time :: Double @@ -81,15 +84,16 @@ g' = with_env k g in synthdef n g' --- | Generate an 'Event' pattern from 'OverlapTexture' control +-- | Generate an /event/ pattern from 'OverlapTexture' control -- parameters and a continuous signal. overlapTextureP :: OverlapTexture -> UGen -> P Event overlapTextureP k g = let s = gen_synth (overlapTexture_env k) g (l,d) = overlapTexture_dt k (_,_,_,c) = k - i = return (InstrumentDef s False) - in pinstr i (pbind [("dur",pn (return d) c),("legato", return l)]) + in pbind [(K_instr,pinstr' (Instr_Def s False)) + ,(K_dur,pn (return (F_Double d)) c) + ,(K_legato,pure (F_Double l))] -- | Audition pattern given by 'overlapTextureP'. -- @@ -111,12 +115,12 @@ nm = show (hashUGen u) in synthdef nm u --- | Audition 'Event' pattern with specified post-processing function. -post_process_a :: Transport m => P Event -> Int -> (UGen -> UGen) -> m () +-- | Audition /event/ pattern with specified post-processing function. +post_process_a :: (Transport m) => P Event -> Int -> (UGen -> UGen) -> m () post_process_a p nc f = do let s = post_process_s nc f _ <- async (d_recv s) - send (s_new (synthdefName s) (-1) AddToTail 2 []) + send (s_new0 (synthdefName s) (-1) AddToTail 2) play p -- | Post processing function. @@ -128,15 +132,16 @@ let p = overlapTextureP k u withSC3 (post_process_a p nc f) --- | Generate an 'Event' pattern from 'XFadeTexture' control +-- | Generate an /event/ pattern from 'XFadeTexture' control -- parameters and a continuous signal. xfadeTextureP :: XFadeTexture -> UGen -> P Event xfadeTextureP k g = let s = gen_synth (xfadeTexture_env k) g (l,d) = xfadeTexture_dt k (_,_,c) = k - i = return (InstrumentDef s False) - in pinstr i (pbind [("dur",pn (return d) c),("legato", return l)]) + in pbind [(K_instr,pinstr' (Instr_Def s False)) + ,(K_dur,pn (return (F_Double d)) c) + ,(K_legato,pure (F_Double l))] -- | Audition pattern given by 'xfadeTextureP'. -- @@ -155,17 +160,19 @@ -- | UGen generating state transform function. type USTF st = (st -> (UGen,st)) --- | Variant of 'overlapTextureP' where the continuous signal for --- each 'Event' is derived from a state transform function seeded with +-- | Variant of 'overlapTextureP' where the continuous signal for each +-- /event/ is derived from a state transform function seeded with -- given initial state. overlapTextureP_st :: OverlapTexture -> USTF st -> st -> P Event overlapTextureP_st k u i_st = let (l,d) = overlapTexture_dt k (_,_,_,c) = k g = take c (unfoldr (Just . u) i_st) - i = flip InstrumentDef False - s = map (i . gen_synth (overlapTexture_env k)) g - in pinstr (fromList s) (pbind [("dur",prepeat d),("legato",prepeat l)]) + i = flip Instr_Def False + s = toP (map (i . gen_synth (overlapTexture_env k)) g) + in pbind [(K_instr,fmap F_Instr s) + ,(K_dur,pure (F_Double d)) + ,(K_legato,pure (F_Double l))] -- | Audition pattern given by 'overlapTextureP_st'. overlapTextureS :: OverlapTexture -> USTF st -> st -> IO () @@ -181,9 +188,9 @@ type MSTF st m = (st -> m (Maybe st)) -- | Run a monadic state transforming function /f/ that operates with --- a delta 'E.Time' indicating the duration to pause before re-running +-- a delta 'Time' indicating the duration to pause before re-running -- the function. -dt_rescheduler_m :: MonadIO m => MSTF (st,E.Time) m -> (st,E.Time) -> m () +dt_rescheduler_m :: MonadIO m => MSTF (st,Time) m -> (st,Time) -> m () dt_rescheduler_m f = let rec (st,t) = do pauseThreadUntil t @@ -194,7 +201,8 @@ in rec -- | Underlying function of 'overlapTextureM' with explicit 'Transport'. -overlapTextureR :: Transport m => OverlapTexture -> IO UGen -> MSTF (Int,E.Time) m +overlapTextureR :: Transport m => + OverlapTexture -> IO UGen -> MSTF (Int,Time) m overlapTextureR k uf = let nm = "ot_" ++ show k (_,dt) = overlapTexture_dt k @@ -202,7 +210,7 @@ u <- liftIO uf let g = with_env (overlapTexture_env k) u _ <- async (d_recv (synthdef nm g)) - send (s_new nm (-1) AddToTail 1 []) + send (s_new0 nm (-1) AddToTail 1) case st of 0 -> return Nothing _ -> return (Just (st-1,dt)) diff --git a/Sound/SC3/Lang/Control/Pitch.hs b/Sound/SC3/Lang/Control/Pitch.hs --- a/Sound/SC3/Lang/Control/Pitch.hs +++ b/Sound/SC3/Lang/Control/Pitch.hs @@ -1,6 +1,22 @@ -- | @SC3@ pitch model implementation. module Sound.SC3.Lang.Control.Pitch where +import Data.Maybe {- base -} +import Sound.SC3.Lang.Math + +-- * Pitched + +-- | 'Pitched' values, minimal definition is 'midinote'. +-- +-- > midinote (defaultPitch {degree = 5}) == 69 +-- > freq (defaultPitch {degree = 5,detune = 10}) == 440 + 10 +class Pitched p where + midinote :: p -> Double + freq :: p -> Double + freq = midicps . midinote + +-- * Pitch + -- | The supercollider language pitch model is organised as a tree -- with three separate layers, and is designed to allow separate -- processes to manipulate aspects of the model independently. @@ -14,7 +30,7 @@ -- a scale interpreted relative to an equally tempered octave divided -- into the indicated number of steps. -- --- The midinote is derived from the note by adding the inidicated +-- The midinote is derived from the note by adding the indicated -- root, octave and gamut transpositions. -- -- The frequency is derived by a chromatic transposition of the @@ -38,99 +54,89 @@ -- -- > let {edit_mtranspose p d = p {mtranspose = mtranspose p + d} -- > ;edit_octave p o = p {octave = octave p + o} --- > ;p = repeat defaultPitch --- > ;q = zipWith edit_mtranspose p [0,2,4,3,5] --- > ;r = zipWith edit_octave q [0,-1,0,1,0]} --- > in (map midinote q,map midinote r) -data Pitch a = Pitch { mtranspose :: a - , gtranspose :: a - , ctranspose :: a - , octave :: a - , root :: a - , scale :: [a] - , degree :: a - , stepsPerOctave :: a - , detune :: a - , harmonic :: a - , freq_f :: Pitch a -> a - , midinote_f :: Pitch a -> a - , note_f :: Pitch a -> a } - --- | Midi note number to cycles per second. --- --- > midi_cps 69 == 440 -midi_cps :: (Floating a) => a -> a -midi_cps a = 440.0 * (2.0 ** ((a - 69.0) * (1.0 / 12.0))) +-- > ;p' = repeat defaultPitch +-- > ;q = zipWith edit_mtranspose p' [0,2,4,3,5] +-- > ;r = zipWith edit_octave q [0,-1,0,1,0] +-- > ;f = map midinote} +-- > in (f q,f r) == ([60,64,67,65,69],[60,52,67,77,69]) +data Pitch = Pitch {mtranspose :: Double + ,gtranspose :: Double + ,ctranspose :: Double + ,octave :: Double + ,root :: Double + ,scale :: [Double] + ,degree :: Double + ,stepsPerOctave :: Double + ,detune :: Double + ,harmonic :: Double + ,freq' :: Maybe Double + ,midinote' :: Maybe Double + ,note' :: Maybe Double + } + deriving (Eq,Show) -- | A default 'Pitch' value of middle C given as degree @0@ of a C -- major scale. -- --- > degree defaultPitch == 0 --- > scale defaultPitch == [0,2,4,5,7,9,11] --- > stepsPerOctave defaultPitch == 12 -defaultPitch :: (Floating a, RealFrac a) => Pitch a +-- > let {p = defaultPitch +-- > ;r = ([0,2,4,5,7,9,11],12,0,5,0)} +-- > in (scale p,stepsPerOctave p,root p,octave p,degree p) == r +defaultPitch :: Pitch defaultPitch = - Pitch { mtranspose = 0 - , gtranspose = 0 - , ctranspose = 0 - , octave = 5 - , root = 0 - , degree = 0 - , scale = [0,2,4,5,7,9,11] - , stepsPerOctave = 12 - , detune = 0 - , harmonic = 1 - , freq_f = default_freq_f - , midinote_f = default_midinote_f - , note_f = default_note_f + Pitch {mtranspose = 0 + ,gtranspose = 0 + ,ctranspose = 0 + ,octave = 5 + ,root = 0 + ,degree = 0 + ,scale = [0,2,4,5,7,9,11] + ,stepsPerOctave = 12 + ,detune = 0 + ,harmonic = 1 + ,freq' = Nothing + ,midinote' = Nothing + ,note' = Nothing } --- | The 'freq_f' function for 'defaultPitch'. -default_freq_f :: (Floating a) => Pitch a -> a -default_freq_f e = midi_cps (midinote e + ctranspose e) * harmonic e - --- | The 'midinote_f' function for 'defaultPitch'. -default_midinote_f :: (Fractional a) => Pitch a -> a -default_midinote_f e = - let n = note e + gtranspose e + root e - in (n / stepsPerOctave e + octave e) * 12 - --- | The 'note_f' function for 'defaultPitch'. -default_note_f :: (RealFrac a) => Pitch a -> a -default_note_f e = - let d = degree e + mtranspose e - in degree_to_key (scale e) (stepsPerOctave e) d - --- | Translate degree, scale and steps per octave to key. --- --- > degree_to_key [0,2,4,5,7,9,11] 12 5 == 9 -degree_to_key :: (RealFrac a) => [a] -> a -> a -> a -degree_to_key s n d = - let l = length s - d' = round d - a = (d - fromIntegral d') * 10.0 * (n / 12.0) - in (n * fromIntegral (d' `div` l)) + (s !! (d' `mod` l)) + a - --- | The note value of the pitch model. +-- | Calculate /note/ field. -- -- > note (defaultPitch {degree = 5}) == 9 -note :: Pitch a -> a -note e = note_f e e +note :: Pitch -> Double +note p = + let f e = let d = degree e + mtranspose e + in degreeToKey (scale e) (stepsPerOctave e) d + in fromMaybe (f p) (note' p) --- | The midi note value of the pitch model. --- --- > midinote (defaultPitch {degree = 5}) == 69 -midinote :: Pitch a -> a -midinote e = midinote_f e e +instance Pitched Pitch where + midinote p = + let f e = let n = note e + gtranspose e + root e + in (n / stepsPerOctave e + octave e) * 12 + in fromMaybe (f p) (midinote' p) + freq p = + let f e = midicps (midinote e + ctranspose e) * harmonic e + in fromMaybe (f p) (freq' p) + detune p --- | The frequency value of the pitch model, excluding 'detune'. --- --- > freq (defaultPitch {degree = 5,detune = 10}) == 440 -freq :: Pitch a -> a -freq e = freq_f e e +-- * Optional --- | The frequency value of the complete pitch model, including 'detune'. --- --- > detunedFreq (defaultPitch {degree = 5}) == 440 -detunedFreq :: (Num a) => Pitch a -> a -detunedFreq e = freq e + detune e +-- | Tuple in 6-1-6 arrangement. +type T616 a b c = (a,a,a,a,a,a,b,c,c,c,c,c,c) + +-- | 'Pitch' represented as tuple of optional values. +type OptPitch = T616 (Maybe Double) (Maybe [Double]) (Maybe Double) + +-- | Transform 'OptPitch' to 'Pitch'. +optPitch :: OptPitch -> Pitch +optPitch (mt,gt,ct,o,r,d,s,s',d',h,f,m,n) = + Pitch {mtranspose = fromMaybe 0 mt + ,gtranspose = fromMaybe 0 gt + ,ctranspose = fromMaybe 0 ct + ,octave = fromMaybe 5 o + ,root = fromMaybe 0 r + ,degree = fromMaybe 0 d + ,scale = fromMaybe [0,2,4,5,7,9,11] s + ,stepsPerOctave = fromMaybe 12 s' + ,detune = fromMaybe 0 d' + ,harmonic = fromMaybe 1 h + ,freq' = f + ,midinote' = m + ,note' = n} diff --git a/Sound/SC3/Lang/Math.hs b/Sound/SC3/Lang/Math.hs --- a/Sound/SC3/Lang/Math.hs +++ b/Sound/SC3/Lang/Math.hs @@ -1,37 +1,40 @@ -- | @sclang@ math functions. module Sound.SC3.Lang.Math where -import Data.Bits +import Data.Bits {- base -} --- * Binary +-- * SimpleNumber --- | @0@ is false, @1@ is True, else error. +-- | @SimpleNumber.ampdb@ converts linear amplitude to decibels. -- --- > map bitChar "01" == [False,True] -bitChar :: Char -> Bool -bitChar c = - case c of - '0' -> False - '1' -> True - _ -> error "bitChar" - --- | Parse a sequence of 0 and 1 characters as a BE bit sequence +-- > > [1,0.5,0.25,0.13,6e-2].collect({|i| i.ampdb.round}) == [0,-6,-12,-18,-24] +-- > map (round . ampdb) [1,0.5,0.25,0.13,6e-2] == [0,-6,-12,-18,-24] -- --- > parseBits "101" == 5 --- > parseBits "00001111" == 15 -parseBits :: (Num a,Bits a) => String -> a -parseBits x = - let x' = filter (id . bitChar . snd) (zip [0..] (reverse x)) - in foldr ((.|.) . bit . fst) 0 x' +-- > > [1,0.7,0.5,0.35,0.25].collect({|i| i.ampdb.round}) == [0,-3,-6,-9,-12] +-- > map (round . ampdb) [1,0.7,0.5,0.35,0.25] == [0,-3,-6,-9,-12] +ampdb :: Floating a => a -> a +ampdb = (* 20) . log10 --- * SimpleNumber +-- | @SimpleNumber.dbamp@ converts decibels to a linear amplitude. +-- +-- > > [0,-3,-6,-9,-12].collect({|i| (i.dbamp * 100).floor}) == [100,70,50,35,25] +-- > map (floor . (* 100) . dbamp) [0,-3,-6,-9,-12] == [100,70,50,35,25] +dbamp :: Floating a => a -> a +dbamp = (10 **) . (* 0.05) --- | Variant of @SimpleNumber.exprand@ that shifts a linear (0,1) --- value to an exponential distribution. +-- | @SimpleNumber.degreeToKey@ translates degree, scale and steps per +-- octave to key. -- --- > map (floor . exprandrng 10 100) [0,0.5,1] == [10,31,100] -exprandrng :: (Floating b) => b -> b -> b -> b -exprandrng l r i = l * exp (log (r / l) * i) +-- > > (0..5).collect({|i| i.degreeToKey([0,1,5,9,11],12)}) == [0,1,5,9,11,12] +-- > map (degreeToKey [0,1,5,9,11] 12) [0..5] == [0,1,5,9,11,12] +-- +-- > degreeToKey [0,2,4,5,7,9,11] 12 5 == 9 +degreeToKey :: (RealFrac a) => [a] -> a -> a -> a +degreeToKey s n d = + let l = length s + d' = round d + a = (d - fromIntegral d') * 10.0 * (n / 12.0) + in (n * fromIntegral (d' `div` l)) + (s !! (d' `mod` l)) + a -- | Psuedo-inifite bounded value. -- @@ -47,6 +50,7 @@ -- | @SimpleNumber.linexp@ shifts from linear to exponential ranges. -- +-- > > [1,1.5,2].collect({|i| i.linexp(1,2,10,100).floor}) == [10,31,100] -- > map (floor . linexp 1 2 10 100) [1,1.5,2] == [10,31,100] linexp :: (Ord a, Floating a) => a -> a -> a -> a -> a -> a linexp l r l' r' n = @@ -56,24 +60,44 @@ then r' else ((r'/l') ** ((n-l)/(r-l))) * l' --- * Gain - --- | Synonym for 'logBase' @10@. +-- | @SimpleNumber.log10@ is the base 10 logarithm. log10 :: Floating a => a -> a log10 = logBase 10 --- > map rmsToDb [1,0.75,0.5,0.25,0] -rmsToDb :: Floating a => a -> a -rmsToDb rms = log10 rms * 20 +-- | @SimpleNumber.midicps@ translates from midi note number to cycles +-- per second. +-- +-- > > [57,69].collect({|i| i.midicps}) == [220,440] +-- > map midicps [57,69] == [220,440] +midicps :: (Floating a) => a -> a +midicps a = 440.0 * (2.0 ** ((a - 69.0) * (1.0 / 12.0))) --- > map dbToRms [0,-3,-6,-9,-12] -dbToRms :: Floating a => a -> a -dbToRms db = 10 ** (db * 0.05) +-- * UGen --- > map powToDb [1,0.75,0.5,0.25,0] -powToDb :: Floating a => a -> a -powToDb pow = 10 * log10 pow +-- | @UGen.exprand@ shifts a linear (0,1) value to an exponential +-- range. +-- +-- > map (floor . exprange 10 100) [0,0.5,1] == [10,31,100] +exprange :: (Floating b) => b -> b -> b -> b +exprange l r i = l * exp (log (r / l) * i) --- > map dbToPow [0,-3,-6,-9,-12] -dbToPow :: Floating a => a -> a -dbToPow db = 10 ** (db * 0.1) +-- * Binary + +-- | @0@ is false, @1@ is True, else error. +-- +-- > map bitChar "01" == [False,True] +bitChar :: Char -> Bool +bitChar c = + case c of + '0' -> False + '1' -> True + _ -> error "bitChar" + +-- | Parse a sequence of 0 and 1 characters as a BE bit sequence +-- +-- > parseBits "101" == 5 +-- > parseBits "00001111" == 15 +parseBits :: (Num a,Bits a) => String -> a +parseBits x = + let x' = filter (id . bitChar . snd) (zip [0..] (reverse x)) + in foldr ((.|.) . bit . fst) 0 x' diff --git a/Sound/SC3/Lang/Math/Warp.hs b/Sound/SC3/Lang/Math/Warp.hs --- a/Sound/SC3/Lang/Math/Warp.hs +++ b/Sound/SC3/Lang/Math/Warp.hs @@ -21,8 +21,8 @@ -- | A linear real value map. -- --- > w = LinearWarp(ControlSpec(1,2)) --- > [0,0.5,1].collect{|n| w.map(n)} == [1,1.5,2] +-- > > w = LinearWarp(ControlSpec(1,2)) +-- > > [0,0.5,1].collect{|n| w.map(n)} == [1,1.5,2] -- -- > map (w_map (warpLinear 1 2)) [0,1/2,1] == [1,3/2,2] -- > map (warpLinear (-1) 1 W_Map) [0,1/2,1] == [-1,0,1] @@ -35,8 +35,8 @@ -- | The left and right must both be non zero and have the same sign. -- --- > w = ExponentialWarp(ControlSpec(1,2)) --- > [0,0.5,1].collect{|n| w.map(n)} == [1,pow(2,0.5),2] +-- > > w = ExponentialWarp(ControlSpec(1,2)) +-- > > [0,0.5,1].collect{|n| w.map(n)} == [1,pow(2,0.5),2] -- -- > map (warpExponential 1 2 W_Map) [0,0.5,1] == [1,2 ** 0.5,2] warpExponential :: (Floating a) => a -> a -> Warp a @@ -48,8 +48,8 @@ -- | Cosine warp -- --- > w = CosineWarp(ControlSpec(1,2)) --- > [0,0.25,0.5,0.75,1].collect{|n| w.map(n)} +-- > > w = CosineWarp(ControlSpec(1,2)) +-- > > [0,0.25,0.5,0.75,1].collect{|n| w.map(n)} -- -- > map (warpCosine 1 2 W_Map) [0,0.25,0.5,0.75,1] warpCosine :: (Floating a) => a -> a -> Warp a @@ -82,8 +82,8 @@ warpDbFader :: (Eq a,Floating a) => Warp a warpDbFader d n = if d == W_Map - then if n == 0 then -180 else rmsToDb (n * n) - else sqrt (dbToRms n) + then if n == 0 then -180 else ampdb (n * n) + else sqrt (dbamp n) -- | A curve warp given by a real /n/. -- diff --git a/Sound/SC3/Lang/Math/Window.hs b/Sound/SC3/Lang/Math/Window.hs --- a/Sound/SC3/Lang/Math/Window.hs +++ b/Sound/SC3/Lang/Math/Window.hs @@ -2,7 +2,7 @@ module Sound.SC3.Lang.Math.Window where import qualified Numeric.GSL.Special.Bessel as M {- hmatrix-special -} -import qualified Numeric.GSL.Special.Trig as M +import qualified Numeric.GSL.Special.Trig as M {- hmatrix-special -} -- * Type and conversion @@ -69,42 +69,43 @@ -- | 'window_table' . 'gaussian'. -- --- > plot [gaussian_table 1024 0.25,gaussian_table 1024 0.5] +-- > import Sound.SC3.Plot +-- > plotTable [gaussian_table 1024 0.25,gaussian_table 1024 0.5] gaussian_table :: (Integral n, Floating b, Enum b) => n -> b -> [b] gaussian_table n = window_table n . gaussian -- | 'window_table' . 'hamming'. -- --- plot [hann 128,hamming 128] +-- plotTable [hann_table 128,hamming_table 128] hamming_table :: Int -> [Double] hamming_table n = window_table n hamming -- | 'window_table' . 'hann'. -- --- plot [hann_table 128] +-- plotTable [hann_table 128] hann_table :: Int -> [Double] hann_table n = window_table n hann -- | 'window_table' . 'kaiser'. -- --- plot [kaiser_table 128 1,kaiser_table 128 2,kaiser_table 128 8] +-- let k = kaiser_table 128 in plotTable [k 1,k 2,k 8] kaiser_table :: Int -> Double -> [Double] kaiser_table n = window_table n . kaiser -- | 'window_table' . 'lanczos'. -- --- plot [lanczos (2^9)] +-- plotTable [lanczos_table (2^9)] lanczos_table :: Integral n => n -> [Double] lanczos_table n = window_table n lanczos -- | 'window_table' . 'sine'. -- --- plot [sine 128] +-- plotTable [sine_table 128] sine_table :: (Integral n, Floating b, Enum b) => n -> [b] sine_table n = window_table n sine -- | 'window_table' . 'triangular'. -- --- plot [triangular (2^9)] +-- plotTable [triangular_table (2^9)] triangular_table :: (Integral n, Fractional b, Enum b) => n -> [b] triangular_table n = window_table n triangular diff --git a/Sound/SC3/Lang/Pattern.hs b/Sound/SC3/Lang/Pattern.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Pattern.hs @@ -0,0 +1,9 @@ +-- | Composite module. +module Sound.SC3.Lang.Pattern (module P) where + +import Sound.SC3.Lang.Control.Duration as P +import Sound.SC3.Lang.Control.Event as P +import Sound.SC3.Lang.Control.Instrument as P +import Sound.SC3.Lang.Control.Pitch as P +import Sound.SC3.Lang.Control.OverlapTexture as P +import Sound.SC3.Lang.Pattern.ID as P diff --git a/Sound/SC3/Lang/Pattern/ID.hs b/Sound/SC3/Lang/Pattern/ID.hs --- a/Sound/SC3/Lang/Pattern/ID.hs +++ b/Sound/SC3/Lang/Pattern/ID.hs @@ -1,1118 +1,1960 @@ {-# Language FlexibleInstances #-} -- | @sclang@ pattern library functions. -- See for tutorial. -module Sound.SC3.Lang.Pattern.ID where - -import Control.Applicative hiding ((<*)) -import Control.Monad -import qualified Data.Foldable as F -import qualified Data.List as L -import qualified Data.List.Split as S -import Data.Maybe -import Data.Monoid -import Data.Traversable -import Sound.OSC -import Sound.SC3 -import qualified Sound.SC3.Lang.Collection as C -import qualified Sound.SC3.Lang.Control.Event as E -import qualified Sound.SC3.Lang.Control.Instrument as I -import qualified Sound.SC3.Lang.Control.Pitch as P -import qualified Sound.SC3.Lang.Math as M -import Sound.SC3.Lang.Pattern.List -import qualified Sound.SC3.Lang.Random.Gen as R -import System.Random - --- * P type and instances - --- | Pattern continuation mode -data M = Stop - | Continue - deriving (Eq,Show) - --- | Pattern data type (opaque) -data P a = P {unP :: [a] - ,stP :: M} - deriving (Eq,Show) - --- | A variant of 'pappend' that preserves the continuation mode but --- is strict in the right argument. -pappend' :: P a -> P a -> P a -pappend' (P xs _) (P ys st) = P (xs ++ ys) st - --- | 'Data.Monoid.mappend' variant to sequence two patterns. --- --- Note that in order for 'Data.Monoid.mappend' to be productive in --- 'Data.Monoid.mconcat' on an infinite list it cannot store the --- right-hand stop/continue mode, see 'pappend'' --- --- > toP [1,2] `pappend` toP [2,3] == toP [1,2,2,3] --- > ptake 3 (prepeat 3 `pappend` prepeat 4) == toP' [3,3,3] --- > ptake 3 (pconcat (cycle [prepeat 3])) == toP' [3,3,3] --- > pempty `pappend` pempty == pempty -pappend :: P a -> P a -> P a -pappend p q = fromList (unP p ++ unP q) - -instance Monoid (P a) where - mappend = pappend - mempty = P [] Continue - --- | A '>>=' variant using the continuation maintaining 'pappend'' function. -(>>=*) ::P a -> (a -> P b) -> P b -m >>=* k = F.foldr (pappend' . k) mempty m - -instance Monad P where - m >>= k = F.foldr (mappend . k) mempty m - return x = P [x] Continue - -instance Functor P where - fmap f (P xs st) = P (map f xs) st - -instance F.Foldable P where - foldr f i (P xs _) = L.foldr f i xs - -instance Applicative P where - pure x = P [x] Continue - f <*> e = fmap (\(f',e') -> f' e') (pzip f e) - -instance Traversable P where - traverse f (P xs st) = pure P <*> traverse f xs <*> pure st - -instance (Num a) => Num (P a) where - (+) = pzipWith (+) - (-) = pzipWith (-) - (*) = pzipWith (*) - abs = fmap abs - signum = fmap signum - fromInteger = return . fromInteger - negate = fmap negate - -instance (Fractional a) => Fractional (P a) where - (/) = pzipWith (/) - recip = fmap recip - fromRational = return . fromRational - -instance (OrdE a) => OrdE (P a) where - (>*) = pzipWith (>*) - (>=*) = pzipWith (>=*) - (<*) = pzipWith (<*) - (<=*) = pzipWith (<=*) - --- | Pseudo-/infinite/ value for use at repeat counts. -inf :: Int -inf = maxBound - --- | Constant /NaN/ (not a number) value for use as a rest indicator --- at a frequency model input (not at a @rest@ key). -nan :: (Monad m,Floating a) => m a -nan = return (sqrt (-1)) - --- * Extension - --- | Join a set of 'M' values, if any are 'Stop' then 'Stop' else --- 'Continue'. -stP_join :: [M] -> M -stP_join m = if Stop `elem` m then Stop else Continue - --- | Extension of a set of patterns. If any patterns are stopping, --- the longest such pattern, else the longest of the continuing --- patterns. --- --- > pextension [toP [1,2],toP [3,4,5]] == [(),(),()] --- > pextension [toP' [1,2],toP [3,4,5]] == [(),()] -pextension :: [P a] -> [()] -pextension x = - let x' = filter ((== Stop) . stP) x - in C.extension (map F.toList (if null x' then x else x')) - --- | Extend a set of patterns following 'pextension' rule. --- --- > pextend [toP [1,2],toP [3,4,5]] == [toP' [1,2,1],toP' [3,4,5]] --- --- > pextend [toP' [1,2],toP [3,4,5]] == [toP' [1,2],toP' [3,4]] -pextend :: [P a] -> [P a] -pextend l = - let f = pzipWith (\_ x -> x) (P (pextension l) Stop) . pcycle - in map f l - --- | Variant of 'transpose'. --- --- > ptranspose [toP [1,2],toP [3,4,5]] == toP [[1,3],[2,4],[5]] -ptranspose :: [P a] -> P [a] -ptranspose l = - let d = L.transpose (map unP l) - s = stP_join (map stP l) - in P d s - --- | Variant of 'pflop'. --- --- > pflop' [toP [1,2],toP [3,4,5]] == toP' [[1,3],[2,4],[1,5]] -pflop' :: [P a] -> P [a] -pflop' l = - let l' = map pcycle l - in pzipWith (\_ x -> x) (P (pextension l) Stop) (ptranspose l') - --- | Variant of 'ptranspose' transforming the input patterns by --- 'pextension'. --- --- > pflop [toP [1,2],toP [3,4,5]] == toP' (map toP [[1,3],[2,4],[1,5]]) -pflop :: [P a] -> P (P a) -pflop = fmap fromList . pflop' - --- | Composition of 'pjoin' and 'pflop'. -pflopJoin :: [P a] -> P a -pflopJoin = pjoin . pflop - --- * P lifting - --- | Lift unary list function to 'P'. -liftP :: ([a] -> [b]) -> P a -> P b -liftP f (P xs st) = P (f xs) st - --- | Lift binary list function to 'P'. -liftP2 :: ([a] -> [b] -> [c]) -> P a -> P b -> P c -liftP2 f p q = - let P l st = pzip p q - (a,b) = unzip l - in P (f a b) st - --- | Lift ternary list function to 'P'. -liftP3 :: ([a] -> [b] -> [c] -> [d]) -> P a -> P b -> P c -> P d -liftP3 f p q r = - let P l st = pzip3 p q r - (a,b,c) = unzip3 l - in P (f a b c) st - --- | Lift quaternary list function to 'P'. -liftP4 :: ([a] -> [b] -> [c] -> [d] -> [e]) -> P a -> P b -> P c -> P d -> P e -liftP4 f p q r s = - let P l st = pzip4 p q r s - (a,b,c,d) = L.unzip4 l - in P (f a b c d) st - --- * P functions - --- | Variant of 'null'. -pnull :: P a -> Bool -pnull = null . F.toList - --- | Select 'M' according to repeat count, see 'inf'. -stp :: Int -> M -stp n = if n == inf then Continue else Stop - --- | Set pattern mode to 'Stop'. -stopping :: P a -> P a -stopping (P xs _) = P xs Stop - --- | Set pattern mode according to repeat count, see 'inf'. -stoppingN :: Int -> P a -> P a -stoppingN n (P xs _) = P xs (stp n) - --- | Set pattern mode to 'Continue'. -continuing :: P a -> P a -continuing (P xs _) = P xs Continue - --- | The basic list to pattern function. The pattern is continuing. --- --- > continuing (pseq [1,2,3] 1) == toP [1,2,3] -fromList :: [a] -> P a -fromList xs = P xs Continue - --- | Alias for 'fromList'. -toP :: [a] -> P a -toP = fromList - --- | A variant from 'fromList' to make stopping patterns. --- --- > pseq [1,2,3] 1 == toP' [1,2,3] -fromList' :: [a] -> P a -fromList' xs = P xs Stop - --- | Alias for 'fromList''. -toP' :: [a] -> P a -toP' = fromList' - --- | Pattern variant of 'repeat'. See also 'pure' and 'pcycle'. --- --- > ptake 5 (prepeat 3) == toP' [3,3,3,3,3] --- > ptake 5 (Control.Applicative.pure 3) == toP' [3] --- > take 5 (Control.Applicative.pure 3) == [3] -prepeat :: a -> P a -prepeat = fromList . repeat - --- | Pattern variant of 'zipWith'. Note that 'zipWith' is truncating, --- whereas the numerical instances are extending. --- --- > zipWith (*) [1,2,3] [5,6] == [5,12] --- > pzipWith (*) (toP [1,2,3]) (toP [5,6]) == toP [5,12,15] --- > toP [1,2,3] * toP [5,6] == toP [5,12,15] --- --- Note that the list instance of applicative is combinatorial --- (ie. Monadic). --- --- > (pure (*) <*> [1,2,3] <*> [5,6]) == [5,6,10,12,15,18] --- > (pure (*) <*> toP [1,2] <*> toP [5]) == toP [5,10] -pzipWith :: (a -> b -> c) -> P a -> P b -> P c -pzipWith f p q = - let u = void - x = pextension [u p,u q] - c = cycle . unP - l = zipWith3 (\_ i j -> f i j) x (c p) (c q) - in P l (stP_join [stP p,stP q]) - --- | Pattern variant of 'zipWith3'. -pzipWith3 :: (a -> b -> c -> d) -> P a -> P b -> P c -> P d -pzipWith3 f p q r = - let u = void - x = pextension [u p,u q,u r] - c = cycle . unP - z = L.zipWith4 (\_ i j k -> f i j k) x (c p) (c q) (c r) - in P z (stP_join [stP p,stP q,stP r]) - --- | Pattern variant of 'zipWith4'. -pzipWith4 :: (a -> b -> c -> d -> e) -> P a -> P b -> P c -> P d -> P e -pzipWith4 f p q r s = - let u = void - x = pextension [u p,u q,u r,u s] - c = cycle . unP - z = L.zipWith5 (\_ i j k l -> f i j k l) x (c p) (c q) (c r) (c s) - in P z (stP_join [stP p,stP q,stP r,stP s]) - --- | Pattern variant of 'zip'. --- --- > ptake 2 (pzip (prepeat 3) (prepeat 4)) == toP' [(3,4),(3,4)] --- --- Note that haskell 'zip' is truncating wheras 'pzip' is extending. --- --- > zip [1 .. 2] [0] == [(1,0)] --- > pzip (toP [1..2]) (toP [0]) == toP [(1,0),(2,0)] -pzip :: P a -> P b -> P (a,b) -pzip = pzipWith (,) - --- | Pattern variant of 'zip3'. -pzip3 :: P a -> P b -> P c -> P (a,b,c) -pzip3 = pzipWith3 (,,) - --- | Tupling variant of 'pzipWith4'. -pzip4 :: P a -> P b -> P c -> P d -> P (a,b,c,d) -pzip4 = pzipWith4 (,,,) - --- | Pattern variant on 'unzip'. -punzip :: P (a,b) -> (P a,P b) -punzip (P p st) = let (i,j) = unzip p in (P i st,P j st) - --- * SC3 patterns - --- | Add a value to an existing key, or set the key if it doesn't exist. --- --- > Padd(\freq,801,Pbind(\freq,100)).asStream.next(()) --- > padd "freq" 801 (pbind [("freq",100)]) == pbind [("freq",901)] -padd :: E.Key -> P E.Value -> P E.Event -> P E.Event -padd k = pzipWith (\i j -> E.edit_v k 0 (+ i) j) - --- | A primitive form of the SC3 'pbind' pattern, with explicit type --- and identifier inputs. -pbind' :: [E.Type] -> [Maybe Int] -> [Maybe I.Instrument] -> [(E.Key,P E.Value)] -> P E.Event -pbind' ty is ss xs = - let xs' = pflop' (fmap (\(k,v) -> pzip (return k) v) xs) - p = fromList - in pure E.from_list <*> p ty <*> p is <*> p ss <*> xs' - --- | SC3 pattern to assign keys to a set of value patterns making an --- 'E.Event' pattern. A finite binding stops the 'E.Event' pattern. --- --- > Pbind(\x,Pseq([1,2,3]), --- > \y,Prand([100,300,200],inf)).asStream.nextN(3,()) --- --- > pkey "x" (pbind [("x",prand 'α' [100,300,200] inf) --- > ,("y",pseq [1,2,3] 1)]) == toP' [200,200,300] -pbind :: [(E.Key,P E.Value)] -> P E.Event -pbind = - let ty = repeat E.E_s_new - i = repeat Nothing - s = repeat Nothing - in pbind' ty i s - --- | A variant of 'pbrown' where the l, r and s inputs are patterns. --- --- > pbrown' 'α' 1 700 (pseq [1,20] inf) 4 == toP' [415,419,420,428] -pbrown' :: (Enum e,Random n,Num n,Ord n) => e -> P n -> P n -> P n -> Int -> P n -pbrown' e l r s n = let f = liftP3 (brown' e) in ptake n (f l r s) - --- | SC3 pattern to generate psuedo-brownian motion. --- --- > pbrown 'α' 0 9 1 5 == toP' [4,4,5,4,3] -pbrown :: (Enum e,Random n,Num n,Ord n) => e -> n -> n -> n -> Int -> P n -pbrown e l r s n = ptake n (fromList (brown e l r s)) - --- | SC3 sample and hold pattern. For true values in the control --- pattern, step the value pattern, else hold the previous value. --- --- > Pclutch(Pser([1,2,3,4,5],8), --- > Pseq([1,0,1,0,0,0,1,1],inf)).asStream.all --- --- > let {c = pbool (pseq [1,0,1,0,0,1,1] 1) --- > ;r = toP' [1,1,2,2,2,3,4,5,5,1,1,1,2,3]} --- > in pclutch (pser [1,2,3,4,5] 8) c == r --- --- Note the initialization behavior, nothing is generated until the --- first true value. --- --- > let {p = pseq [1,2,3,4,5] 1 --- > ;q = pbool (pseq [0,0,0,0,0,0,1,0,0,1,0,1] 1)} --- > in pclutch p q -pclutch :: P a -> P Bool -> P a -pclutch p q = - let r = fmap (+ 1) (pcountpost q) - in pstutter r p - --- | SC3 name for 'fmap', ie. patterns are functors. --- --- > Pcollect({arg i;i * 3},Pseq(#[1,2,3],inf)).asStream.nextN(9) --- > pcollect (* 3) (toP [1,2,3]) == toP [3,6,9] --- --- > Pseq(#[1,2,3],3).collect({arg i;i * 3}).asStream.nextN(9) --- > fmap (* 3) (toP [1,2,3]) == toP [3,6,9] -pcollect :: (a -> b) -> P a -> P b -pcollect = fmap - --- | SC3 pattern to constrain the sum of a numerical pattern. Is --- equal to /p/ until the accumulated sum is within /t/ of /n/. At --- that point, the difference between the specified sum and the --- accumulated sum concludes the pattern. --- --- > Pconst(10,Prand([1,2,0.5,0.1],inf),0.001).asStream.nextN(15,()) --- --- > let p = pconst 10 (prand 'α' [1,2,0.5,0.1] inf) 0.001 --- > in (p,Data.Foldable.sum p) -pconst :: (Ord a,Num a) => a -> P a -> a -> P a -pconst n p t = - let f _ [] = [] - f j (i:is) = if i + j < n - t - then i : f (j + i) is - else [n - j] - in stopping (fromList (f 0 (unP p))) - --- | SC3 pattern to derive notes from an index into a scale. --- --- > let {p = pseq [0,1,2,3,4,3,2,1,0,2,4,7,4,2] 2 --- > ;q = return [0,2,4,5,7,9,11] --- > ;r = [0,2,4,5,7,5,4,2,0,4,7,12,7,4,0,2,4,5,7,5,4,2,0,4,7,12,7,4]} --- > in pdegreeToKey p q (return 12) == toP' r --- --- > let {p = pseq [0,1,2,3,4,3,2,1,0,2,4,7,4,2] 2 --- > ;q = pseq (map return [[0,2,4,5,7,9,11],[0,2,3,5,7,8,11]]) 1 --- > ;r = [0,2,4,5,7,5,4,2,0,4,7,12,7,4,0,2,3,5,7,5,3,2,0,3,7,12,7,3]} --- > in pdegreeToKey p (pstutter 14 q) (return 12) == toP' r --- --- This is the pattern variant of 'P.degree_to_key'. --- --- > let s = [0,2,4,5,7,9,11] --- > in map (P.degree_to_key s 12) [0,2,4,7,4,2,0] == [0,4,7,12,7,4,0] -pdegreeToKey :: (RealFrac a) => P a -> P [a] -> P a -> P a -pdegreeToKey = pzipWith3 (\i j k -> P.degree_to_key j k i) - --- | SC3 pattern to calculate adjacent element difference. --- --- > pdiff (toP [0,2,3,5,6,8,9]) == toP [-2,-1,-2,-1,-2,-1,7] -pdiff :: Num n => P n -> P n -pdiff p = p - ptail p - --- | SC3 pattern to partition a value into /n/ equal subdivisions. --- Subdivides each duration by each stutter and yields that value --- stutter times. A stutter of @0@ will skip the duration value, a --- stutter of @1@ yields the duration value unaffected. --- --- > s = Pseq(#[1,1,1,1,1,2,2,2,2,2,0,1,3,4,0],inf); --- > d = Pseq(#[0.5,1,2,0.25,0.25],inf); --- > PdurStutter(s,d).asStream.nextN(24) --- --- > let {s = pseq [1,1,1,1,1,2,2,2,2,2,0,1,3,4,0] inf --- > ;d = pseq [0.5,1,2,0.25,0.25] inf} --- > in ptake 24 (pdurStutter s d) -pdurStutter :: Fractional a => P Int -> P a -> P a -pdurStutter = liftP2 durStutter - --- | Edit 'E.Value' at 'E.Key' in each element of an 'E.Event' pattern. -pedit :: E.Key -> (E.Value -> E.Value) -> P E.Event -> P E.Event -pedit k f = fmap (E.edit k f) - --- | An SC3 pattern of random values that follow a exponential --- distribution. --- --- > Pexprand(0.0001,1,10).asStream.all --- > pexprand 'α' 0.0001 1 10 -pexprand :: (Enum e,Random a,Floating a) => e -> a -> a -> Int -> P a -pexprand e l r n = fmap (M.exprandrng l r) (pwhite e 0 1 n) - --- | SC3 pattern to take the first n elements of the pattern. See --- also 'ptake'. --- --- > Pfinval(5,Pseq(#[1,2,3],inf)).asStream.nextN(5) --- > pfinval 5 (pseq [1,2,3] inf) == toP' [1,2,3,1,2] -pfinval :: Int -> P a -> P a -pfinval = ptake - --- | SC3 pattern to fold values to lie within range (as opposed to --- wrap and clip). This is /not/ related to the 'Data.Foldable' --- pattern instance. --- --- > pfold (toP [10,11,12,-6,-7,-8]) (-7) 11 == toP [10,11,10,-6,-7,-6] --- --- The underlying primitive is the 'fold_' function. --- --- > let f n = fold_ n (-7) 11 --- > in map f [10,11,12,-6,-7,-8] == [10,11,10,-6,-7,-6] -pfold :: (RealFrac n) => P n -> n -> n -> P n -pfold p i j = fmap (\n -> fold_ n i j) p - --- | Underlying form of haskell 'pfuncn' pattern. -pfuncn' :: (RandomGen g) => g -> (g -> (n,g)) -> Int -> P n -pfuncn' g_ f n = - let go [] _ = [] - go (h:hs) g = let (r,g') = h g in r : go hs g' - in P (go (replicate n f) g_) (stp n) - --- | A variant of the SC3 pattern that evaluates a closure at each --- step. The haskell variant function has a 'StdGen' form. -pfuncn :: (Enum e) => e -> (StdGen -> (n,StdGen)) -> Int -> P n -pfuncn e = pfuncn' (mkStdGen (fromEnum e)) - --- | SC3 geometric series pattern. --- --- > Pgeom(3,6,5).asStream.nextN(5) --- > pgeom 3 6 5 == toP' [3,18,108,648,3888] --- > pgeom 1 2 10 == toP' [1,2,4,8,16,32,64,128,256,512] --- --- Real numbers work as well. --- --- > pgeom 1.0 1.1 6 -pgeom :: (Num a) => a -> a -> Int -> P a -pgeom i s n = P (C.geom n i s) Stop - --- | SC3 pattern-based conditional expression. --- --- > var a = Pfunc({0.3.coin}); --- > var b = Pwhite(0,9,in); --- > var c = Pwhite(10,19,inf); --- > Pif(a,b,c).asStream.nextN(9) --- --- > let {a = fmap (< 0.3) (pwhite 'α' 0.0 1.0 inf) --- > ;b = pwhite 'β' 0 9 inf --- > ;c = pwhite 'γ' 10 19 inf} --- > in ptake 9 (pif a b c) == toP' [11,3,6,11,11,15,17,4,7] -pif :: P Bool -> P a -> P a -> P a -pif = liftP3 ifExtending - --- | Pattern to assign 'I.Instrument's to 'E.Event's. An --- 'I.Instrument' is either a 'Synthdef' or a 'String'. In the --- 'Synthdef' case the instrument is asynchronously sent to the server --- before processing the event, which has timing implications. In --- general the instrument pattern ought to have a 'Synthdef' for the --- first occurence of the instrument, and a 'String' for subsequent --- occurences. -pinstr :: P I.Instrument -> P E.Event -> P E.Event -pinstr = pzipWith (\i e -> e {E.e_instrument = Just i}) - --- | Variant of 'pinstr' which lifts the 'String' pattern to an --- 'I.Instrument' pattern. -pinstr_s :: P (String,Bool) -> P E.Event -> P E.Event -pinstr_s p = pinstr (fmap (uncurry I.InstrumentName) p) - --- | Variant of 'pinstr' which lifts the 'Synthdef' pattern to an --- 'I.Instrument' pattern. -pinstr_d :: P (Synthdef,Bool) -> P E.Event -> P E.Event -pinstr_d p = pinstr (fmap (uncurry I.InstrumentDef) p) - --- | Pattern to extract 'E.Value's at 'E.Key' from an 'E.Event' --- pattern. --- --- > pkey_m "freq" (pbind [("freq",440)]) == toP' [Just 440] -pkey_m :: E.Key -> P E.Event -> P (Maybe E.Value) -pkey_m k = fmap (E.lookup_m k) - --- | SC3 pattern to read 'E.Value' of 'E.Key' at 'E.Event' pattern. --- Note however that in haskell is usually more appropriate to name --- the pattern using /let/. --- --- > pkey "freq" (pbind [("freq",440)]) == toP' [440] --- > pkey "amp" (pbind [("amp",toP [0,1])]) == toP' [0,1] -pkey :: E.Key -> P E.Event -> P E.Value -pkey k = fmap (fromJust . E.lookup_m k) - --- | SC3 interlaced embedding of subarrays. --- --- > Place([0,[1,2],[3,4,5]],3).asStream.all --- > place [[0],[1,2],[3,4,5]] 3 == toP' [0,1,3,0,2,4,0,1,5] --- --- > Place(#[1,[2,5],[3,6]],2).asStream.nextN(6) --- > place [[1],[2,5],[3,6]] 2 == toP' [1,2,3,1,5,6] --- > place [[1],[2,5],[3,6..]] 4 == toP' [1,2,3,1,5,6,1,2,9,1,5,12] -place :: [[a]] -> Int -> P a -place a n = - let i = length a - f = if n == inf then id else take (n * i) - in stoppingN n (fromList (f (L.concat (C.flop a)))) - --- | SC3 pattern that is a variant of 'pbind' for controlling --- monophonic (persistent) synthesiser nodes. -pmono :: I.Instrument -> Int -> [(E.Key,P E.Value)] -> P E.Event -pmono i k = - let i' = case i of - I.InstrumentDef d sr -> - let nm = synthdefName d - in i : repeat (I.InstrumentName nm sr) - I.InstrumentName _ _ -> repeat i - ty = E.E_s_new : repeat E.E_n_set - in pbind' ty (repeat (Just k)) (map Just i') - --- | Variant of 'pmono' that lifts 'Synthdef' to 'I.Instrument'. -pmono_d :: Synthdef -> Int -> [(E.Key,P E.Value)] -> P E.Event -pmono_d = pmono . flip I.InstrumentDef False - --- | Variant of 'pmono' that lifts 'String' to 'I.Instrument'. -pmono_s :: String -> Int -> [(E.Key,P E.Value)] -> P E.Event -pmono_s = pmono . flip I.InstrumentName False - --- | Idiom to scale 'E.Value' at 'E.Key' in an 'E.Event' pattern. -pmul :: E.Key -> P E.Value -> P E.Event -> P E.Event -pmul k = pzipWith (\i j -> E.edit_v k 1 (* i) j) - --- | Variant that does not insert key. -pmul' :: E.Key -> P E.Value -> P E.Event -> P E.Event -pmul' k = pzipWith (\i j -> E.edit k (* i) j) - --- | SC3 pattern to lace input patterns. Note that the current --- implementation stops late, it cycles the second series one place. --- --- > ppatlace [1,prand 'α' [2,3] inf] 5 == toP' [1,3,1,2,1,3,1,2,1,2] -ppatlace :: [P a] -> Int -> P a -ppatlace a n = - let i = length a - f = if n == inf then id else take (n * i) - in stoppingN n (P (f (L.concat (C.flop (map unP a)))) Continue) - --- | SC3 pattern to repeats the enclosed pattern a number of times. --- --- > pn 1 4 == toP' [1,1,1,1] --- > pn (toP [1,2,3]) 3 == toP' [1,2,3,1,2,3,1,2,3] --- --- This is related to `concat`.`replicate` in standard list processing. --- --- > concat (replicate 4 [1]) == [1,1,1,1] --- > concat (replicate 3 [1,2,3]) == [1,2,3,1,2,3,1,2,3] --- --- There is a `pconcatReplicate` near-alias (reversed argument order). --- --- > pconcatReplicate 4 1 == toP' [1,1,1,1] --- > pconcatReplicate 3 (toP [1,2]) == toP' [1,2,1,2,1,2] --- --- This is productive over infinite lists. --- --- > concat (replicate inf [1]) --- > pconcat (replicate inf 1) --- > pconcatReplicate inf 1 -pn :: P a -> Int -> P a -pn = flip pconcatReplicate - --- | Pattern variant of 'C.normalizeSum'. -pnormalizeSum :: Fractional n => P n -> P n -pnormalizeSum = liftP C.normalizeSum - --- | Un-joined variant of 'prand'. -prand' :: Enum e => e -> [P a] -> Int -> P (P a) -prand' e a n = P (rand' e a n) (stp n) - --- | SC3 pattern to make n random selections from a list of patterns, --- the resulting pattern is flattened (joined). --- --- > Prand([1,Pseq([10,20,30]),2,3,4,5],6).asStream.all --- > prand 'α' [1,toP [10,20],2,3,4,5] 4 == toP' [5,2,10,20,2] -prand :: Enum e => e -> [P a] -> Int -> P a -prand e a = pjoin' . prand' e a - --- | SC3 pattern to rejects values for which the predicate is true. reject --- f is equal to filter (not . f). --- --- > preject (== 1) (pseq [1,2,3] 2) == toP' [2,3,2,3] --- > pfilter (not . (== 1)) (pseq [1,2,3] 2) == toP' [2,3,2,3] --- --- > Pwhite(0,255,20).reject({|x| x.odd}).asStream.all --- > preject odd (pwhite 'α' 0 255 10) == toP [32,158,62,216,240,20] --- --- > Pwhite(0,255,20).select({|x| x.odd}).asStream.all --- > pselect odd (pwhite 'α' 0 255 10) == toP [241,187,119,127] -preject :: (a -> Bool) -> P a -> P a -preject f = liftP (filter (not . f)) - --- | Underlying pattern for 'prorate'. -prorate' :: Num a => Either a [a] -> a -> P a -prorate' p = - case p of - Left p' -> fromList . rorate_n' p' - Right p' -> fromList . rorate_l' p' - --- | SC3 sub-dividing pattern. --- --- > Prorate(Pseq([0.35,0.5,0.8]),1).asStream.nextN(6) --- > prorate (fmap Left (pseq [0.35,0.5,0.8] 1)) 1 --- --- > Prorate(Pseq([0.35,0.5,0.8]),Prand([20,1],inf)).asStream.nextN(6) --- > prorate (fmap Left (pseq [0.35,0.5,0.8] 1)) (prand 'α' [20,1] 3) --- --- > var l = [[1,2],[5,7],[4,8,9]]).collect(_.normalizeSum); --- > Prorate(Pseq(l,1).asStream.nextN(8) --- --- > let l = map (Right . C.normalizeSum) [[1,2],[5,7],[4,8,9]] --- > in prorate (toP l) 1 -prorate :: Num a => P (Either a [a]) -> P a -> P a -prorate p = join . pzipWith prorate' p - --- | See 'pfilter'. --- --- > pselect (< 3) (pseq [1,2,3] 2) == toP' [1,2,1,2] -pselect :: (a -> Bool) -> P a -> P a -pselect f = liftP (filter f) - --- | Variant of `pseq` that retrieves only one value from each pattern --- on each list traversal. Compare to `pswitch1`. --- --- > pseq [pseq [1,2] 1,pseq [3,4] 1] 2 == toP' [1,2,3,4,1,2,3,4] --- > pseq1 [pseq [1,2] 1,pseq [3,4] 1] 2 == toP' [1,3,2,4] --- > pseq1 [pseq [1,2] inf,pseq [3,4] inf] 3 == toP' [1,3,2,4,1,3] -pseq1 :: [P a] -> Int -> P a -pseq1 a i = pjoin' (ptake i (pflop a)) - --- | SC3 pattern to cycle over a list of patterns. The repeats pattern --- gives the number of times to repeat the entire list. --- --- > pseq [return 1,return 2,return 3] 2 == toP' [1,2,3,1,2,3] --- > pseq [1,2,3] 2 == toP' [1,2,3,1,2,3] --- > pseq [1,pn 2 2,3] 2 == toP' [1,2,2,3,1,2,2,3] --- --- There is an 'inf' value for the repeats variable. --- --- > ptake 3 (pdrop 1000000 (pseq [1,2,3] inf)) == toP' [2,3,1] -pseq :: [P a] -> Int -> P a -pseq a i = stoppingN i (pn (pconcat a) i) - --- | A variant of 'pseq' that passes a new seed at each invocation, --- see also 'pfuncn'. -pseqr :: (Int -> [P a]) -> Int -> P a -pseqr f n = pconcat (L.concatMap f [1 .. n]) - --- | A variant of 'pseq' to aid translating a common SC3 idiom where a --- finite random pattern is included in a @Pseq@ list. In the SC3 --- case, at each iteration a new computation is run. This idiom does --- not directly translate to the declarative haskell pattern library. --- --- > Pseq([1,Prand([2,3],1)],5).asStream.all --- > pseq [1,prand 'α' [2,3] 1] 5 --- --- Although the intended pattern can usually be expressed using an --- alternate construction: --- --- > Pseq([1,Prand([2,3],1)],5).asStream.all --- > ppatlace [1,prand 'α' [2,3] inf] 5 == toP' [1,3,1,2,1,3,1,2,1,2] --- --- the 'pseqn' variant handles many common cases. --- --- > Pseq([Pn(8,2),Pwhite(9,16,1)],5).asStream.all --- > pseqn [2,1] [8,pwhite 'α' 9 16 inf] 5 -pseqn :: [Int] -> [P a] -> Int -> P a -pseqn n q = - let go _ 0 = pempty - go p c = let (i,j) = unzip (zipWith psplitAt n p) - in pconcat i `pappend` go j (c - 1) - in go (map pcycle q) - --- | Variant of 'pser' that consumes sub-patterns one element per --- iteration. --- --- > pser1 [1,pser [10,20] 3,3] 9 == toP' [1,10,3,1,20,3,1,10,3] -pser1 :: [P a] -> Int -> P a -pser1 a i = ptake i (pflopJoin a) - --- | SC3 pattern that is like 'pseq', however the repeats variable --- gives the number of elements in the sequence, not the number of --- cycles of the pattern. --- --- > pser [1,2,3] 5 == toP' [1,2,3,1,2] --- > pser [1,pser [10,20] 3,3] 9 == toP' [1,10,20,10,3,1,10,20,10] --- > pser [1,2,3] 5 * 3 == toP' [3,6,9,3,6] -pser :: [P a] -> Int -> P a -pser a i = ptake i (pcycle (pconcat a)) - --- | SC3 arithmetric series pattern, see also 'pgeom'. --- --- > pseries 0 2 10 == toP' [0,2,4,6,8,10,12,14,16,18] --- > pseries 9 (-1) 10 == toP' [9,8 .. 0] --- > pseries 1.0 0.2 3 == toP' [1.0,1.2,1.4] -pseries :: (Num a) => a -> a -> Int -> P a -pseries i s n = P (C.series n i s) (stp n) - --- | SC3 pattern to return @n@ repetitions of a shuffled sequence. --- --- > Pshuf([1,2,3,4],2).asStream.all --- > pshuf 'α' [1,2,3,4] 2 == toP' [2,4,3,1,2,4,3,1] -pshuf :: Enum e => e -> [a] -> Int -> P a -pshuf e a = - let (a',_) = R.scramble a (mkStdGen (fromEnum e)) - in pn (P a' Continue) - - --- | SC3 pattern to slide over a list of values. --- --- > Pslide([1,2,3,4],inf,3,1,0).asStream.all --- > pslide [1,2,3,4] 4 3 1 0 True == toP' [1,2,3,2,3,4,3,4,1,4,1,2] --- > pslide [1,2,3,4,5] 3 3 (-1) 0 True == toP' [1,2,3,5,1,2,4,5,1] -pslide :: [a] -> Int -> Int -> Int -> Int -> Bool -> P a -pslide a n j s i = stoppingN n . fromList . slide a n j s i - --- | Pattern variant of 'splitAt'. -psplitAt :: Int -> P a -> (P a,P a) -psplitAt n (P p st) = let (i,j) = splitAt n p in (P i st,P j st) - --- | Pattern variant of 'S.splitPlaces'. -psplitPlaces' :: P Int -> P a -> P [a] -psplitPlaces' = liftP2 S.splitPlaces - --- | A variant of 'psplitPlaces'' that joins the output pattern. -psplitPlaces :: P Int -> P a -> P (P a) -psplitPlaces n = fmap fromList . psplitPlaces' n - --- | SC3 pattern to do time stretching. It is equal to 'pmul' at --- \"stretch\". -pstretch :: P E.Value -> P E.Event -> P E.Event -pstretch = pmul "stretch" - --- | SC3 pattern to repeat each element of a pattern _n_ times. --- --- > pstutter 2 (toP [1,2,3]) == toP [1,1,2,2,3,3] --- --- The count input may be a pattern. --- --- > let {p = pseq [1,2] inf --- > ;q = pseq [1,2,3] 2} --- > in pstutter p q == toP' [1,2,2,3,1,1,2,3,3] --- --- > pstutter (toP [1,2,3]) (toP [4,5,6]) == toP [4,5,5,6,6,6] -pstutter :: P Int -> P a -> P a -pstutter = liftP2 stutterExtending - --- | SC3 pattern to select elements from a list of patterns by a --- pattern of indices. --- --- > switch l i = i >>= (l !!) --- > pswitch [pseq [1,2,3] 2,pseq [65,76] 1,800] (toP [2,2,0,1]) -pswitch :: [P a] -> P Int -> P a -pswitch l = liftP (switch (map unP l)) - --- | SC3 pattern that uses a pattern of indices to select which --- pattern to retrieve the next value from. Only one value is --- selected from each pattern. This is in comparison to 'pswitch', --- which embeds the pattern in its entirety. --- --- > Pswitch1([Pseq([1,2,3],inf), --- > Pseq([65,76],inf), --- > 8], --- > Pseq([2,2,0,1],6)).asStream.all --- --- > pswitch1 [pseq [1,2,3] inf,pseq [65,76] inf,8] (pseq [2,2,0,1] 6) -pswitch1 :: [P a] -> P Int -> P a -pswitch1 l = liftP (switch1 (map unP l)) - --- | SC3 pattern to combine a list of streams to a stream of lists. --- See also `pflop`. --- --- > Ptuple([Pseries(7,-1,8), --- > Pseq([9,7,7,7,4,4,2,2],1), --- > Pseq([4,4,4,2,2,0,0,-3],1)],1).asStream.nextN(8) --- --- > ptuple [pseries 7 (-1) 8 --- > ,pseq [9,7,7,7,4,4,2,2] 1 --- > ,pseq [4,4,4,2,2,0,0,-3] 1] 1 -ptuple :: [P a] -> Int -> P [a] -ptuple p = pseq [pflop' p] - --- | A variant of 'pwhite' where the range inputs are patterns. -pwhite' :: (Enum e,Random n) => e -> P n -> P n -> P n -pwhite' e = liftP2 (white' e) - --- | SC3 pattern to generate a uniform linear distribution in given range. --- --- > pwhite 'α' 0 9 5 == toP [3,0,1,6,6] --- --- It is important to note that this structure is not actually --- indeterminate, so that the below is zero. --- --- > let p = pwhite 'α' 0.0 1.0 3 in p - p == toP [0,0,0] -pwhite :: (Random n,Enum e) => e -> n -> n -> Int -> P n -pwhite e l r = fromList . white e l r - --- | A variant of 'pwhite' that generates integral (rounded) values. -pwhitei :: (RealFrac n,Random n,Enum e) => e -> n -> n -> Int -> P n -pwhitei e l r = fmap roundf . pwhite e l r - --- | SC3 pattern to embed values randomly chosen from a list. Returns --- one item from the list at random for each repeat, the probability --- for each item is determined by a list of weights which should sum --- to 1.0. --- --- > let w = C.normalizeSum [1,3,5] --- > in pwrand 'α' [1,2,3] w 6 == toP [3,1,2,3,3,3] --- --- Pwrand.new([1,2,Pseq([3,4],1)],[1,3,5].normalizeSum,6).asStream.nextN(6) --- --- > let w = C.normalizeSum [1,3,5] --- > in pwrand 'α' [1,2,pseq [3,4] 1] w 6 == toP [3,4,1,2,3,4] -pwrand :: Enum e => e -> [P a] -> [Double] -> Int -> P a -pwrand e a w n = P (wrand e (map unP a) w n) Continue - --- | SC3 pattern to constrain the range of output values by wrapping. --- See also 'pfold'. --- --- > Pn(Pwrap(Pgeom(200,1.07,26),200,1000.0),inf).asStream.nextN(26) --- > pwrap (pgeom 200 1.07 26) 200 1000 -pwrap :: (Ord a,Num a) => P a -> a -> a -> P a -pwrap xs l r = fmap (genericWrap l r) xs - --- | SC3 pattern that is like 'prand' but filters successive duplicates. --- --- > pxrand 'α' [1,toP [2,3],toP [4,5,6]] 15 -pxrand :: Enum e => e -> [P a] -> Int -> P a -pxrand e a n = P (xrand e (map unP a) n) Continue - --- * Monoid aliases - --- | 'pconcat' is 'Data.Monoid.mconcat'. See also 'pjoin'. --- --- > take 3 (concat (replicate maxBound [1,2])) == [1,2,1] --- > ptake 3 (pconcat (cycle [toP [1,2]])) == toP' [1,2,1] --- > ptake 3 (pconcat [pseq [1,2] 1,pseq [3,4] 1]) == toP' [1,2,3] -pconcat :: [P a] -> P a -pconcat = mconcat - --- | Pattern variant for `Data.Monoid.mempty`, ie. the empty pattern. --- --- > pempty `pappend` pempty == pempty --- > pempty `pappend` 1 == 1 `pappend` pempty -pempty :: P a -pempty = mempty - --- * Monad aliases - --- | `Control.Monad.join` pattern variant. See also `pconcat`. --- --- > take 3 (Control.Monad.join (replicate maxBound [1,2])) == [1,2,1] --- > ptake 3 (pjoin (preplicate inf (toP [1,2]))) == toP' [1,2,1] -pjoin :: P (P a) -> P a -pjoin = join - --- | Variant that maintains the continuing mode of the outer structure. -pjoin' :: P (P a) -> P a -pjoin' x = (join x) {stP = stP x} - --- * Data.List functions - --- | Pattern variant of ':'. --- --- > pcons 'α' (pn (return 'β') 2) == fromList' "αββ" -pcons :: a -> P a -> P a -pcons i (P j st) = P (i:j) st - --- | Pattern variant of `cycle`. --- --- > ptake 5 (pcycle (toP [1,2,3])) == toP' [1,2,3,1,2] --- > ptake 5 (pseq [1,2,3] inf) == toP' [1,2,3,1,2] -pcycle :: P a -> P a -pcycle = continuing . liftP cycle - --- | Pattern variant of `drop`. --- --- > Pseries(1,1,20).drop(5).asStream.nextN(15) --- --- > pdrop 5 (pseries 1 1 10) == toP' [6,7,8,9,10] --- > pdrop 1 pempty == pempty -pdrop :: Int -> P a -> P a -pdrop n = liftP (drop n) - --- | Pattern variant of `filter`. Allows values for which the --- predicate is true. Aliased to `pselect`. See also `preject`. --- --- > pfilter (< 3) (pseq [1,2,3] 2) == toP' [1,2,1,2] -pfilter :: (a -> Bool) -> P a -> P a -pfilter f = liftP (filter f) - --- | Pattern variant of `replicate`. --- --- > preplicate 4 1 == toP [1,1,1,1] --- --- Compare to `pn`: --- --- > pn 1 4 == toP' [1,1,1,1] --- > pn (toP [1,2]) 3 == toP' [1,2,1,2,1,2] --- > preplicate 4 (toP [1,2]) :: P (P Int) -preplicate :: Int -> a -> P a -preplicate n = fromList . replicate n - --- | Pattern variant of `scanl`. `scanl` is similar to `foldl`, but --- returns a list of successive reduced values from the left. --- --- > Data.Foldable.foldl (\x y -> 2 * x + y) 4 (pseq [1,2,3] 1) == 43 --- > pscanl (\x y -> 2 * x + y) 4 (pseq [1,2,3] 1) == toP' [4,9,20,43] -pscanl :: (a -> b -> a) -> a -> P b -> P a -pscanl f i = liftP (L.scanl f i) - --- | Variant of 'drop', note that 'tail' is partial --- --- > ptail (toP [1,2]) == toP [2] --- > ptail pempty == pempty -ptail :: P a -> P a -ptail = pdrop 1 - --- | Pattern variant of 'take', see also 'pfinval'. --- --- > ptake 5 (pseq [1,2,3] 2) == toP' [1,2,3,1,2] --- > ptake 5 (toP [1,2,3]) == toP' [1,2,3] --- > ptake 5 (pseq [1,2,3] inf) == toP' [1,2,3,1,2] --- > ptake 5 (pwhite 'α' 0 5 inf) == toP' [5,2,1,2,0] --- --- Note that `ptake` does not extend the input pattern, unlike `pser`. --- --- > ptake 5 (toP [1,2,3]) == toP' [1,2,3] --- > pser [1,2,3] 5 == toP' [1,2,3,1,2] -ptake :: Int -> P a -> P a -ptake n = stoppingN n . liftP (take n) - --- * Non-SC3 patterns - --- | Transforms a numerical pattern into a boolean pattern where --- values greater than zero are 'True' and zero and negative values --- 'False'. --- --- > pbool (toP [2,1,0,-1]) == toP [True,True,False,False] -pbool :: (Ord a,Num a) => P a -> P Bool -pbool = fmap (> 0) - --- | 'pconcat' '.' 'replicate', stopping after /n/ elements. -pconcatReplicate :: Int -> P a -> P a -pconcatReplicate i = stoppingN i . pconcat . replicate i - --- | Count the number of `False` values following each `True` value. --- --- > pcountpost (pbool (pseq [1,0,1,0,0,0,1,1] 1)) == toP' [1,3,0,0] -pcountpost :: P Bool -> P Int -pcountpost = liftP countpost - --- | Count the number of `False` values preceding each `True` value. --- --- > pcountpre (pbool (pseq [0,0,1,0,0,0,1,1] 1)) == toP' [2,3,0] -pcountpre :: P Bool -> P Int -pcountpre = liftP countpre - --- | Interleave elements from two patterns. If one pattern ends the --- other pattern continues until it also ends. --- --- > let {p = pseq [1,2,3] 2 --- > ;q = pseq [4,5,6,7] 1} --- > in pinterleave p q == toP' [1,4,2,5,3,6,1,7,2,4,3,5] --- --- > ptake 5 (pinterleave (pcycle 1) (pcycle 2)) == toP' [1,2,1,2,1] --- > ptake 10 (pinterleave (pwhite 'α' 1 9 inf) (pseries 10 1 5)) -pinterleave :: P a -> P a -> P a -pinterleave = liftP2 interleave - --- | Pattern to remove successive duplicates. --- --- > prsd (pstutter 2 (toP [1,2,3])) == toP [1,2,3] --- > prsd (pseq [1,2,3] 2) == toP' [1,2,3,1,2,3] -prsd :: (Eq a) => P a -> P a -prsd = liftP rsd - --- | Pattern where the 'tr' pattern determines the rate at which --- values are read from the `x` pattern. For each sucessive true --- value at 'tr' the output is a `Just e` of each succesive element at --- x. False values at 'tr' generate `Nothing` values. --- --- > let {tr = pbool (toP [0,1,0,0,1,1]) --- > ;r = [Nothing,Just 1,Nothing,Nothing,Just 2,Just 3]} --- > in ptrigger tr (toP [1,2,3]) == fromList r -ptrigger :: P Bool -> P a -> P (Maybe a) -ptrigger p q = - let r = pcountpre p - f i x = preplicate i Nothing `pappend` return (Just x) - in pjoin (pzipWith f r q) - --- * Parallel patterns - --- | Merge two 'E.Event' patterns with indicated start 'E.Time's. -ptmerge :: (E.Time,P E.Event) -> (E.Time,P E.Event) -> P E.Event -ptmerge (pt,p) (qt,q) = - fromList (E.merge (pt,F.toList p) (qt,F.toList q)) - --- | Variant of 'ptmerge' with zero start times. -pmerge :: P E.Event -> P E.Event -> P E.Event -pmerge p q = ptmerge (0,p) (0,q) - --- | Merge a set of 'E.Event' patterns each with indicated start 'E.Time'. -ptpar :: [(E.Time,P E.Event)] -> P E.Event -ptpar l = - case l of - [] -> pempty - [(_,p)] -> p - (pt,p):(qt,q):r -> ptpar ((min pt qt,ptmerge (pt,p) (qt,q)) : r) - --- | Variant of 'ptpar' with zero start times. -ppar :: [P E.Event] -> P E.Event -ppar l = ptpar (zip (repeat 0) l) - --- * Pattern audition - --- | Send 'E.Event' to @scsynth@ at 'Transport'. -e_send :: Transport m => E.Time -> Int -> E.Event -> m () -e_send t j e = - let voidM a = a >> return () - in case E.to_sc3_bundle t j e of - Just (p,q) -> do case E.instrument_def e of - Just d -> voidM (async (d_recv d)) - Nothing -> return () - sendBundle p - sendBundle q - Nothing -> return () - --- | Function to audition a sequence of 'E.Event's using the @scsynth@ --- instance at 'Transport' starting at indicated 'E.Time'. -e_tplay :: (Transport m) => E.Time -> [Int] -> [E.Event] -> m () -e_tplay t j e = - case (j,e) of - (_,[]) -> return () - ([],_) -> error "e_tplay: no-id" - (i:j',d:e') -> do let t' = t + E.fwd d - e_send t i d - pauseThreadUntil t' - e_tplay t' j' e' - --- | Variant of 'e_tplay' with current clock time from 'time' as start --- time. This function is used to implement the pattern instances of --- 'Audible'. -e_play :: (Transport m) => [Int] -> [E.Event] -> m () -e_play lj le = do - st <- time - e_tplay st lj le - -instance Audible (P E.Event) where - play = e_play [1000..] . unP - -instance Audible (Synthdef,P E.Event) where - play (s,p) = do - let i_d = I.InstrumentDef s True - i_nm = I.InstrumentName (synthdefName s) True - i = pcons i_d (pn (return i_nm) inf) - _ <- async (d_recv s) - e_play [1000..] (unP (pinstr i p)) - -instance Audible (String,P E.Event) where - play (s,p) = - let i = I.InstrumentName s True - in e_play [1000..] (unP (pinstr (return i) p)) - +-- +-- SC3 /value/ patterns: `pbrown` (Pbrown), `pclutch` (Pclutch), +-- `pcollect` (Pcollect), `pconst` (Pconst), `pdegreeToKey` +-- (PdegreeToKey), `pdiff` (Pdiff), `pdrop` (Pdrop), `pdurStutter` +-- (PdurStutter), `pexprand` (Pexprand), `pfinval` (Pfinval), `pfuncn` +-- (Pfuncn), `pgeom` (Pgeom), `pif` (Pif), `place` (Place), `pn` (Pn), +-- `ppatlace` (Ppatlace), `prand` (Prand), `preject` (Preject), +-- `prorate` (Prorate), `pselect` (Pselect), `pseq` (Pseq), `pser` +-- (Pser), `pseries` (Pseries), `pshuf` (Pshuf), `pslide` (Pslide), +-- `pstutter` (Pstutter), `pswitch1` (Pswitch1), `pswitch` (Pswitch), +-- `ptuple` (Ptuple), `pwhite` (Pwhite), `pwrand` (Pwrand), `pwrap` +-- (Pwrap), `pxrand` (Pxrand). +-- +-- SC3 /event/ patterns: `padd` (Padd), `pbind` (Pbind), `pkey` +-- (PKey), `pmono` (Pmono), `pmul` (Pmul), `ppar` (Ppar), `pstretch` +-- (Pstretch), `ptpar` (Ptpar). `pedit`, `pinstr`, `pmce2`, `psynth`, +-- `punion`. +-- +-- SC3 variant patterns: `pbrown`', `prand'`, `prorate'`, `pseq1`, +-- `pseqn`, `pser1`, `pseqr`, `pwhite'`, `pwhitei`. +-- +-- SC3 collection patterns: `pfold` +-- +-- Haskell patterns: `pappend`, `pbool`, `pconcat`, `pcons`, +-- `pcountpost`, `pcountpre`, `pcycle`, `pempty`,`pfilter`, `phold`, +-- `pinterleave`,`pjoin`, `prepeat`, `preplicate`, `prsd`, `pscanl`, +-- `psplitPlaces`, `psplitPlaces'`, `ptail`, `ptake`, `ptrigger`, +-- `pzip`, `pzipWith` +module Sound.SC3.Lang.Pattern.ID where + +import Control.Applicative hiding ((<*)) {- base -} +import Control.Monad {- base -} +import Data.Bifunctor {- bifunctors -} +import qualified Data.Foldable as F {- base -} +import qualified Data.List as L {- base -} +import qualified Data.List.Split as S {- split -} +import Data.Maybe {- base -} +import Data.Monoid {- base -} +import qualified Data.Traversable as T {- base -} +import Sound.OSC {- hsc3 -} +import Sound.SC3 {- hsc3 -} +import System.Random {- random -} + +import qualified Sound.SC3.Lang.Collection as C +import Sound.SC3.Lang.Control.Duration +import Sound.SC3.Lang.Control.Event +import Sound.SC3.Lang.Control.Instrument +import qualified Sound.SC3.Lang.Math as M +import qualified Sound.SC3.Lang.Pattern.List as P +import qualified Sound.SC3.Lang.Random.Gen as R + +-- * P + +-- | Patterns are opaque. @P a@ is a pattern with elements of type +-- @a@. Patterns are constructed, manipulated and destructured using +-- the functions provided, ie. the pattern instances for 'return', +-- 'pure' and 'F.toList', and the pattern specific functions +-- 'undecided' and 'toP'. +-- +-- > F.toList (toP [1,2,3] * 2) == [2,4,6] +-- +-- Patterns are 'Functor's. 'fmap' applies a function to each element +-- of a pattern. +-- +-- > fmap (* 2) (toP [1,2,3,4,5]) == toP [2,4,6,8,10] +-- +-- Patterns are 'Monoid's. 'mempty' is the empty pattern, and +-- 'mappend' ('<>') makes a sequence of two patterns. +-- +-- > 1 <> mempty <> 2 == toP [1,2] +-- +-- Patterns are 'Applicative'. The pattern instance is pointwise & +-- truncating, unlike the combinatorial instance for ordinary lists. +-- 'pure' lifts a value into an infinite pattern of itself, '<*>' +-- applies a pattern of functions to a pattern of values. This is +-- distinct from the list instance which is monadic, ie. 'pure' is +-- 'return' and '<*>' is 'ap'. +-- +-- > liftA2 (+) (toP [1,2]) (toP [3,4,5]) == toP [4,6] +-- > liftA2 (+) [1,2] [3,4,5] == [4,5,6,5,6,7] +-- +-- Patterns are 'Monad's, and therefore allow /do/ notation. +-- +-- > let p = do {x <- toP [1,2]; y <- toP [3,4,5]; return (x,y)} +-- > in p == toP [(1,3),(1,4),(1,5),(2,3),(2,4),(2,5)] +-- +-- Patterns are 'Num'erical. The instances can be derived from the +-- 'Applicative' instance. +-- +-- > 1 + toP [2,3,4] == liftA2 (+) 1 (toP [2,3,4]) +data P a = P {unP_either :: Either a [a]} + deriving (Eq,Show) + +-- | Lift a value to a pattern deferring deciding if the constructor +-- ought to be 'pure' or 'return' to the consuming function. The +-- pattern instances for 'fromInteger' and 'fromRational' make +-- 'undecided' patterns. In general /horizontal/ functions (ie. '<>') +-- resolve using 'return' and /vertical/ functions (ie. 'zip') resolve +-- using 'pure'. +-- +-- > 1 <> toP [2,3] == return 1 <> toP [2,3] +-- > toP [1,2] * 3 == toP [1,2] * pure 3 +undecided :: a -> P a +undecided a = P (Left a) + +-- | The basic list to pattern function, inverse is 'unP'. +-- +-- > unP (toP "str") == "str" +-- +-- > audition (pbind [(K_degree,pxrand 'α' [0,1,5,7] inf) +-- > ,(K_dur,toP [0.1,0.2,0.1])]) +-- +-- > > Pbind(\degree,(Pxrand([0,1,5,7],inf)) +-- > > ,\dur,Pseq([0.1,0.2,0.1],1)).play +-- +-- The pattern above is finite, `toP` can sometimes be replaced with +-- `pseq`. +-- +-- > audition (pbind [(K_degree,pxrand 'α' [0,1,5,7] inf) +-- > ,(K_dur,pseq [0.1,0.2,0.1] inf)]) +toP :: [a] -> P a +toP = P . Right + +-- | Type specialised 'F.toList'. 'undecided' values are singular. +-- +-- > F.toList (undecided 'a') == ['a'] +-- > unP (return 'a') == ['a'] +-- > "aaa" `L.isPrefixOf` unP (pure 'a') +unP :: P a -> [a] +unP = either return id . unP_either + +-- | Variant of 'unP' where 'undecided' values are 'repeat'ed. +-- +-- > unP_repeat (return 'a') == ['a'] +-- > take 2 (unP_repeat (undecided 'a')) == ['a','a'] +-- > take 2 (unP_repeat (pure 'a')) == ['a','a'] +unP_repeat :: P a -> [a] +unP_repeat = either repeat id . unP_either + +instance Functor P where + fmap f (P p) = P (bimap f (map f) p) + +instance Monoid (P a) where + mappend p q = toP (unP p ++ unP q) + mempty = toP [] + +instance Applicative P where + pure = toP . repeat + f <*> e = pzipWith ($) f e + +instance Alternative P where + empty = mempty + (<|>) = mappend + +instance F.Foldable P where + foldr f i p = L.foldr f i (unP p) + +instance T.Traversable P where + traverse f p = pure toP <*> T.traverse f (unP p) + +instance Monad P where + m >>= k = + case m of + P (Left e) -> k e + P (Right l) -> L.foldr (mappend . k) mempty l + return x = toP [x] + +instance MonadPlus P where + mzero = mempty + mplus = mappend + +instance (Num a) => Num (P a) where + (+) = pzipWith (+) + (-) = pzipWith (-) + (*) = pzipWith (*) + abs = fmap abs + signum = fmap signum + negate = fmap negate + fromInteger = undecided . fromInteger + +instance (Fractional a) => Fractional (P a) where + (/) = pzipWith (/) + recip = fmap recip + fromRational = undecided . fromRational + +instance (Ord a) => Ord (P a) where + (>) = error ("~> Ord>*") + (>=) = error ("~> Ord>=*") + (<) = error ("~> Ord<*") + (<=) = error ("~> Ord<=*") + +instance (OrdE a) => OrdE (P a) where + (>*) = pzipWith (>*) + (>=*) = pzipWith (>=*) + (<*) = pzipWith (<*) + (<=*) = pzipWith (<=*) + +-- * Lift P + +-- | Lift unary list function to pattern function. +liftP :: ([a] -> [b]) -> P a -> P b +liftP f = toP . f . unP + +-- | Lift binary list function to pattern function. +-- +-- > liftP2 (zipWith (+)) (toP [1,2]) (toP [3,4,5]) == toP [4,6] +-- > liftA2 (+) (toP [1,2]) (toP [3,4,5]) == toP [4,6] +liftP2 :: ([a] -> [b] -> [c]) -> P a -> P b -> P c +liftP2 f p q = + let p' = unP p + q' = unP q + in toP (f p' q') + +-- | Lift binary list function to /implicitly repeating/ pattern function. +liftP2_repeat :: ([a] -> [b] -> [c]) -> P a -> P b -> P c +liftP2_repeat f p q = + let p' = unP_repeat p + q' = unP_repeat q + in toP (f p' q') + +-- | Lift ternary list function to pattern function. +liftP3 :: ([a] -> [b] -> [c] -> [d]) -> P a -> P b -> P c -> P d +liftP3 f p q r = + let p' = unP p + q' = unP q + r' = unP r + in toP (f p' q' r') + +-- | Lift ternary list function to /implicitly repeating/ pattern function. +liftP3_repeat :: ([a] -> [b] -> [c] -> [d]) -> P a -> P b -> P c -> P d +liftP3_repeat f p q r = + let p' = unP_repeat p + q' = unP_repeat q + r' = unP_repeat r + in toP (f p' q' r') + +-- * Zip P + +-- | An /implicitly repeating/ pattern variant of 'zipWith'. +-- +-- > zipWith (*) [1,2,3] [5,6] == [5,12] +-- > pzipWith (*) (toP [1,2,3]) (toP [5,6]) == toP [5,12] +-- +-- It is the basis for lifting binary operators to patterns. +-- +-- > toP [1,2,3] * toP [5,6] == toP [5,12] +-- +-- > let p = pzipWith (,) (pseq [1,2] 2) (pseq [3,4] inf) +-- > in p == toP [(1,3),(2,4),(1,3),(2,4)] +-- +-- > zipWith (,) (return 0) (return 1) == return (0,1) +-- > pzipWith (,) 0 1 == undecided (0,1) +pzipWith :: (a -> b -> c) -> P a -> P b -> P c +pzipWith f p q = + case (p,q) of + (P (Left m),P (Left n)) -> undecided (f m n) + _ -> toP (zipWith f (unP_repeat p) (unP_repeat q)) + +-- | An /implicitly repeating/ pattern variant of 'zipWith3'. +pzipWith3 :: (a -> b -> c -> d) -> P a -> P b -> P c -> P d +pzipWith3 f p q r = + case (p,q,r) of + (P (Left m),P (Left n),P (Left o)) -> undecided (f m n o) + _ -> toP (zipWith3 f (unP_repeat p) (unP_repeat q) (unP_repeat r)) + +-- | An /implicitly repeating/ pattern variant of 'zip'. +-- +-- > zip (return 0) (return 1) == return (0,1) +-- > pzip (undecided 3) (undecided 4) == undecided (3,4) +-- > pzip 0 1 == undecided (0,1) +-- +-- Note that 'pzip' is otherwise like haskell 'zip', ie. truncating. +-- +-- > zip [1,2] [0] == [(1,0)] +-- > pzip (toP [1,2]) (return 0) == toP [(1,0)] +-- > pzip (toP [1,2]) (pure 0) == toP [(1,0),(2,0)] +-- > pzip (toP [1,2]) 0 == toP [(1,0),(2,0)] +pzip :: P a -> P b -> P (a,b) +pzip = pzipWith (,) + +-- | Pattern variant of 'zip3'. +pzip3 :: P a -> P b -> P c -> P (a,b,c) +pzip3 = pzipWith3 (,,) + +-- | Pattern variant on 'unzip'. +-- +-- > let p = punzip (pzip (toP [1,2,3]) (toP [4,5])) +-- > in p == (toP [1,2],toP [4,5]) +punzip :: P (a,b) -> (P a,P b) +punzip p = let (i,j) = unzip (unP p) in (toP i,toP j) + +-- * Math + +-- | Type specialised 'maxBound', a pseudo-/infinite/ value for use at +-- pattern repeat counts. +-- +-- > inf == maxBound +inf :: Int +inf = maxBound + +{-| Constant /NaN/ (not a number) value. + +> isNaN nan == True + +A frequency value of NaN indicates a rest. This constant value can be +used as a rest indicator at a frequency model input (not at a @rest@ +key). + +> audition (pbind [(K_dur,pseq [0.1,0.7] inf) +> ,(K_legato,0.2) +> ,(K_degree,pseq [0,2,return nan] inf)]) + +-} +nan :: Floating a => a +nan = sqrt (-1) + +-- * Data.List Patterns + +-- | Pattern variant of 'Data.List.:'. +-- +-- > pcons 'α' (pn (return 'β') 2) == toP "αββ" +pcons :: a -> P a -> P a +pcons = mappend . return + +-- | Pattern variant of 'Data.List.null'. +-- +-- > pnull mempty == True +-- > pnull (undecided 'a') == False +-- > pnull (pure 'a') == False +-- > pnull (return 'a') == False +pnull :: P a -> Bool +pnull = null . unP + +-- | Alias for 'pure', pattern variant of 'Data.List.repeat'. +-- +-- > ptake 5 (prepeat 3) == toP [3,3,3,3,3] +-- > ptake 5 (pure 3) == toP [3,3,3,3,3] +-- > take 5 (pure 3) == [3] +prepeat :: a -> P a +prepeat = pure + +-- | Pattern variant of 'splitAt'. +psplitAt :: Int -> P a -> (P a,P a) +psplitAt n p = + let (i,j) = splitAt n (unP p) + in (toP i,toP j) + +-- | Pattern variant of 'Data.List.Split.splitPlaces'. +-- +-- > psplitPlaces' (toP [1,2,3]) (pseries 1 1 6) == toP [[1],[2,3],[4,5,6]] +-- > psplitPlaces' (toP [1,2,3]) (toP ['a'..]) == toP ["a","bc","def"] +psplitPlaces' :: P Int -> P a -> P [a] +psplitPlaces' = liftP2 S.splitPlaces + +-- | 'fmap' 'toP' of 'psplitPlaces''. +-- +-- > psplitPlaces (toP [1,2,3]) (toP ['a'..]) == toP (map toP ["a","bc","def"]) +psplitPlaces :: P Int -> P a -> P (P a) +psplitPlaces n = fmap toP . psplitPlaces' n + +-- | Pattern variant of 'P.take_inf', see also 'pfinval'. +-- +-- > ptake 5 (pseq [1,2,3] 2) == toP [1,2,3,1,2] +-- > ptake 5 (toP [1,2,3]) == toP [1,2,3] +-- > ptake 5 (pseq [1,2,3] inf) == toP [1,2,3,1,2] +-- > ptake 5 (pwhite 'α' 0 5 inf) == toP [5,2,1,2,0] +-- +-- Note that `ptake` does not extend the input pattern, unlike `pser`. +-- +-- > ptake 5 (toP [1,2,3]) == toP [1,2,3] +-- > pser [1,2,3] 5 == toP [1,2,3,1,2] +ptake :: Int -> P a -> P a +ptake n = liftP (P.take_inf n) + +-- | Type specialised 'P.mcycle'. +-- +-- > ptake 5 (pcycle 1) == preplicate 5 1 +-- > ptake 5 (pcycle (pure 1)) == preplicate 5 1 +-- > ptake 5 (pcycle (return 1)) == preplicate 5 1 +pcycle :: P a -> P a +pcycle = P.mcycle + +-- | Type specialised 'mfilter'. Aliased to `pselect`. See also +-- `preject`. +-- +-- > mfilter even (pseq [1,2,3] 2) == toP [2,2] +-- > mfilter (< 3) (pseq [1,2,3] 2) == toP [1,2,1,2] +pfilter :: (a -> Bool) -> P a -> P a +pfilter = mfilter + +-- | Pattern variant of `replicate`. +-- +-- > preplicate 4 1 == toP [1,1,1,1] +-- +-- Compare to `pn`: +-- +-- > pn 1 4 == toP [1,1,1,1] +-- > pn (toP [1,2]) 3 == toP [1,2,1,2,1,2] +-- > preplicate 4 (toP [1,2]) :: P (P Int) +preplicate :: Int -> a -> P a +preplicate n = toP . (if n == inf then repeat else replicate n) + +-- | Pattern variant of `scanl`. `scanl` is similar to `foldl`, but +-- returns a list of successive reduced values from the left. pscanl +-- is an accumulator, it provides a mechanism for state to be threaded +-- through a pattern. It can be used to write a function to remove +-- succesive duplicates from a pattern, to count the distance between +-- occurences of an element in a pattern and so on. +-- +-- > F.foldl (\x y -> 2 * x + y) 4 (pseq [1,2,3] 1) == 43 +-- > pscanl (\x y -> 2 * x + y) 4 (pseq [1,2,3] 1) == toP [4,9,20,43] +-- +-- > F.foldl (flip (:)) [] (toP [1..3]) == [3,2,1] +-- > pscanl (flip (:)) [] (toP [1..3]) == toP [[],[1],[2,1],[3,2,1]] +-- +-- > F.foldl (+) 0 (toP [1..5]) == 15 +-- > pscanl (+) 0 (toP [1..5]) == toP [0,1,3,6,10,15] +pscanl :: (a -> b -> a) -> a -> P b -> P a +pscanl f i = liftP (L.scanl f i) + +-- | 'pdrop' @1@. Pattern variant of `Data.List.tail`. Drops first +-- element from pattern. Note that the haskell `tail` function is +-- partial, although `drop` is not. `ptake` is equal to `pdrop 1`. +-- +-- > tail [] == _|_ +-- > drop 1 [] == [] +-- +-- > ptail (toP [1,2]) == toP [2] +-- > ptail mempty == mempty +ptail :: P a -> P a +ptail = pdrop 1 + +-- | Variant of 'L.transpose'. +-- +-- > L.transpose [[1,2],[3,4,5]] == [[1,3],[2,4],[5]] +-- > ptranspose [toP [1,2],toP [3,4,5]] == toP [[1,3],[2,4],[5]] +-- +-- > let p = ptranspose [pseq [1,2] inf,pseq [4,5] inf] +-- > in ptake 2 (pdrop (2^16) p) == toP [[1,4],[2,5]] +ptranspose :: [P a] -> P [a] +ptranspose l = toP (L.transpose (map unP l)) + +-- | An /implicitly repeating/ pattern variant of 'P.transpose_st'. +ptranspose_st_repeat :: [P a] -> P [a] +ptranspose_st_repeat l = toP (P.transpose_st (map unP_repeat l)) + +-- * SC3 Collection Patterns + +-- | Variant of 'C.flop'. +-- +-- > pflop' [toP [1,2],toP [3,4,5]] == toP [[1,3],[2,4],[1,5]] +-- > pflop' [toP [1,2],3] == toP [[1,3],[2,3]] +-- > pflop' [pseq [1,2] 1,pseq [3,4] inf] +pflop' :: [P a] -> P [a] +pflop' l = toP (C.flop (map unP l)) + +-- | 'fmap' 'toP' of 'pflop''. +-- +-- > C.flop [[1,2],[3,4,5]] == [[1,3],[2,4],[1,5]] +-- > pflop [toP [1,2],toP [3,4,5]] == toP (map toP [[1,3],[2,4],[1,5]]) +pflop :: [P a] -> P (P a) +pflop = fmap toP . pflop' + +-- | Type specialised 'P.ffold'. +-- +-- > pfold (toP [10,11,12,-6,-7,-8]) (-7) 11 == toP [10,11,10,-6,-7,-6] +-- +-- > audition (pbind [(K_degree,pfold (pseries 4 1 inf) (-7) 11) +-- > ,(K_dur,0.0625)]) +-- +-- The underlying primitive is then `fold_` function. +-- +-- > let f = fmap (\n -> fold_ n (-7) 11) +-- > in audition (pbind [(K_degree,f (pseries 4 1 inf)) +-- > ,(K_dur,0.0625)]) +pfold :: (RealFrac n) => P n -> n -> n -> P n +pfold = P.ffold + +-- | Pattern variant of 'C.normalizeSum'. +pnormalizeSum :: Fractional n => P n -> P n +pnormalizeSum = liftP C.normalizeSum + +-- * SC3 Patterns + +{-| Pbrown. Lifted 'P.brown'. SC3 pattern to generate +psuedo-brownian motion. + +> pbrown 'α' 0 9 1 5 == toP [4,4,5,4,3] + +> audition (pbind [(K_dur,0.065) +> ,(K_freq,pbrown 'α' 440 880 20 inf)]) + +-} +pbrown :: (Enum e,Random n,Num n,Ord n) => e -> n -> n -> n -> Int -> P n +pbrown e l r s n = ptake n (toP (P.brown e l r s)) + +{-| Pclutch. SC3 sample and hold pattern. For true values in the +control pattern, step the value pattern, else hold the previous value. + +> > c = Pseq([1,0,1,0,0,1,1],inf); +> > p = Pclutch(Pser([1,2,3,4,5],8),c); +> > r = [1,1,2,2,2,3,4,5,5,1,1,1,2,3]; +> > p.asStream.all == r + +> let {c = pbool (pseq [1,0,1,0,0,1,1] inf) +> ;p = pclutch (pser [1,2,3,4,5] 8) c +> ;r = toP [1,1,2,2,2,3,4,5,5,1,1,1,2,3]} +> in p == toP [1,1,2,2,2,3,4,5,5,1,1,1,2,3] + +Note the initialization behavior, nothing is generated until the +first true value. + +> let {p = pseq [1,2,3,4,5] 1 +> ;q = pbool (pseq [0,0,0,0,0,0,1,0,0,1,0,1] 1)} +> in pclutch p q == toP [1,1,1,2,2,3] + +> > Pbind(\degree,Pstutter(Pwhite(3,10,inf),Pwhite(-4,11,inf)), +> > \dur,Pclutch(Pwhite(0.1,0.4,inf), +> > Pdiff(Pkey(\degree)).abs > 0), +> > \legato,0.3).play; + +> let {d = pstutter (pwhite 'α' 3 10 inf) (pwhitei 'β' (-4) 11 inf) +> ;p = [(K_degree,d) +> ,(K_dur,pclutch (pwhite 'γ' 0.1 0.4 inf) +> (pbool (abs (pdiff d) >* 0))) +> ,(K_legato,0.3)]} +> in audition (pbind p) + +-} +pclutch :: P a -> P Bool -> P a +pclutch p q = + let r = fmap (+ 1) (pcountpost q) + in pstutter r p + +-- | Pcollect. SC3 name for 'fmap', ie. patterns are functors. +-- +-- > > Pcollect({|i| i * 3},Pseq(#[1,2,3],1)).asStream.all == [3,6,9] +-- > pcollect (* 3) (toP [1,2,3]) == toP [3,6,9] +-- +-- > > Pseq(#[1,2,3],1).collect({|i| i * 3}).asStream.all == [3,6,9] +-- > fmap (* 3) (toP [1,2,3]) == toP [3,6,9] +pcollect :: (a -> b) -> P a -> P b +pcollect = fmap + +-- | Pconst. SC3 pattern to constrain the sum of a numerical pattern. +-- Is equal to /p/ until the accumulated sum is within /t/ of /n/. At +-- that point, the difference between the specified sum and the +-- accumulated sum concludes the pattern. +-- +-- > > p = Pconst(10,Pseed(Pn(1000,1),Prand([1,2,0.5,0.1],inf),0.001)); +-- > > p.asStream.all == [0.5,0.1,0.5,1,2,2,0.5,1,0.5,1,0.9] +-- +-- > let p = pconst 10 (prand 'α' [1,2,0.5,0.1] inf) 0.001 +-- > in (p,Data.Foldable.sum p) +-- +-- > > Pbind(\degree,Pseq([-7,Pwhite(0,11,inf)],1), +-- > > \dur,Pconst(4,Pwhite(1,4,inf) * 0.25)).play +-- +-- > let p = [(K_degree,pcons (-7) (pwhitei 'α' 0 11 inf)) +-- > ,(K_dur,pconst 4 (pwhite 'β' 1 4 inf * 0.25) 0.001)] +-- > in audition (pbind p) +pconst :: (Ord a,Num a) => a -> P a -> a -> P a +pconst n p t = + let f _ [] = [] + f j (i:is) = if i + j < n - t + then i : f (j + i) is + else [n - j] + in toP (f 0 (unP p)) + +{-| PdegreeToKey. SC3 pattern to derive notes from an index into a +scale. + +> let {p = pseq [0,1,2,3,4,3,2,1,0,2,4,7,4,2] 2 +> ;q = pure [0,2,4,5,7,9,11] +> ;r = [0,2,4,5,7,5,4,2,0,4,7,12,7,4,0,2,4,5,7,5,4,2,0,4,7,12,7,4]} +> in pdegreeToKey p q (pure 12) == toP r + +> let {p = pseq [0,1,2,3,4,3,2,1,0,2,4,7,4,2] 2 +> ;q = pseq (map return [[0,2,4,5,7,9,11],[0,2,3,5,7,8,11]]) 1 +> ;r = [0,2,4,5,7,5,4,2,0,4,7,12,7,4,0,2,3,5,7,5,3,2,0,3,7,12,7,3]} +> in pdegreeToKey p (pstutter 14 q) (pure 12) == toP r + +This is the pattern variant of 'M.degreeToKey'. + +> let s = [0,2,4,5,7,9,11] +> in map (M.degreeToKey s 12) [0,2,4,7,4,2,0] == [0,4,7,12,7,4,0] + +> > Pbind(\note,PdegreeToKey(Pseq([1,2,3,2,5,4,3,4,2,1],2), +> > #[0,2,3,6,7,9], +> > 12),\dur,0.25).play + +> let {n = pdegreeToKey (pseq [1,2,3,2,5,4,3,4,2,1] 2) +> (pure [0,2,3,6,7,9]) +> 12} +> in audition (pbind [(K_note,n),(K_dur,0.25)]) + +> > s = #[[0,2,3,6,7,9],[0,1,5,6,7,9,11],[0,2,3]]; +> > d = [1,2,3,2,5,4,3,4,2,1]; +> > Pbind(\note,PdegreeToKey(Pseq(d,4), +> > Pstutter(3,Prand(s,inf)), +> > 12),\dur,0.25).play; + +> let {s = map return [[0,2,3,6,7,9],[0,1,5,6,7,9,11],[0,2,3]] +> ;d = [1,2,3,2,5,4,3,4,2,1] +> ;k = pdegreeToKey (pseq d 4) +> (pstutter 3 (prand 'α' s 14)) +> (pn 12 40)} +> in audition (pbind [(K_note,k),(K_dur,0.25)]) + +-} +pdegreeToKey :: (RealFrac a) => P a -> P [a] -> P a -> P a +pdegreeToKey = pzipWith3 (\i j k -> M.degreeToKey j k i) + +-- | Pdiff. SC3 pattern to calculate adjacent element difference. +-- +-- > > Pdiff(Pseq([0,2,3,5,6,8,9],1)).asStream.all == [2,1,2,1,2,1] +-- > pdiff (pseq [0,2,3,5,6,8,9] 1) == toP [2,1,2,1,2,1] +pdiff :: Num n => P n -> P n +pdiff p = ptail p - p + +-- | Pdrop. Lifted 'L.drop'. +-- +-- > > p = Pseries(1,1,20).drop(5); +-- > > p.asStream.all == [6,7,8,9,10,11,12,13,14,15,16,17,18,19,20] +-- +-- > pdrop 5 (pseries 1 1 10) == toP [6,7,8,9,10] +-- > pdrop 1 mempty == mempty +pdrop :: Int -> P a -> P a +pdrop n = liftP (drop n) + +-- | PdurStutter. Lifted 'P.durStutter'. +-- +-- > > s = Pseq(#[1,1,1,1,1,2,2,2,2,2,0,1,3,4,0],inf); +-- > > d = Pseq(#[0.5,1,2,0.25,0.25],1); +-- > > PdurStutter(s,d).asStream.all == [0.5,1,2,0.25,0.25] +-- +-- > let {s = pseq [1,1,1,1,1,2,2,2,2,2,0,1,3,4,0] inf +-- > ;d = pseq [0.5,1,2,0.25,0.25] 1} +-- > in pdurStutter s d == toP [0.5,1.0,2.0,0.25,0.25] +-- +-- Applied to duration. +-- +-- > > d = PdurStutter(Pseq(#[1,1,1,1,1,2,2,2,2,2,3,3,3,3,3,4,4,4,4,4],inf), +-- > > Pseq(#[0.5,1,2,0.25,0.25],inf)); +-- > > Pbind(\freq,440,\dur,d).play +-- +-- > let {s = pseq [1,1,1,1,1,2,2,2,2,2,3,3,3,3,3,4,4,4,4,4] inf +-- > ;d = pseq [0.5,1,2,0.25,0.25] inf} +-- > in audition (pbind [(K_freq,440),(K_dur,pdurStutter s d)]) +-- +-- Applied to frequency. +-- +-- > let {s = pseq [1,1,1,1,1,2,2,2,2,2,3,3,3,3,4,4,0,4,4] inf +-- > ;d = pseq [0,2,3,5,7,9,10] inf + 80} +-- > in audition (pbind [(K_midinote,pdurStutter s d),(K_dur,0.15)]) +pdurStutter :: Fractional a => P Int -> P a -> P a +pdurStutter = liftP2 P.durStutter + +-- | Pexprand. Lifted 'P.exprand'. +-- +-- > > Pexprand(0.0001,1,10).asStream.all +-- > pexprand 'α' 0.0001 1 10 +-- +-- > > Pbind(\freq,Pexprand(0.0001,1,inf) * 600 + 300,\dur,0.02).play +-- +-- > audition (pbind [(K_freq,pexprand 'α' 0.0001 1 inf * 600 + 300) +-- > ,(K_dur,0.02)]) +pexprand :: (Enum e,Random a,Floating a) => e -> a -> a -> Int -> P a +pexprand e l r = toP . P.exprand e l r + +-- | Pfinval. Alias for 'ptake' +-- +-- > > Pfinval(5,Pseq(#[1,2,3],inf)).asStream.all == [1,2,3,1,2] +-- > pfinval 5 (pseq [1,2,3] inf) == toP [1,2,3,1,2] +pfinval :: Int -> P a -> P a +pfinval = ptake + +{-| +A variant of the SC3 pattern that evaluates a closure at each +step. The haskell variant function has a 'StdGen' form. + +> > p = Pfuncn({exprand(0.1,0.3) + #[1,2,3,6,7].choose},inf); +> > Pbind(\freq,p * 100 + 300,\dur,0.02).play + +> let {exprand = Sound.SC3.Lang.Random.Gen.exprand +> ;choose = Sound.SC3.Lang.Random.Gen.choose +> ;p = pfuncn 'α' (exprand 0.1 0.3) inf +> ;q = pfuncn 'β' (choose [1,2,3,6,7]) inf} +> in audition (pbind [(K_freq,(p + q) * 100 + 300),(K_dur,0.02)]) + +Of course in this case there is a pattern equivalent. + +> let {p = pexprand 'α' 0.1 0.3 inf + prand 'β' [1,2,3,6,7] inf} +> in audition (pbind [(K_freq,p * 100 + 300),(K_dur,0.02)]) + +-} +pfuncn :: Enum e => e -> (StdGen -> (n,StdGen)) -> Int -> P n +pfuncn e f n = toP (P.funcn e f n) + +-- | Pgeom. SC3 geometric series pattern. +-- +-- > > Pgeom(3,6,5).asStream.all == [3,18,108,648,3888] +-- > pgeom 3 6 5 == toP [3,18,108,648,3888] +-- +-- > > Pgeom(1,2,10).asStream.all == [1,2,4,8,16,32,64,128,256,512] +-- > pgeom 1 2 10 == toP [1,2,4,8,16,32,64,128,256,512] +-- +-- Real numbers work as well. +-- +-- > > p = Pgeom(1.0,1.1,6).collect({|i| (i * 100).floor}); +-- > > p.asStream.all == [100,110,121,133,146,161]; +-- +-- > let p = fmap (floor . (* 100)) (pgeom 1.0 1.1 6) +-- > in p == toP [100,110,121,133,146,161] +-- +-- > > Pbind(\degree,Pseries(-7,1,15), +-- > > \dur,Pgeom(0.5,0.89140193218427,15)).play; +-- +-- > audition (pbind [(K_degree,pseries (-7) 1 15) +-- > ,(K_dur,pgeom 0.5 0.89140193218427 15)]) +-- +-- There is a list variant. +-- +-- > > 5.geom(3,6) +-- > C.geom 5 3 6 == [3,18,108,648,3888] +pgeom :: (Num a) => a -> a -> Int -> P a +pgeom i s n = toP (C.geom n i s) + +-- | Pif. SC3 /implicitly repeating/ pattern-based conditional expression. +-- +-- > > a = Pfunc({0.3.coin}); +-- > > b = Pwhite(0,9,3); +-- > > c = Pwhite(10,19,3); +-- > > Pfin(9,Pif(a,b,c)).asStream.all +-- +-- > let {a = fmap (< 0.75) (pwhite 'α' 0.0 1.0 inf) +-- > ;b = pwhite 'β' 0 9 6 +-- > ;c = pwhite 'γ' 10 19 6} +-- > in pif a b c * (-1) == toP [-7,-3,-11,-17,-18,-6,-3,-4,-5] +pif :: P Bool -> P a -> P a -> P a +pif = liftP3_repeat P.if_demand + +-- | Place. SC3 interlaced embedding of subarrays. +-- +-- > > Place([0,[1,2],[3,4,5]],3).asStream.all == [0,1,3,0,2,4,0,1,5] +-- > C.lace 9 [[0],[1,2],[3,4,5]] == [0,1,3,0,2,4,0,1,5] +-- > place [[0],[1,2],[3,4,5]] 3 == toP [0,1,3,0,2,4,0,1,5] +-- +-- > > Place(#[1,[2,5],[3,6]],2).asStream.all == [1,2,3,1,5,6] +-- > C.lace 6 [[1],[2,5],[3,6]] == [1,2,3,1,5,6] +-- > place [[1],[2,5],[3,6]] 2 == toP [1,2,3,1,5,6] +-- +-- > C.lace 12 [[1],[2,5],[3,6..]] == [1,2,3,1,5,6,1,2,9,1,5,12] +-- > place [[1],[2,5],[3,6..]] 4 == toP [1,2,3,1,5,6,1,2,9,1,5,12] +place :: [[a]] -> Int -> P a +place a n = + let f = toP . concat . P.take_inf n . L.transpose . map cycle + in f a + +-- | Pn. SC3 pattern to repeat the enclosed pattern a number of +-- times. +-- +-- > pn 1 4 == toP [1,1,1,1] +-- > pn (toP [1,2,3]) 3 == toP [1,2,3,1,2,3,1,2,3] +-- +-- This is related to `concat`.`replicate` in standard list processing. +-- +-- > concat (replicate 4 [1]) == [1,1,1,1] +-- > concat (replicate 3 [1,2,3]) == [1,2,3,1,2,3,1,2,3] +-- +-- There is a `pconcatReplicate` near-alias (reversed argument order). +-- +-- > pconcatReplicate 4 1 == toP [1,1,1,1] +-- > pconcatReplicate 3 (toP [1,2]) == toP [1,2,1,2,1,2] +-- +-- This is productive over infinite lists. +-- +-- > concat (replicate inf [1]) +-- > pconcat (replicate inf 1) +-- > pconcatReplicate inf 1 +pn :: P a -> Int -> P a +pn p n = mconcat (replicate n p) + +-- | Ppatlace. SC3 /implicitly repeating/ pattern to lace input patterns. +-- +-- > > p = Ppatlace([1,Pseq([2,3],2),4],5); +-- > > p.asStream.all == [1,2,4,1,3,4,1,2,4,1,3,4,1,4] +-- +-- > ppatlace [1,pseq [2,3] 2,4] 5 == toP [1,2,4,1,3,4,1,2,4,1,3,4,1,4] +-- +-- > > p = Ppatlace([1,Pseed(Pn(1000,1),Prand([2,3],inf))],5); +-- > > p.asStream.all == [1,3,1,3,1,3,1,2,1,2] +-- +-- > ppatlace [1,prand 'α' [2,3] inf] 5 == toP [1,3,1,2,1,3,1,2,1,2] +-- +-- > > Pbind(\degree,Ppatlace([Pseries(0,1,8),Pseries(2,1,7)],inf), +-- > > \dur,0.25).play; +-- +-- > let p = [(K_degree,ppatlace [pseries 0 1 8,pseries 2 1 7] inf) +-- > ,(K_dur,0.125)] +-- > in audition (pbind p) +ppatlace :: [P a] -> Int -> P a +ppatlace a n = + let a' = L.transpose (map unP_repeat a) + in toP (L.concat (P.take_inf n a')) + +{-| Prand. SC3 pattern to make n random selections from a list of +patterns, the resulting pattern is flattened (joined). + +> > p = Pseed(Pn(1000,1),Prand([1,Pseq([10,20,30]),2,3,4,5],6)); +> > p.asStream.all == [3,5,3,10,20,30,2,2] + +> prand 'α' [1,toP [10,20],2,3,4,5] 5 == toP [5,2,10,20,2,1] + +> > Pbind(\note,Prand([0,1,5,7],inf),\dur,0.25).play + +> audition (pbind [(K_note,prand 'α' [0,1,5,7] inf),(K_dur,0.25)]) + +Nested sequences of pitches: + +> > Pbind(\midinote,Prand([Pseq(#[60,61,63,65,67,63]), +> > Prand(#[72,73,75,77,79],6), +> > Pshuf(#[48,53,55,58],2)],inf), +> > \dur,0.25).play + +> let {n = prand 'α' [pseq [60,61,63,65,67,63] 1 +> ,prand 'β' [72,73,75,77,79] 6 +> ,pshuf 'γ' [48,53,55,58] 2] inf} +> in audition (pbind [(K_midinote,n),(K_dur,0.075)]) + +The below cannot be written as intended with the list +based pattern library. This is precisely because the +noise patterns are values, not processes with a state +threaded non-locally. + +> do {n0 <- Sound.SC3.Lang.Random.IO.rrand 2 5 +> ;n1 <- Sound.SC3.Lang.Random.IO.rrand 3 9 +> ;let p = pseq [prand 'α' [pempty,pseq [24,31,36,43,48,55] 1] 1 +> ,pseq [60,prand 'β' [63,65] 1 +> ,67,prand 'γ' [70,72,74] 1] n0 +> ,prand 'δ' [74,75,77,79,81] n1] inf +> in return (ptake 24 p)} + +-} +prand :: Enum e => e -> [P a] -> Int -> P a +prand e a = join . prand' e a + +-- | Preject. SC3 pattern to rejects values for which the predicate +-- is true. reject f is equal to filter (not . f). +-- +-- > preject (== 1) (pseq [1,2,3] 2) == toP [2,3,2,3] +-- > pfilter (not . (== 1)) (pseq [1,2,3] 2) == toP [2,3,2,3] +-- +-- > > p = Pseed(Pn(1000,1),Pwhite(0,255,20).reject({|x| x.odd})); +-- > > p.asStream.all == [224,60,88,94,42,32,110,24,122,172] +-- +-- > preject odd (pwhite 'α' 0 255 10) == toP [32,158,62,216,240,20] +-- +-- > > p = Pseed(Pn(1000,1),Pwhite(0,255,20).select({|x| x.odd})); +-- > > p.asStream.all == [151,157,187,129,45,245,101,79,77,243] +-- +-- > pselect odd (pwhite 'α' 0 255 10) == toP [241,187,119,127] +preject :: (a -> Bool) -> P a -> P a +preject f = liftP (filter (not . f)) + +-- | Prorate. SC3 /implicitly repeating/ sub-dividing pattern. +-- +-- > > p = Prorate(Pseq([0.35,0.5,0.8]),1); +-- > > p.asStream.all == [0.35,0.65,0.5,0.5,0.8,0.2]; +-- +-- > let p = prorate (fmap Left (pseq [0.35,0.5,0.8] 1)) 1 +-- > in fmap roundE (p * 100) == toP [35,65,50,50,80,20] +-- +-- > > p = Prorate(Pseq([0.35,0.5,0.8]),Pseed(Pn(100,1),Prand([20,1],inf))); +-- > > p.asStream.all == [7,13,0.5,0.5,16,4] +-- +-- > let p = prorate (fmap Left (pseq [0.35,0.5,0.8] 1)) +-- > (prand 'α' [20,1] 3) +-- > in fmap roundE (p * 100) == toP [35,65,1000,1000,80,20] +-- +-- > > l = [[1,2],[5,7],[4,8,9]].collect(_.normalizeSum); +-- > > Prorate(Pseq(l,1)).asStream.all +-- +-- > let l = map (Right . C.normalizeSum) [[1,2],[5,7],[4,8,9]] +-- > in prorate (toP l) 1 +-- +-- > > Pfinval(5,Prorate(0.6,0.5)).asStream.all == [0.3,0.2,0.3,0.2,0.3] +-- +-- > pfinval 5 (prorate (fmap Left 0.6) 0.5) == toP [0.3,0.2,0.3,0.2,0.3] +-- +-- > > Pbind(\degree,Pseries(4,1,inf).fold(-7,11), +-- > > \dur,Prorate(0.6,0.5)).play +-- +-- > audition (pbind [(K_degree,pfold (pseries 4 1 inf) (-7) 11) +-- > ,(K_dur,prorate (fmap Left 0.6) 0.25)]) +prorate :: Num a => P (Either a [a]) -> P a -> P a +prorate p = pjoin_repeat . pzipWith prorate' p + +-- | Pselect. See 'pfilter'. +-- +-- > pselect (< 3) (pseq [1,2,3] 2) == toP [1,2,1,2] +pselect :: (a -> Bool) -> P a -> P a +pselect f = liftP (filter f) + +{-| Pseq. SC3 pattern to cycle over a list of patterns. The repeats +pattern gives the number of times to repeat the entire list. + +> pseq [return 1,return 2,return 3] 2 == toP [1,2,3,1,2,3] +> pseq [1,2,3] 2 == toP [1,2,3,1,2,3] +> pseq [1,pn 2 2,3] 2 == toP [1,2,2,3,1,2,2,3] + +There is an 'inf' value for the repeats variable. + +> ptake 3 (pdrop (10^5) (pseq [1,2,3] inf)) == toP [2,3,1] + +Unlike the SC3 Pseq, `pseq` does not have an offset argument to give a +starting offset into the list. + +> pseq (C.rotate 3 [1,2,3,4]) 3 == toP [2,3,4,1,2,3,4,1,2,3,4,1] + +As scale degrees. + +> > Pbind(\degree,Pseq(#[0,0,4,4,5,5,4],1), +> > \dur,Pseq(#[0.5,0.5,0.5,0.5,0.5,0.5,1],1)).play + +> audition (pbind [(K_degree,pseq [0,0,4,4,5,5,4] 1) +> ,(K_dur,pseq [0.5,0.5,0.5,0.5,0.5,0.5,1] 1)]) + +> > Pseq(#[60,62,63,65,67,63],inf) + Pseq(#[0,0,0,0,-12],inf) + +> let n = pseq [60,62,63,65,67,63] inf + pser [0,0,0,0,-12] 25 +> in audition (pbind [(K_midinote,n),(K_dur,0.2)]) + +Pattern `b` pattern sequences `a` once normally, once transposed up a +fifth and once transposed up a fourth. + +> > a = Pseq(#[60,62,63,65,67,63]); +> > b = Pseq([a,a + 7,a + 5],inf); +> > Pbind(\midinote,b,\dur,0.3).play + +> let {a = pseq [60,62,63,65,67,63] 1 +> ;b = pseq [a,a + 7,a + 5] inf} +> in audition (pbind [(K_midinote,b),(K_dur,0.13)]) +-} +pseq :: [P a] -> Int -> P a +pseq a i = + let a' = mconcat a + in if i == inf then pcycle a' else pn a' i + +-- | Pser. SC3 pattern that is like 'pseq', however the repeats +-- variable gives the number of elements in the sequence, not the +-- number of cycles of the pattern. +-- +-- > pser [1,2,3] 5 == toP [1,2,3,1,2] +-- > pser [1,pser [10,20] 3,3] 9 == toP [1,10,20,10,3,1,10,20,10] +-- > pser [1,2,3] 5 * 3 == toP [3,6,9,3,6] +pser :: [P a] -> Int -> P a +pser a i = ptake i (pcycle (mconcat a)) + +-- | Pseries. SC3 arithmetric series pattern, see also 'pgeom'. +-- +-- > pseries 0 2 10 == toP [0,2,4,6,8,10,12,14,16,18] +-- > pseries 9 (-1) 10 == toP [9,8 .. 0] +-- > pseries 1.0 0.2 3 == toP [1.0::Double,1.2,1.4] +pseries :: (Num a) => a -> a -> Int -> P a +pseries i s n = toP (C.series n i s) + +-- | Pshuf. SC3 pattern to return @n@ repetitions of a shuffled +-- sequence. +-- +-- > > Pshuf([1,2,3,4],2).asStream.all +-- > pshuf 'α' [1,2,3,4] 2 == toP [2,4,3,1,2,4,3,1] +-- +-- > > Pbind(\degree,Pshuf([0,1,2,4,5],inf),\dur,0.25).play +-- +-- > audition (pbind [(K_degree,pshuf 'α' [0,1,2,4,5] inf) +-- > ,(K_dur,0.25)]) +pshuf :: Enum e => e -> [a] -> Int -> P a +pshuf e a = + let (a',_) = R.scramble a (mkStdGen (fromEnum e)) + in pn (toP a') + +-- | Pslide. Lifted 'P.slide'. +-- +-- > > Pslide([1,2,3,4],inf,3,1,0).asStream.all +-- > pslide [1,2,3,4] 4 3 1 0 True == toP [1,2,3,2,3,4,3,4,1,4,1,2] +-- > pslide [1,2,3,4,5] 3 3 (-1) 0 True == toP [1,2,3,5,1,2,4,5,1] +-- +-- > > Pbind(\degree,Pslide((-6,-4 .. 12),8,3,1,0), +-- > > \dur,Pseq(#[0.1,0.1,0.2],inf), +-- > > \sustain,0.15).play +-- +-- > audition (pbind [(K_degree,pslide [-6,-4 .. 12] 8 3 1 0 True) +-- > ,(K_dur,pseq [0.05,0.05,0.1] inf) +-- > ,(K_sustain,0.15)]) +pslide :: [a] -> Int -> Int -> Int -> Int -> Bool -> P a +pslide a n j s i = toP . P.slide a n j s i + +-- | Pstutter. SC3 /implicitly repeating/ pattern to repeat each +-- element of a pattern /n/ times. +-- +-- > > Pstutter(2,Pseq([1,2,3],1)).asStream.all == [1,1,2,2,3,3] +-- > pstutter 2 (pseq [1,2,3] 1) == toP [1,1,2,2,3,3] +-- +-- The count input may be a pattern. +-- +-- > let {p = pseq [1,2] inf +-- > ;q = pseq [1,2,3] 2} +-- > in pstutter p q == toP [1,2,2,3,1,1,2,3,3] +-- +-- > pstutter (toP [1,2,3]) (toP [4,5,6]) == toP [4,5,5,6,6,6] +-- > pstutter 2 (toP [4,5,6]) == toP [4,4,5,5,6,6] +-- +-- Stutter scale degree and duration with the same random sequence. +-- +-- > > Pbind(\n,Pwhite(3,10,inf), +-- > > \degree,Pstutter(Pkey(\n),Pwhite(-4,11,inf)), +-- > > \dur,Pstutter(Pkey(\n),Pwhite(0.05,0.4,inf)), +-- > > \legato,0.3).play +-- +-- > let {n = pwhite 'α' 3 10 inf +-- > ;p = [(K_degree,pstutter n (pwhitei 'β' (-4) 11 inf)) +-- > ,(K_dur,pstutter n (pwhite 'γ' 0.05 0.4 inf)) +-- > ,(K_legato,0.3)]} +-- > in audition (pbind p) +pstutter :: P Int -> P a -> P a +pstutter = liftP2_repeat P.stutter + +-- | Pswitch. Lifted 'P.switch'. +-- +-- > let p = pswitch [pseq [1,2,3] 2,pseq [65,76] 1,800] (toP [2,2,0,1]) +-- > in p == toP [800,800,1,2,3,1,2,3,65,76] +pswitch :: [P a] -> P Int -> P a +pswitch l = liftP (P.switch (map unP l)) + +-- | Pswitch1. Lifted /implicitly repeating/ 'P.switch1'. +-- +-- > > l = [Pseq([1,2,3],inf),Pseq([65,76],inf),8]; +-- > > p = Pswitch1(l,Pseq([2,2,0,1],3)); +-- > > p.asStream.all == [8,8,1,65,8,8,2,76,8,8,3,65]; +-- +-- > let p = pswitch1 [pseq [1,2,3] inf +-- > ,pseq [65,76] inf +-- > ,8] (pseq [2,2,0,1] 6) +-- > in p == toP [8,8,1,65,8,8,2,76,8,8,3,65,8,8,1,76,8,8,2,65,8,8,3,76] +pswitch1 :: [P a] -> P Int -> P a +pswitch1 l = liftP (P.switch1 (map unP_repeat l)) + +-- | Ptuple. 'pseq' of 'ptranspose_st_repeat'. +-- +-- > > l = [Pseries(7,-1,8),3,Pseq([9,7,4,2],1),Pseq([4,2,0,0,-3],1)]; +-- > > p = Ptuple(l,1); +-- > > p.asStream.all == [[7,3,9,4],[6,3,7,2],[5,3,4,0],[4,3,2,0]] +-- +-- > let p = ptuple [pseries 7 (-1) 8 +-- > ,3 +-- > ,pseq [9,7,4,2] 1 +-- > ,pseq [4,2,0,0,-3] 1] 1 +-- > in p == toP [[7,3,9,4],[6,3,7,2],[5,3,4,0],[4,3,2,0]] +ptuple :: [P a] -> Int -> P [a] +ptuple p = pseq [ptranspose_st_repeat p] + +-- | Pwhite. Lifted 'P.white'. +-- +-- > pwhite 'α' 0 9 5 == toP [3,0,1,6,6] +-- > pwhite 'α' 0 9 5 - pwhite 'α' 0 9 5 == toP [0,0,0,0,0] +-- +-- The pattern below is alternately lower and higher noise. +-- +-- > let {l = pseq [0.0,9.0] inf +-- > ;h = pseq [1.0,12.0] inf} +-- > in audition (pbind [(K_freq,pwhite' 'α' l h * 20 + 800) +-- > ,(K_dur,0.25)]) +pwhite :: (Random n,Enum e) => e -> n -> n -> Int -> P n +pwhite e l r = toP . P.white e l r + +-- | Pwrand. Lifted 'P.wrand'. +-- +-- > let w = C.normalizeSum [12,6,3] +-- > in pwrand 'α' [1,2,3] w 6 == toP [2,1,2,3,3,2] +-- +-- > > r = Pwrand.new([1,2,Pseq([3,4],1)],[1,3,5].normalizeSum,6); +-- > > p = Pseed(Pn(100,1),r); +-- > > p.asStream.all == [2,3,4,1,3,4,3,4,2] +-- +-- > let w = C.normalizeSum [1,3,5] +-- > in pwrand 'ζ' [1,2,pseq [3,4] 1] w 6 == toP [3,4,2,2,3,4,1,3,4] +-- +-- > > Pbind(\degree,Pwrand((0..7),[4,1,3,1,3,2,1].normalizeSum,inf), +-- > > \dur,0.25).play; +-- +-- > let {w = C.normalizeSum [4,1,3,1,3,2,1] +-- > ;d = pwrand 'α' (C.series 7 0 1) w inf} +-- > in audition (pbind [(K_degree,d),(K_dur,0.25)]) +pwrand :: (Enum e) => e -> [P a] -> [Double] -> Int -> P a +pwrand e a w = toP . P.wrand e (map unP a) w + +-- | Pwrap. Type specialised 'P.fwrap', see also 'pfold'. +-- +-- > > p = Pwrap(Pgeom(200,1.25,9),200,1000.0); +-- > > r = p.asStream.all.collect({|n| n.round}); +-- > > r == [200,250,313,391,488,610,763,954,392]; +-- +-- > let p = fmap roundE (pwrap (pgeom 200 1.25 9) 200 1000) +-- > in p == toP [200,250,312,391,488,610,763,954,391] +pwrap :: (Ord a,Num a) => P a -> a -> a -> P a +pwrap = P.fwrap + +-- | Pxrand. Lifted 'P.xrand'. +-- +-- > let p = pxrand 'α' [1,toP [2,3],toP [4,5,6]] 9 +-- > in p == toP [4,5,6,2,3,4,5,6,1] +-- +-- > > Pbind(\note,Pxrand([0,1,5,7],inf),\dur,0.25).play +-- +-- > audition (pbind [(K_note,pxrand 'α' [0,1,5,7] inf),(K_dur,0.25)]) +pxrand :: Enum e => e -> [P a] -> Int -> P a +pxrand e a n = toP (P.xrand e (map unP a) n) + +-- * Variant SC3 Patterns + +-- | Lifted /implicitly repeating/ 'P.pbrown''. +-- +-- > pbrown' 'α' 1 700 (pseq [1,20] inf) 4 == toP [415,419,420,428] +pbrown' :: (Enum e,Random n,Num n,Ord n) => + e -> P n -> P n -> P n -> Int -> P n +pbrown' e l r s n = + let f = liftP3_repeat (P.brown' e) + in ptake n (f l r s) + +-- | Un-joined variant of 'prand'. +-- +-- > let p = prand' 'α' [1,toP [2,3],toP [4,5,6]] 5 +-- > in p == toP [toP [4,5,6],toP [4,5,6],toP [2,3],toP [4,5,6],1] +prand' :: Enum e => e -> [P a] -> Int -> P (P a) +prand' e a n = toP (P.rand' e a n) + +-- | Underlying pattern for 'prorate'. +-- +-- > prorate' (Left 0.6) 0.5 +prorate' :: Num a => Either a [a] -> a -> P a +prorate' p = + case p of + Left p' -> toP . P.rorate_n' p' + Right p' -> toP . P.rorate_l' p' + +{-| +Variant of `pseq` that retrieves only one value from each pattern +on each list traversal. Compare to `pswitch1`. + +> pseq [pseq [1,2] 1,pseq [3,4] 1] 2 == toP [1,2,3,4,1,2,3,4] +> pseq1 [pseq [1,2] 1,pseq [3,4] 1] 2 == toP [1,3,2,4] +> pseq1 [pseq [1,2] inf,pseq [3,4] inf] 3 == toP [1,3,2,4,1,3] + +> let {p = prand' 'α' [pempty,toP [24,31,36,43,48,55]] inf +> ;q = pflop [60,prand 'β' [63,65] inf +> ,67,prand 'γ' [70,72,74] inf] +> ;r = psplitPlaces (pwhite 'δ' 3 9 inf) +> (toP [74,75,77,79,81]) +> ;n = pjoin (pseq1 [p,q,r] inf)} +> in audition (pbind [(K_midinote,n),(K_dur,0.13)]) +-} +pseq1 :: [P a] -> Int -> P a +pseq1 a i = join (ptake i (pflop a)) + +-- | A variant of 'pseq' to aid translating a common SC3 idiom where a +-- finite random pattern is included in a @Pseq@ list. In the SC3 +-- case, at each iteration a new computation is run. This idiom does +-- not directly translate to the declarative haskell pattern library. +-- +-- > > Pseq([1,Prand([2,3],1)],5).asStream.all +-- > pseq [1,prand 'α' [2,3] 1] 5 == toP [1,3,1,3,1,3,1,3,1,3] +-- +-- Although the intended pattern can usually be expressed using an +-- alternate construction: +-- +-- > > Pseq([1,Prand([2,3],1)],5).asStream.all +-- > ppatlace [1,prand 'α' [2,3] inf] 5 == toP [1,3,1,2,1,3,1,2,1,2] +-- +-- the 'pseqn' variant handles many common cases. +-- +-- > > Pseq([Pn(8,2),Pwhite(9,16,1)],5).asStream.all +-- +-- > let p = pseqn [2,1] [8,pwhite 'α' 9 16 inf] 5 +-- > in p == toP [8,8,10,8,8,9,8,8,12,8,8,15,8,8,15] +pseqn :: [Int] -> [P a] -> Int -> P a +pseqn n q = + let rec p c = if c == 0 + then mempty + else let (i,j) = unzip (zipWith psplitAt n p) + in mconcat i <> rec j (c - 1) + in rec (map pcycle q) + +{-| + +A variant of 'pseq' that passes a new seed at each invocation, +see also 'pfuncn'. + +> > pseqr (\e -> [pshuf e [1,2,3,4] 1]) 2 == toP [2,3,4,1,4,1,2,3] + +> let {d = pseqr (\e -> [pshuf e [-7,-3,0,2,4,7] 4 +> ,pseq [0,1,2,3,4,5,6,7] 1]) inf} +> in audition (pbind [(K_degree,d),(K_dur,0.15)]) + +> > Pbind(\dur,0.2, +> > \midinote,Pseq([Pshuf(#[60,61,62,63,64,65,66,67],3)],inf)).play + +> let m = pseqr (\e -> [pshuf e [60,61,62,63,64,65,66,67] 3]) inf +> in audition (pbind [(K_dur,0.2),(K_midinote,m)]) + +-} +pseqr :: (Int -> [P a]) -> Int -> P a +pseqr f n = mconcat (L.concatMap f [1 .. n]) + +-- | Variant of 'pser' that consumes sub-patterns one element per +-- iteration. +-- +-- > pser1 [1,pser [10,20] 3,3] 9 == toP [1,10,3,1,20,3,1,10,3] +pser1 :: [P a] -> Int -> P a +pser1 a i = ptake i (join (pflop a)) + +-- | Lifted /implicitly repeating/ 'P.pwhite'. +-- +-- > pwhite' 'α' 0 (pseq [9,19] 3) == toP [3,0,1,6,6,15] +pwhite' :: (Enum e,Random n) => e -> P n -> P n -> P n +pwhite' e = liftP2_repeat (P.white' e) + +-- | Lifted 'P.whitei'. +-- +-- > pwhitei 'α' 1 9 5 == toP [5,1,7,7,8] +-- +-- > audition (pbind [(K_degree,pwhitei 'α' 0 8 inf),(K_dur,0.15)]) +pwhitei :: (RealFracE n,Random n,Enum e) => e -> n -> n -> Int -> P n +pwhitei e l r = toP . P.whitei e l r + +-- * Non-SC3 Patterns + +-- | Type specialised 'P.fbool'. +pbool :: (Ord a,Num a) => P a -> P Bool +pbool = P.fbool + +-- | 'mconcat' of 'replicate'. +pconcatReplicate :: Int -> P a -> P a +pconcatReplicate i = mconcat . replicate i + +-- | Lifted 'P.countpost'. +pcountpost :: P Bool -> P Int +pcountpost = liftP P.countpost + +-- | Lifted 'P.countpre'. +pcountpre :: P Bool -> P Int +pcountpre = liftP P.countpre + +-- | Lifted 'P.hold'. +phold :: P a -> P a +phold = liftP P.hold + +-- | Lifted 'P.interleave2'. +-- +-- > let p = pinterleave2 (pwhite 'α' 1 9 inf) (pseries 10 1 5) +-- > in [3,10,9,11,2,12,9,13,4,14] `L.isPrefixOf` unP p +pinterleave2 :: P a -> P a -> P a +pinterleave2 = liftP2 P.interleave2 + +-- | Lifted 'P.interleave'. +-- +-- > pinterleave [pwhitei 'α' 0 4 3,pwhitei 'β' 5 9 3] == toP [2,7,0,5,3,6] +pinterleave :: [P a] -> P a +pinterleave = toP . P.interleave . map unP + +-- | Lifted 'L.isPrefixOf'. +pisPrefixOf :: Eq a => P a -> P a -> Bool +pisPrefixOf p q = L.isPrefixOf (unP p) (unP q) + +-- | Lifted 'P.rsd'. +-- +-- > prsd (pstutter 2 (toP [1,2,3])) == toP [1,2,3] +-- > prsd (pseq [1,2,3] 2) == toP [1,2,3,1,2,3] +prsd :: (Eq a) => P a -> P a +prsd = liftP P.rsd + +-- | Lifted 'P.trigger'. +-- +-- > let {tr = pbool (toP [0,1,0,0,1,1]) +-- > ;p = ptrigger tr (toP [1,2,3]) +-- > ;r = [Nothing,Just 1,Nothing,Nothing,Just 2,Just 3]} +-- > in p == toP r +ptrigger :: P Bool -> P a -> P (Maybe a) +ptrigger p q = + let r = pcountpre p + f i x = preplicate i Nothing <> return (Just x) + in join (pzipWith f r q) + +-- * SC3 Event Patterns + +instance Audible (P Event) where + play = e_play . Event_Seq . unP + +-- | Synonym for ('Key','P Field'). +type P_Bind = (Key,P Field) + +{-| +Padd. Add a value to an existing key, or set the key if it doesn't exist. + +> > p = Padd(\freq,801,Pbind(\freq,Pseq([100],1))); +> > p.asStream.all(()) == [('freq':901)] + +> let p = padd (K_freq,801) (pbind [(K_freq,return 100)]) +> in p == pbind [(K_freq,return 901)] + +> > Padd(\freq,Pseq([401,801],2),Pbind(\freq,100)).play + +> audition (padd (K_freq,pseq [401,801] 2) (pbind [(K_freq,100)])) + +> let {d = pseq [pshuf 'α' [-7,-3,0,2,4,7] 2 +> ,pseq [0,1,2,3,4,5,6,7] 1] 1 +> ;p = pbind [(K_dur,0.15),(K_degree,d)] +> ;t n = padd (K_mtranspose,n) p} +> in audition (pseq [p,t 1,t 2] inf) +-} +padd :: P_Bind -> P Event -> P Event +padd (k,p) = pzipWith (\i j -> e_edit k 0 (+ i) j) p + +{-| Pbind. SC3 pattern to assign keys to a set of 'Field' patterns +making an 'Event' pattern. + +Each input pattern is assigned to key in the resulting event pattern. + +There are a set of reserved keys that have particular roles in the +pattern library. + +> > p = Pbind(\x,Pseq([1,2,3],1),\y,Pseed(Pn(100,1),Prand([4,5,6],inf))); +> > p.asStream.all(()) == [('y':4,'x':1),('y':6,'x':2),('y':4,'x':3)] + +> let p = pbind [(K_param "x",prand 'α' [100,300,200] inf) +> ,(K_param "y",pseq [1,2,3] 1)] +> in pkey (K_param "x") p == toP [200,200,300] + +'K_param' can be elided if /OverloadedStrings/ are in place. + +> :set -XOverloadedStrings + +> ptake 2 (pbind [("x",pwhitei 'α' 0 9 inf) +> ,("y",pseq [1,2,3] inf)]) + +'Event's implement variations on the @SC3@ 'Dur' and +'Sound.SC3.Lang.Control.Pitch.Pitch' models. + +> > Pbind(\freq,Prand([300,500,231.2,399.2],inf), +> > \dur,0.1).play; + +> audition (pbind [(K_freq,prand 'α' [300,500,231.2,399.2] inf) +> ,(K_dur,0.1)]) + +> > Pbind(\freq, Prand([300,500,231.2,399.2],inf), +> > \dur,Prand([0.1,0.3],inf)).play; + +> audition (pbind [(K_freq,prand 'α' [300,500,231.2,399.2] inf) +> ,(K_dur,prand 'β' [0.1,0.3] inf)]) + +> > Pbind(\freq,Prand([1,1.2,2,2.5,3,4],inf) * 200, +> > \dur,0.1).play; + +> audition (pbind [(K_freq,prand 'α' [1,1.2,2,2.5,3,4] inf * 200) +> ,(K_dur,0.1)]) + +> audition (pbind [(K_freq,pseq [440,550,660,770] 2) +> ,(K_dur,pseq [0.1,0.15,0.1] inf) +> ,(K_amp,pseq [0.1,0.05] inf) +> ,(K_param "pan",pseq [-1,0,1] inf)]) + +A finite binding stops the `Event` pattern. + +> > Pbind(\freq,Prand([300,500,231.2,399.2],inf), +> > \dur,Pseq([0.1,0.2],3)).play; + +> audition (pbind [(K_freq,prand 'α' [300,500,231.2,399.2] inf) +> ,(K_dur,pseq [0.1,0.2] 3)]) + +> > Pbind(\freq,Prand([300,500,231.2,399.2],inf), +> > \dur,Prand([0.1,0.3],inf)).play + +All infinite inputs: + +> audition (pbind [(K_freq,prand 'α' [300,500,231.2,399.2] inf) +> ,(K_dur,prand 'β' [0.1,0.3] inf)]) + +Implicit /field/ patterns is this context are infinite. + +> audition (pbind [(K_freq,prand 'α' [1,1.2,2,2.5,3,4] inf * 200) +> ,(K_dur,0.1)]) + +> let test = let {freq = control KR "freq" 440 +> ;amp = control KR "amp" 0.1 +> ;nharms = control KR "nharms" 10 +> ;pan = control KR "pan" 0 +> ;gate = control KR "gate" 1 +> ;s = blip AR freq nharms * amp +> ;e = linen gate 0.01 0.6 0.4 RemoveSynth +> ;o = offsetOut 0 (pan2 s pan e)} +> in synthdef "test" o + +> audition (pbind [(K_instr,psynth test) +> ,(K_freq,prand 'α' [1,1.2,2,2.5,3,4] inf * 200) +> ,(K_dur,0.1)]) + +> audition (pbind [(K_instr,psynth test) +> ,(K_param "nharms",pseq [4,10,40] inf) +> ,(K_dur,pseq [1,1,2,1] inf / 10) +> ,(K_freq,pn (pseries 1 1 16 * 50) 4) +> ,(K_sustain,pseq [1/10,0.5,1,2] inf)]) + +> let acid = let {freq = control KR "freq" 1000 +> ;gate = control KR "gate" 1 +> ;pan = control KR "pan" 0 +> ;cut = control KR "cut" 4000 +> ;res = control KR "res" 0.8 +> ;amp = control KR "amp" 1 +> ;s = rlpf (pulse AR freq 0.05) cut res +> ;d = envLinen 0.01 1 0.3 1 +> ;e = envGen KR gate amp 0 1 RemoveSynth d +> ;o = out 0 (pan2 s pan e)} +> in synthdef "acid" o + +> > Pbind(\instrument,\acid, +> > \dur,Pseq([0.25,0.5,0.25],4), +> > \root,-24, +> > \degree,Pseq([0,3,5,7,9,11,5,1],inf), +> > \pan,Pfunc({1.0.rand2}), +> > \cut,Pxrand([1000,500,2000,300],inf), +> > \rez,Pfunc({0.7.rand +0.3}), +> > \amp,0.2).play + +> audition (pbind [(K_instr,psynth acid) +> ,(K_dur,pseq [0.25,0.5,0.25] 4) +> ,(K_root,-24) +> ,(K_degree,pseq [0,3,5,7,9,11,5,1] inf) +> ,(K_param "pan",pwhite 'α' (-1.0) 1.0 inf) +> ,(K_param "cut",pxrand 'β' [1000,500,2000,300] inf) +> ,(K_param "res",pwhite 'γ' 0.3 1.0 inf) +> ,(K_amp,0.2)]) + +> > Pseq([Pbind(\instrument,\acid, +> > \dur,Pseq([0.25,0.5,0.25],4), +> > \root,-24, +> > \degree,Pseq([0,3,5,7,9,11,5,1],inf), +> > \pan,Pfunc({1.0.rand2}), +> > \cut,Pxrand([1000,500,2000,300],inf), +> > \rez,Pfunc({0.7.rand + 0.3}), +> > \amp,0.2), +> > Pbind(\instrument,\acid, +> > \dur,Pseq([0.25],6), +> > \root,-24, +> > \degree,Pseq([18,17,11,9],inf), +> > \pan,Pfunc({1.0.rand2}), +> > \cut,1500, +> > \rez,Pfunc({0.7.rand + 0.3}), +> > \amp,0.16)],inf).play + +> audition (pseq [pbind [(K_instr,psynth acid) +> ,(K_dur,pseq [0.25,0.5,0.25] 4) +> ,(K_root,-24) +> ,(K_degree,pseq [0,3,5,7,9,11,5,1] inf) +> ,(K_param "pan",pwhite 'α' (-1.0) 1.0 inf) +> ,(K_param "cut",pxrand 'β' [1000,500,2000,300] inf) +> ,(K_param "res",pwhite 'γ' 0.3 1.0 inf) +> ,(K_amp,0.2)] +> ,pbind [(K_instr,psynth acid) +> ,(K_dur,pn 0.25 6) +> ,(K_root,-24) +> ,(K_degree,pser [18,17,11,9] inf) +> ,(K_param "pan",pwhite 'δ' (-1.0) 1.0 inf) +> ,(K_param "cut",1500) +> ,(K_param "res",pwhite 'ε' 0.3 1.0 inf) +> ,(K_amp,0.16)]] inf) + +> > Pbind(\instrument, \acid, +> > \dur, Pseq([0.25,0.5,0.25], inf), +> > \root, [-24,-17], +> > \degree, Pseq([0,3,5,7,9,11,5,1], inf), +> > \pan, Pfunc({1.0.rand2}), +> > \cut, Pxrand([1000,500,2000,300], inf), +> > \rez, Pfunc({0.7.rand +0.3}), +> > \amp, 0.2).play; + +> audition (pbind [(K_instr,psynth acid) +> ,(K_dur,pseq [0.25,0.5,0.25] inf) +> ,(K_root,pmce2 (-24) (-17)) +> ,(K_degree,pseq [0,3,5,7,9,11,5,1] inf) +> ,(K_param "pan",pwhite 'α' (-1.0) 1.0 inf) +> ,(K_param "cut",pxrand 'β' [1000,500,2000,300] inf) +> ,(K_param "res",pwhite 'γ' 0.3 1.0 inf) +> ,(K_amp,0.2)]) + +A persistent synthesis node with /freq/ and /amp/ controls. + +> import Sound.SC3.ID + +> let {freq = control KR "freq" 440 +> ;amp = control KR "amp" 0.6 +> ;n = pinkNoise 'α' AR * amp} +> in audition (out 0 (pan2 (moogFF n freq 2 0) 0 1)) + +A pattern to set /freq/ and /amp/ controls at the most recently +instantiated synthesis node. + +> :set -XOverloadedStrings + +> audition (pbind [(K_type,prepeat "n_set") +> ,(K_id,(-1)) +> ,(K_freq,pwhite 'α' 100 1000 inf) +> ,(K_dur,0.2) +> ,(K_amp,toP [1,0.99 .. 0.1])]) + +> let berlinb = +> let {k = control KR +> ;o = k "out" 0 +> ;f = k "freq" 80 +> ;a = k "amp" 0.01 +> ;p = k "pan" 0 +> ;g = k "gate" 1 +> ;env = decay2 g 0.05 8 * 0.0003 +> ;syn = rlpf (lfPulse AR f 0 (sinOsc KR 0.12 (mce2 0 (pi/2)) * 0.48 + 0.5)) +> (f * (sinOsc KR 0.21 0 * 18 + 20)) +> 0.07 +> ;syn_env = syn * env +> ;kil = detectSilence (mceChannel 0 syn_env) 0.1 0.2 RemoveSynth} +> in mrg2 (out o (a * mix (panAz 4 syn_env (mce2 p (p + 1)) 1 2 0.5))) kil + +> audition (ppar [pbind [(K_degree,pseq [0,1,2,4,6,3,4,8] inf) +> ,(K_dur,0.5) +> ,(K_octave,3) +> ,(K_instr,psynth (synthdef "berlinb" berlinb))] +> ,pbind [(K_degree,pseq [0,1,2,4,6,3,4,8] inf) +> ,(K_dur,0.5) +> ,(K_octave,pmce2 2 1) +> ,(K_param "pan",pwhite 'a' (-1) 1 inf) +> ,(K_instr,psynth (synthdef "berlinb" berlinb))]]) + +-} +pbind :: [P_Bind] -> P Event +pbind xs = + let xs' = fmap (\(k,v) -> pzip (undecided k) v) xs + xs'' = ptranspose_st_repeat xs' + in fmap e_from_list xs'' + +-- | Operator to lift 'F_Value' pattern to 'P_Bind' tuple. +-- +-- > let {r = True `pcons` preplicate 3 False :: P Bool} +-- > in pbind [K_rest <| r] == pbind [(K_rest,pseq [1,0,0,0] 1)] +(<|) :: F_Value v => Key -> P v -> P_Bind +(<|) k p = (k,fmap toF p) +infixl 3 <| + +-- | Pkey. SC3 pattern to read 'Key' at 'Event' pattern. Note +-- however that in haskell is usually more appropriate to name the +-- pattern using /let/. +-- +-- > pkey K_freq (pbind [(K_freq,return 440)]) == toP [440] +-- > pkey K_amp (pbind [(K_amp,toP [0,1])]) == toP [0,1] +-- +-- > > Pbind(\degree,Pseq([Pseries(-7,1,14),Pseries(7,-1,14)],inf), +-- > > \dur,0.25, +-- > > \legato,Pkey(\degree).linexp(-7,7,2.0,0.05)).play +-- +-- > let {d = pseq [pseries (-7) 1 14,pseries 7 (-1) 14] inf +-- > ;l = fmap (Sound.SC3.Lang.Math.linexp (-7) 7 2 0.05) d} +-- > in audition (pbind [(K_degree,d) +-- > ,(K_dur,0.25) +-- > ,(K_legato,l)]) +pkey :: Key -> P Event -> P Field +pkey k = fmap (fromJust . e_get k) + +-- | Pmono. SC3 pattern that is a variant of 'pbind' for controlling +-- monophonic (persistent) synthesiser nodes. +-- +-- > let p = [(K_instr,pinstr' (Instr_Ref "default" False)) +-- > ,(K_id,100) +-- > ,(K_degree,pxrand 'α' [0,2,4,5,7,9,11] inf) +-- > ,(K_amp,pwrand 'β' [0.05,0.2] [0.7,0.3] inf) +-- > ,(K_dur,0.25)] +-- > in audition (pmono p) +pmono :: [P_Bind] -> P Event +pmono b = + let ty = fmap F_String ("s_new" `pcons` prepeat "n_set") + in pbind ((K_type,ty) : b) + +-- | Pmul. SC3 pattern to multiply an existing key by a value, or set +-- the key if it doesn't exist. +-- +-- > let p = pbind [(K_dur,0.15),(K_freq,prand 'α' [440,550,660] 6)] +-- > in audition (pseq [p,pmul (K_freq,2) p,pmul (K_freq,0.5) p] 2) +pmul :: P_Bind -> P Event -> P Event +pmul (k,p) = pzipWith (\i j -> e_edit k 1 (* i) j) p + +{-| Ppar. Variant of 'ptpar' with zero start times. + +The result of `pmerge` can be merged again, `ppar` merges a list of +patterns. + +> let {a = pbind [(K_param "a",pseq [1,2,3] inf)] +> ;b = pbind [(K_param "b",pseq [4,5,6] inf)] +> ;r = toP [e_from_list [(K_param "a",1),(K_fwd',0)] +> ,e_from_list [(K_param "b",4),(K_fwd',1)]]} +> in ptake 2 (ppar [a,b]) == r + +> let {p = pbind [(K_dur,0.2),(K_midinote,pseq [62,65,69,72] inf)] +> ;q = pbind [(K_dur,0.4),(K_midinote,pseq [50,45] inf)] +> ;r = pbind [(K_dur,0.6),(K_midinote,pseq [76,79,81] inf)]} +> in audition (ppar [p,q,r]) + +Multiple nested `ppar` patterns. + +> let {a u = pbind [(K_dur,0.2),(K_param "pan",0.5),(K_midinote,pseq u 1)] +> ;b l = pbind [(K_dur,0.4),(K_param "pan",-0.5),(K_midinote,pseq l 1)] +> ;f u l = ppar [a u,b l] +> ;h = pbind [(K_dur,prand 'α' [0.2,0.4,0.6] inf) +> ,(K_midinote,prand 'β' [72,74,76,77,79,81] inf) +> ,(K_db,-26) +> ,(K_legato,1.1)] +> ;m = pseq [pbind [(K_dur,3.2),(K_freq,return nan)] +> ,prand 'γ' [f [60,64,67,64] [48,43] +> ,f [62,65,69,65] [50,45] +> ,f [64,67,71,67] [52,47]] 12] inf} +> in audition (ppar [h,m]) + +-} +ppar :: [P Event] -> P Event +ppar l = ptpar (zip (repeat 0) l) + +-- | Pstretch. SC3 pattern to do time stretching. It is equal to +-- 'pmul' at 'K_stretch'. +-- +-- > let {d = pseq [pshuf 'α' [-7,-3,0,2,4,7] 2 +-- > ,pseq [0,1,2,3,4,5,6,7] 1] 1 +-- > ;p = pbind [(K_dur,0.15),(K_degree,d)]} +-- > in audition (pseq [p,pstretch 0.5 p,pstretch 2 p] inf) +pstretch :: P Field -> P Event -> P Event +pstretch p = pmul (K_stretch,p) + +{-| Ptpar. Merge a set of 'Event' patterns each with indicated +-- start 'Time'. + +`ptpar` is a variant of `ppar` which allows non-equal start times. + +> let {f d p n = pbind [(K_dur,d),(K_param "pan",p),(K_midinote,n)] +> ;a = f 0.2 (-1) (pseries 60 1 15) +> ;b = f 0.15 0 (pseries 58 2 15) +> ;c = f 0.1 1 (pseries 46 3 15)} +> in audition (ptpar [(0,a),(1,b),(2,c)]) + +> let {d = pseq [pgeom 0.05 1.1 24,pgeom 0.5 0.909 24] 2 +> ;f n a p = pbind [(K_dur,d) +> ,(K_db,a) +> ,(K_param "pan",p) +> ,(K_midinote,pseq [n,n-4] inf)]} +> in audition (ptpar [(0,f 53 (-20) (-0.9)) +> ,(2,f 60 (-23) (-0.3)) +> ,(4,f 67 (-26) 0.3) +> ,(6,f 74 (-29) 0.9)]) + +-} +ptpar :: [(Time,P Event)] -> P Event +ptpar l = + case l of + [] -> mempty + [(_,p)] -> p + (pt,p):(qt,q):r -> ptpar ((min pt qt,ptmerge (pt,p) (qt,q)) : r) + +-- * Instrument Event Patterns + +-- | Pattern from 'Instr'. An 'Instr' is either a 'Synthdef' or a +-- /name/. In the 'Synthdef' case the instrument is asynchronously +-- sent to the server before processing the event, which has timing +-- implications. The pattern constructed here uses the 'Synthdef' for +-- the first element, and the subsequently the /name/. +-- +-- > audition (pbind [(K_instr,pinstr' defaultInstr) +-- > ,(K_degree,toP [0,2,4,7]) +-- > ,(K_dur,0.25)]) +pinstr' :: Instr -> P Field +pinstr' i = toP (map F_Instr (i_repeat i)) + +{-| 'Instr' pattern from instrument /name/. See also `psynth` (where +the /sine/ instrument below is defined). + +> let {si = return (F_Instr (Instr_Ref "sine" True)) +> ;di = return (F_Instr (Instr_Ref "default" True)) +> ;i = pseq [si,si,di] inf +> ;p = pbind [(K_instr,i),(K_degree,pseq [0,2,4,7] inf),(K_dur,0.25)]} +> in audition p + +-} +pinstr :: String -> P Field +pinstr s = pinstr' (Instr_Ref s True) + +{-| `Synthdef`s can be used directly as an instrument using `psynth`. +The default synthdef is at 'Data.Default.def'. + +> let sineSynth = +> let {f = control KR "freq" 440 +> ;g = control KR "gate" 1 +> ;a = control KR "amp" 0.1 +> ;d = envASR 0.01 1 1 (EnvNum (-4)) +> ;e = envGen KR g a 0 1 RemoveSynth d +> ;o = out 0 (sinOsc AR f 0 * e)} +> in synthdef "sine" o + +> audition (pbind [(K_instr,psynth sineSynth) +> ,(K_degree,toP [0,2,4,7]) +> ,(K_dur,0.25)]) + +-} +psynth :: Synthdef -> P Field +psynth s = pinstr' (Instr_Def s True) + +-- * MCE Patterns + +-- | Two-channel MCE for /field/ patterns. +-- +-- > pmce2 (toP [1,2]) (toP [3,4]) == toP [f_array [1,3],f_array [2,4]] +-- +-- > let p = pmce2 (pseq [1,2] inf) (pseq [3,4] inf) +-- > in ptake 2 p == toP [f_array [1,3],f_array [2,4]] +pmce2 :: P Field -> P Field -> P Field +pmce2 p = pzipWith (\m n -> F_Vector [m,n]) p + +-- | Three-channel MCE for /field/ patterns. +pmce3 :: P Field -> P Field -> P Field -> P Field +pmce3 p q = pzipWith3 (\m n o -> F_Vector [m,n,o]) p q + +{-| + +Remove one layer of MCE expansion at an /event/ pattern. The +pattern will be expanded only to the width of the initial input. +Holes are filled with rests. + +> let {a = pseq [65,69,74] inf +> ;b = pseq [60,64,67,72,76] inf +> ;c = pseq [pmce3 72 76 79,pmce2 a b] 1} +> in audition (p_un_mce (pbind [(K_midinote,c) +> ,(K_param "pan",pmce2 (-1) 1) +> ,(K_dur,1 `pcons` prepeat 0.15)])) + +`p_un_mce` translates via `ppar`. This allows `dur` related fields to +be MCE values. The underlying event processor also implements one +layer of MCE expansion. + +> audition (p_un_mce +> (pbind [(K_dur,pmce2 0.25 0.2525) +> ,(K_legato,pmce2 0.25 2.5) +> ,(K_freq,pmce2 (pseq [300,400,500] inf) +> (pseq [302,402,502,202] inf)) +> ,(K_param "pan",pmce2 (-0.5) 0.5)])) + +-} +p_un_mce :: P Event -> P Event +p_un_mce p = + let l' = P.transpose_fw_def' e_rest (map e_un_mce' (unP p)) + in toP (e_par (zip (repeat 0) l')) + +-- * Non-SC3 Event Patterns + +-- | Edit 'a' at 'Key' in each element of an 'Event' pattern. +pedit :: Key -> (Field -> Field) -> P Event -> P Event +pedit k f = fmap (e_edit' k f) + +-- | Pattern of start times of events at event pattern. +-- +-- > p_time (pbind [(K_dur,toP [1,2,3,2,1])]) == toP [0,1,3,6,8,9] +-- > p_time (pbind [(K_dur,pseries 0.5 0.5 5)]) == toP [0,0.5,1.5,3,5,7.5] +p_time :: P Event -> P Time +p_time = pscanl (+) 0 . fmap (fwd . e_dur Nothing) + +-- | Pattern to extract 'a's at 'Key' from an 'Event' +-- pattern. +-- +-- > pkey_m K_freq (pbind [(K_freq,return 440)]) == toP [Just 440] +pkey_m :: Key -> P Event -> P (Maybe Field) +pkey_m k = fmap (e_get k) + +{-| Variant of 'ptmerge' with zero start times. + +`pmerge` merges two event streams, adding /fwd'/ entries as required. + +> let {p = pbind [(K_dur,0.2),(K_midinote,pseq [62,65,69,72] inf)] +> ;q = pbind [(K_dur,0.4),(K_midinote,pseq [50,45] inf)]} +> in audition (pmerge p q) + +-} +pmerge :: P Event -> P Event -> P Event +pmerge p q = ptmerge (0,p) (0,q) + +-- | Variant that does not insert key. +pmul' :: P_Bind -> P Event -> P Event +pmul' (k,p) = pzipWith (\i j -> e_edit' k (* i) j) p + +-- | Merge two 'Event' patterns with indicated start 'Time's. +ptmerge :: (Time,P Event) -> (Time,P Event) -> P Event +ptmerge (pt,p) (qt,q) = + toP (e_merge (pt,F.toList p) (qt,F.toList q)) + +-- | Left-biased union of event patterns. +punion :: P Event -> P Event -> P Event +punion = pzipWith (<>) + +-- | 'punion' of 'pbind' of 'return', ie. @p_with (K_Instr,psynth s)@. +p_with :: P_Bind -> P Event -> P Event +p_with = punion . pbind . return + +-- * Aliases + +-- | Type specialised 'mappend', sequences two patterns, +-- ie. 'Data.List.++'. +-- +-- > 1 <> mempty <> 2 == toP [1,2] +-- +-- > let {p = prand 'α' [0,1] 3 +-- > ;q = prand 'β' [5,7] 3} +-- > in audition (pbind [(K_degree,pappend p q),(K_dur,0.15)]) +pappend :: P a -> P a -> P a +pappend = mappend + +-- | Type specialised 'mconcat' (or equivalently 'msum' or +-- 'Data.List.concat'). +-- +-- > mconcat [pseq [1,2] 1,pseq [3,4] 2] == toP [1,2,3,4,3,4] +-- > msum [pseq [1,2] 1,pseq [3,4] 2] == toP [1,2,3,4,3,4] +pconcat :: [P a] -> P a +pconcat = mconcat + +-- | Type specialised `mempty`, ie. 'Data.List.[]'. +pempty :: P a +pempty = mempty + +-- | Type specialised 'F.foldr'. +-- +-- > > (Pser([1,2,3],5) + Pseq([0,10],3)).asStream.all == [1,12,3,11,2] +-- +-- > let p = pser [1,2,3] 5 + pseq [0,10] 3 +-- > in F.foldr (:) [] p == [1,12,3,11,2] +-- +-- Indefinte patterns may be folded. +-- +-- > take 3 (F.foldr (:) [] (prepeat 1)) == [1,1,1] +-- +-- The `Foldable` module includes functions for 'F.product', 'F.sum', +-- 'F.any', 'F.elem' etc. +-- +-- > F.product (toP [1,3,5]) == 15 +-- > floor (F.sum (ptake 100 (pwhite 'α' 0.25 0.75 inf))) == 51 +-- > F.any even (toP [1,3,5]) == False +-- > F.elem 5 (toP [1,3,5]) == True +pfoldr :: (a -> b -> b) -> b -> P a -> b +pfoldr = F.foldr + +-- | Type specialised 'join'. +-- +-- > join (replicate 2 [1,2]) == [1,2,1,2] +-- > join (preplicate 2 (toP [1,2])) == toP [1,2,1,2] +pjoin :: P (P a) -> P a +pjoin = join + +-- | 'join' that pushes an outer 'undecided' inward. +-- +-- > join (undecided (undecided 1)) == undecided 1 +-- > join (undecided (return 1)) == return 1 +-- > pjoin_repeat (undecided (return 1)) == pure 1 == _|_ +pjoin_repeat :: P (P a) -> P a +pjoin_repeat p = + case p of + P (Left (P (Right l))) -> toP (cycle l) + _ -> join p + +-- | Type specialised 'fmap', ie. 'Data.List.map'. +pmap :: (a -> b) -> P a -> P b +pmap = fmap + +-- | Type specialised '>>='. +-- +-- > (return 1 >>= return . id) == [1] +-- > (undecided 1 >>= undecided . id) == undecided 1 +-- +-- > (pseq [1,2] 1 >>= \x -> +-- > pseq [3,4,5] 1 >>= \y -> +-- > return (x,y)) == toP [(1,3),(1,4),(1,5),(2,3),(2,4),(2,5)] +pmbind :: P a -> (a -> P b) -> P b +pmbind = (>>=) + +-- | Type specialised 'pure'. +ppure :: a -> P a +ppure = pure + +-- | Type specialised 'return'. +preturn :: a -> P a +preturn = return + +-- | Type specialised 'T.traverse'. +-- +-- > let {f i e = (i + e,e * 2) +-- > ;(r,p) = T.mapAccumL f 0 (toP [1,3,5])} +-- > in (r,p) == (9,toP [2,6,10]) +ptraverse :: Applicative f => (a -> f b) -> P a -> f (P b) +ptraverse = T.traverse + +-- * NRT + +{-| Transform an /event/ pattern into a /non-real time/ SC3 score. + +> let n = pNRT (pbind [(K_freq,prand 'α' [300,500,231.2,399.2] inf) +> ,(K_dur,pseq [0.1,0.2] 3)]) +> audition n +> mapM_ (putStrLn . bundlePP) (nrt_bundles n) + +Infinite 'NRT' scores are productive for 'audition'ing. + +> let n' = pNRT (pbind [(K_dur,0.25),(K_freq,pseq [300,600,900] inf)]) +> audition n' +> mapM_ (putStrLn . bundlePP) (take 9 (nrt_bundles n')) + +-} +pNRT :: P Event -> NRT +pNRT = e_nrt . Event_Seq . unP + +-- * UId variants + +-- | 'liftUId' of 'pbrown'. +pbrownM :: (UId m,Num n,Ord n,Random n) => n -> n -> n -> Int -> m (P n) +pbrownM = liftUId4 pbrown + +-- | 'liftUId' of 'pexprand'. +pexprandM :: (UId m,Random a,Floating a) => a -> a -> Int -> m (P a) +pexprandM = liftUId3 pexprand + +-- | 'liftUId' of 'prand'. +prandM :: UId m => [P a] -> Int -> m (P a) +prandM = liftUId2 prand + +-- | 'liftUId' of 'pshuf'. +pshufM :: UId m => [a] -> Int -> m (P a) +pshufM = liftUId2 pshuf + +-- | 'liftUId' of 'pwhite'. +pwhiteM :: (UId m,Random n) => n -> n -> Int -> m (P n) +pwhiteM = liftUId3 pwhite + +-- | 'liftUId' of 'pwhitei'. +pwhiteiM :: (UId m,RealFracE n,Random n) => n -> n -> Int -> m (P n) +pwhiteiM = liftUId3 pwhitei + +-- | 'liftUId' of 'pwrand'. +pwrandM :: UId m => [P a] -> [Double] -> Int -> m (P a) +pwrandM = liftUId3 pwrand + +-- | 'liftUId' of 'pxrand'. +pxrandM :: UId m => [P a] -> Int -> m (P a) +pxrandM = liftUId2 pxrand 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,75 +1,306 @@ -- | List variants of @SC3@ pattern functions. module Sound.SC3.Lang.Pattern.List where -import qualified Data.Map as M -import Data.Maybe -import Data.List -import qualified Sound.SC3 as S +import qualified Data.Map as M {- containers -} +import Data.Maybe {- base -} +import Data.Monoid {- base -} +import Data.List {- base -} +import qualified Sound.SC3 as S {- hsc3 -} +import System.Random {- random -} + import qualified Sound.SC3.Lang.Collection as C +import qualified Sound.SC3.Lang.Math as M import qualified Sound.SC3.Lang.Random.Gen as R -import System.Random -brown_ :: (RandomGen g,Random n,Num n,Ord n) => (n,n,n) -> (n,g) -> (n,g) -brown_ (l,r,s) (n,g) = - let (i,g') = randomR (-s,s) g - in (S.foldToRange l r (n + i),g') +-- * Data.Bool variants -brown' :: (Enum e,Random n,Num n,Ord n) => e -> [n] -> [n] -> [n] -> [n] -brown' e l_ r_ s_ = - let go _ [] = [] - go (n,g) ((l,r,s):z) = let (n',g') = brown_ (l,r,s) (n,g) - in n' : go (n',g') z - in go (randomR (head l_,head r_) (mkStdGen (fromEnum e))) (zip3 l_ r_ s_) +-- | '>' @0@. Values greater than zero are 'True' and zero and +-- negative values are 'False'. +bool :: (Ord n,Num n) => n -> Bool +bool = (> 0) +-- * Data.Functor variants + +-- | 'fmap' of 'bool'. +-- +-- > fbool [2,1,0,-1] == [True,True,False,False] +fbool :: (Ord a,Num a,Functor f) => f a -> f Bool +fbool = fmap (> 0) + +-- | SC3 pattern to fold values to lie within range (as opposed to +-- wrap and clip). This is /not/ related to "Data.Foldable". +-- +-- > ffold [10,11,12,-6,-7,-8] (-7) 11 == [10,11,10,-6,-7,-6] +-- +-- The underlying primitive is the 'S.fold_' function. +-- +-- > let f n = S.fold_ n (-7) 11 +-- > in map f [10,11,12,-6,-7,-8] == [10,11,10,-6,-7,-6] +ffold :: (Functor f,Num a,Ord a) => f a -> a -> a -> f a +ffold p i j = fmap (\n -> S.fold_ n i j) p + +-- | SC3 pattern to constrain the range of output values by wrapping, +-- the primitive is 'S.genericWrap'. +-- +-- > let p = fmap round (fwrap (geom 200 1.2 10) 200 1000) +-- > in p == [200,240,288,346,415,498,597,717,860,231] +fwrap :: (Functor f,Ord a,Num a) => f a -> a -> a -> f a +fwrap xs l r = fmap (S.genericWrap l r) xs + +-- * Data.List variants + +-- | Inverse of 'Data.List.:'. +-- +-- > map uncons [[],1:[]] == [(Nothing,[]),(Just 1,[])] +uncons :: [a] -> (Maybe a,[a]) +uncons l = + case l of + [] -> (Nothing,[]) + x:l' -> (Just x,l') + +-- | 'Maybe' variant of '!!'. +-- +-- > map (lindex "str") [2,3] == [Just 'r',Nothing] +lindex :: [a] -> Int -> Maybe a +lindex l n = + if n < 0 + then Nothing + else case (l,n) of + ([],_) -> Nothing + (x:_,0) -> Just x + (_:l',_) -> lindex l' (n - 1) + +-- | List section with /wrapped/ indices. +-- +-- > segment [0..4] 5 (3,5) == [3,4,0] +segment :: [a] -> Int -> (Int,Int) -> [a] +segment a k (l,r) = + let i = map (S.genericWrap 0 (k - 1)) [l .. r] + in map (a !!) i + +-- | If /n/ is 'maxBound' this is 'id', else it is 'take'. +take_inf :: Int -> [a] -> [a] +take_inf n = if n == maxBound then id else take n + +-- | Variant of 'transpose' for /fixed width/ interior lists. Holes +-- are represented by 'Nothing'. +-- +-- > transpose_fw undefined [] == [] +-- +-- > transpose [[1,3],[2,4]] == [[1,2],[3,4]] +-- > transpose_fw 2 [[1,3],[2,4]] == [[Just 1,Just 2],[Just 3,Just 4]] +-- +-- > transpose [[1,5],[2],[3,7]] == [[1,2,3],[5,7]] +-- +-- > transpose_fw 2 [[1,4],[2],[3,6]] == [[Just 1,Just 2,Just 3] +-- > ,[Just 4,Nothing,Just 6]] +-- +-- This function is more productive than 'transpose' for the case of +-- an infinite list of finite lists. +-- +-- > map head (transpose_fw 4 (repeat [1..4])) == map Just [1,2,3,4] +-- > map head (transpose (repeat [1..4])) == _|_ +transpose_fw :: Int -> [[a]] -> [[Maybe a]] +transpose_fw w l = + if null l + then [] + else let f n = map (`lindex` n) l + in map f [0 .. w - 1] + +-- | Variant of 'transpose_fw' with default value for holes. +transpose_fw_def :: a -> Int -> [[a]] -> [[a]] +transpose_fw_def def w l = + let f n = map (fromMaybe def . (`lindex` n)) l + in map f [0 .. w - 1] + +-- | Variant of 'transpose_fw_def' deriving /width/ from first element. +transpose_fw_def' :: a -> [[a]] -> [[a]] +transpose_fw_def' def l = + case l of + [] -> [] + h:_ -> transpose_fw_def def (length h) l + +-- | A 'transpose' variant, halting when first hole appears. +-- +-- > trs [[1,2,3],[4,5,6],[7,8]] == [[1,4,7],[2,5,8]] +transpose_st :: [[a]] -> [[a]] +transpose_st l = + let (h,l') = unzip (map uncons l) + in case all_just h of + Just h' -> h' : transpose_st l' + Nothing -> [] + +-- * Data.Maybe variants + +-- | Variant of 'catMaybes' that returns 'Nothing' unless /all/ +-- elements are 'Just'. +-- +-- > map all_just [[Nothing,Just 1],[Just 0,Just 1]] == [Nothing,Just [0,1]] +all_just :: [Maybe a] -> Maybe [a] +all_just = + let rec r l = + case l of + [] -> Just (reverse r) + Nothing:_ -> Nothing + Just e:l' -> rec (e:r) l' + in rec [] + +-- * Data.Monoid variants + +-- | 'mconcat' of 'repeat', for lists this is 'cycle'. +-- +-- > [1,2,3,1,2] `isPrefixOf` take 5 (mcycle [1,2,3]) +mcycle :: Monoid a => a -> a +mcycle = mconcat . repeat + +-- * Non-SC3 Patterns + +-- | Count the number of `False` values following each `True` value. +-- +-- > countpost (map bool [1,0,1,0,0,0,1,1]) == [1,3,0,0] +countpost :: [Bool] -> [Int] +countpost = + let f i p = if null p + then [i] + else let (x:xs) = p + r = i : f 0 xs + in if not x then f (i + 1) xs else r + in tail . f 0 + +-- | Count the number of `False` values preceding each `True` value. +-- +-- > countpre (fbool [0,0,1,0,0,0,1,1]) == [2,3,0] +countpre :: [Bool] -> [Int] +countpre = + let f i p = if null p + then if i == 0 then [] else [i] + else let (x:xs) = p + r = i : f 0 xs + in if x then r else f (i + 1) xs + in f 0 + +-- | Sample and hold initial value. +-- +-- > hold [] == [] +-- > hold [1..5] == [1,1,1,1,1] +-- > hold [1,undefined] == [1,1] +hold :: [a] -> [a] +hold l = + case l of + [] -> [] + e:_ -> map (const e) l + +-- | Interleave elements from two lists. If one list ends the other +-- continues until it also ends. +-- +-- > interleave2 [1,2,3,1,2,3] [4,5,6,7] == [1,4,2,5,3,6,1,7,2,3] +-- > [1..9] `isPrefixOf` interleave2 [1,3..] [2,4..] +interleave2 :: [a] -> [a] -> [a] +interleave2 p q = + case (p,q) of + ([],_) -> q + (_,[]) -> p + (x:xs,y:ys) -> x : y : interleave2 xs ys + +-- | N-ary variant of 'interleave2', ie. 'concat' of 'transpose'. +-- +-- > interleave [whitei 'α' 0 4 3,whitei 'β' 5 9 3] == [3,7,0,8,1,6] +-- > [1..9] `isPrefixOf` interleave [[1,4..],[2,5..],[3,6..]] +interleave :: [[a]] -> [a] +interleave = concat . transpose + +-- | Remove successive duplicates. +-- +-- > rsd (stutter (repeat 2) [1,2,3]) == [1,2,3] +-- > rsd [1,2,3,1,2,3] == [1,2,3,1,2,3] +rsd :: (Eq a) => [a] -> [a] +rsd = + let f (p,_) i = (Just i,if Just i == p then Nothing else Just i) + in mapMaybe snd . scanl f (Nothing,Nothing) + +-- | Pattern where the 'tr' pattern determines the rate at which +-- values are read from the `x` pattern. For each sucessive true +-- value at 'tr' the output is a (`Just` e) of each succesive element at +-- x. False values at 'tr' generate `Nothing` values. +-- +-- > let l = trigger (map toEnum [0,1,0,0,1,1]) [1,2,3] +-- > in l == [Nothing,Just 1,Nothing,Nothing,Just 2,Just 3] +trigger :: [Bool] -> [a] -> [Maybe a] +trigger p q = + let r = countpre p + f i x = replicate i Nothing ++ [Just x] + in concat (C.zipWith_c f r q) + +-- * SC3 Patterns + +-- | Pbrown. SC3 pattern to generate psuedo-brownian motion. +-- +-- > [4,4,1,8,5] `isPrefixOf` brown 'α' 0 9 15 brown :: (Enum e,Random n,Num n,Ord n) => e -> n -> n -> n -> [n] brown e l r s = brown' e (repeat l) (repeat r) (repeat s) +-- | PdurStutter. SC3 pattern to partition a value into /n/ equal +-- subdivisions. Subdivides each duration by each stutter and yields +-- that value stutter times. A stutter of @0@ will skip the duration +-- value, a stutter of @1@ yields the duration value unaffected. +-- +-- > let {s = [1,1,1,1,1,2,2,2,2,2,0,1,3,4,0] +-- > ;d = [0.5,1,2,0.25,0.25]} +-- > in durStutter s d == [0.5,1.0,2.0,0.25,0.25] durStutter :: Fractional a => [Int] -> [a] -> [a] durStutter p = let f s d = case s of 0 -> [] 1 -> [d] _ -> replicate s (d / fromIntegral s) - in concat . C.zipWith_c f p + in concat . zipWith f p -ifF :: Bool -> a -> a -> a -ifF x y z = if x then y else z +-- | Pexprand. SC3 pattern of random values that follow a exponential +-- distribution. +-- +-- > exprand 'α' 0.0001 1 10 +exprand :: (Enum e,Random a,Floating a) => e -> a -> a -> Int -> [a] +exprand e l r n = fmap (M.exprange l r) (white e 0 1 n) -ifF' :: (Bool,a,a) -> a -ifF' (x,y,z) = if x then y else z +-- | Pfuncn. Variant of the SC3 pattern that evaluates a closure at +-- each step that has a 'StdGen' form. +funcn :: Enum e => e -> (StdGen -> (n,StdGen)) -> Int -> [n] +funcn e = funcn' (mkStdGen (fromEnum e)) -ifTruncating :: [Bool] -> [a] -> [a] -> [a] -ifTruncating a b c = map ifF' (zip3 a b c) +-- | Pgeom. 'C.geom' with arguments re-ordered. +-- +-- > geom 3 6 5 == [3,18,108,648,3888] +geom :: Num a => a -> a -> Int -> [a] +geom i s n = C.geom n i s -ifExtending :: [Bool] -> [a] -> [a] -> [a] -ifExtending a b c = map ifF' (C.zip3_c a b c) +-- | Pif. Consume values from /q/ or /r/ according to /p/. +-- +-- > if_demand [True,False,True] [1,3] [2] == [1,2,3] +if_demand :: [Bool] -> [a] -> [a] -> [a] +if_demand p q r = + case if_rec (p,q,r) of + Just (e,(p',q',r')) -> e : if_demand p' q' r' + Nothing -> [] +-- | Prand. Random elements of /p/. +-- +-- > rand' 'α' [1..9] 9 == [3,9,2,9,4,7,4,3,8] rand' :: Enum e => e -> [a] -> Int -> [a] rand' e a n = let k = length a - 1 - f m g = if m == 0 - then [] - else let (i,g') = randomR (0,k) g - in (a !! i) : f (m - 1) g' - in f n (mkStdGen (fromEnum e)) - -rorate_n' :: Num a => a -> a -> [a] -rorate_n' p i = [i * p,i * (1 - p)] - -rorate_n :: Num a => [a] -> [a] -> [a] -rorate_n p = concat . C.zipWith_c rorate_n' p - -rorate_l' :: Num a => [a] -> a -> [a] -rorate_l' p i = map (* i) p - -rorate_l :: Num a => [[a]] -> [a] -> [a] -rorate_l p = concat . C.zipWith_c rorate_l' p - -segment :: [a] -> Int -> (Int,Int) -> [a] -segment a k (l,r) = - let i = map (S.genericWrap 0 k) [l .. r] + i = white e 0 k n in map (a !!) i +-- | Pseq. 'concat' of 'replicate' of 'concat'. +-- +-- > seq' [return 1,[2,3],return 4] 2 == [1,2,3,4,1,2,3,4] +seq' :: [[a]] -> Int -> [a] +seq' l n = concat (replicate n (concat l)) + +-- | Pslide. SC3 pattern to slide over a list of values. +-- +-- > slide [1,2,3,4] 4 3 1 0 True == [1,2,3,2,3,4,3,4,1,4,1,2] +-- > slide [1,2,3,4,5] 3 3 (-1) 0 True == [1,2,3,5,1,2,4,5,1] slide :: [a] -> Int -> Int -> Int -> Int -> Bool -> [a] slide a n j s i wr = let k = length a @@ -79,24 +310,135 @@ then concat (take n (map (segment a k) (zip l r))) else error "slide: non-wrap variant not implemented" -stutterTruncating :: [Int] -> [a] -> [a] -stutterTruncating ns = concat . zipWith replicate ns - -stutterExtending :: [Int] -> [a] -> [a] -stutterExtending ns = concat . C.zipWith_c replicate ns +-- | Pstutter. Repeat each element of a pattern /n/ times. +-- +-- > stutter [1,2,3] [4,5,6] == [4,5,5,6,6,6] +-- > stutter (repeat 2) [4,5,6] == [4,4,5,5,6,6] +stutter :: [Int] -> [a] -> [a] +stutter ns = concat . zipWith replicate ns +-- | Pswitch. SC3 pattern to select elements from a list of patterns +-- by a pattern of indices. +-- +-- > let r = switch [[1,2,3,1,2,3],[65,76],[800]] [2,2,0,1] +-- > in r == [800,800,1,2,3,1,2,3,65,76] switch :: [[a]] -> [Int] -> [a] switch l i = i >>= (l !!) +-- | Pswitch1. SC3 pattern that uses a pattern of indices to select +-- which pattern to retrieve the next value from. Only one value is +-- selected from each pattern. This is in comparison to 'switch', +-- which embeds the pattern in its entirety. +-- +-- > let p = switch1 [(cycle [1,2,3]) +-- > ,(cycle [65,76]) +-- > ,repeat 8] (concat (replicate 6 [2,2,0,1])) +-- > in p == [8,8,1,65,8,8,2,76,8,8,3,65,8,8,1,76,8,8,2,65,8,8,3,76] switch1 :: [[a]] -> [Int] -> [a] switch1 ps = - let go _ [] = [] - go m (i:is) = case M.lookup i m of + let rec m l = + case l of + [] -> [] + i:l' -> case M.lookup i m of Nothing -> [] Just [] -> [] - Just (x:xs) -> x : go (M.insert i xs m) is - in go (M.fromList (zip [0..] (C.extendSequences ps))) + Just (x:xs) -> x : rec (M.insert i xs m) l' + in rec (M.fromList (zip [0..] ps)) +-- | Pwhite. SC3 pattern to generate a uniform linear distribution in +-- given range. +-- +-- > white 'α' 0 9 5 == [3,0,1,6,6] +-- +-- It is important to note that this structure is not actually +-- indeterminate, so that the below is zero. +-- +-- > white 'α' 1 9 5 == [3,9,2,9,4] +-- > let p = white 'α' 0.0 1.0 3 in zipWith (-) p p == [0,0,0] +white :: (Random n,Enum e) => e -> n -> n -> Int -> [n] +white e l r n = take_inf n (randomRs (l,r) (mkStdGen (fromEnum e))) + +-- | Pwrand. SC3 pattern to embed values randomly chosen from a list. +-- Returns one item from the list at random for each repeat, the +-- probability for each item is determined by a list of weights which +-- should sum to 1.0. +-- +-- > let w = C.normalizeSum [1,3,5] +-- > in wrand 'ζ' [[1],[2],[3,4]] w 6 == [3,4,2,2,3,4,1,3,4] +wrand :: (Enum e,Fractional n,Ord n,Random n) => + e -> [[a]] -> [n] -> Int -> [a] +wrand e a w n = concat (take_inf n (wrand' e a w)) + +-- | Pxrand. SC3 pattern that is like 'rand' but filters successive +-- duplicates. +-- +-- > xrand 'α' [return 1,[2,3],[4,5,6]] 9 == [4,5,6,2,3,4,5,6,1] +xrand :: Enum e => e -> [[a]] -> Int -> [a] +xrand e a n = take_inf n (xrand' e a) + +-- * SC3 Variant Patterns + +-- | Underlying 'brown''. +brown_ :: (RandomGen g,Random n,Num n,Ord n) => (n,n,n) -> (n,g) -> (n,g) +brown_ (l,r,s) (n,g) = + let (i,g') = randomR (-s,s) g + in (S.foldToRange l r (n + i),g') + +-- | Brown noise with list inputs. +-- +-- > let l = brown' 'α' (repeat 1) (repeat 700) (cycle [1,20]) +-- > in [415,419,420,428] `isPrefixOf` l +brown' :: (Enum e,Random n,Num n,Ord n) => e -> [n] -> [n] -> [n] -> [n] +brown' e l_ r_ s_ = + let i = (randomR (head l_,head r_) (mkStdGen (fromEnum e))) + rec (n,g) z = + case z of + [] -> [] + (l,r,s):z' -> let (n',g') = brown_ (l,r,s) (n,g) + in n' : rec (n',g') z' + in rec i (zip3 l_ r_ s_) + +-- | Underlying 'if_demand'. +if_rec :: ([Bool],[a],[a]) -> Maybe (a,([Bool],[a],[a])) +if_rec i = + case i of + (True:p,q:q',r) -> Just (q,(p,q',r)) + (False:p,q,r:r') -> Just (r,(p,q,r')) + _ -> Nothing + +-- | 'zip3' variant. +-- +-- > if_zip [True,False,True] [1,3] [2] == [1] +if_zip :: [Bool] -> [a] -> [a] -> [a] +if_zip a b c = + let f (x,y,z) = if x then y else z + in map f (zip3 a b c) + +-- | Underlying 'funcn'. +funcn' :: (RandomGen g) => g -> (g -> (n,g)) -> Int -> [n] +funcn' g_ f n = + let rec [] _ = [] + rec h g = + case h of + [] -> [] + e:h' -> let (r,g') = e g in r : rec h' g' + in rec (replicate n f) g_ + +rorate_n' :: Num a => a -> a -> [a] +rorate_n' p i = [i * p,i * (1 - p)] + +rorate_n :: Num a => [a] -> [a] -> [a] +rorate_n p = concat . zipWith rorate_n' p + +rorate_l' :: Num a => [a] -> a -> [a] +rorate_l' p i = map (* i) p + +rorate_l :: Num a => [[a]] -> [a] -> [a] +rorate_l p = concat . zipWith rorate_l' p + +-- | 'white' with pattern inputs. +-- +-- > white' 'α' (repeat 0) [9,19,9,19,9,19] == [3,0,1,6,6,15] white' :: (Enum e,Random n) => e -> [n] -> [n] -> [n] white' e l r = let g = mkStdGen (fromEnum e) @@ -104,63 +446,29 @@ f a b = let (a',b') = randomR b a in (b',a') in snd (mapAccumL f g n) -white :: (Random n,Enum e) => e -> n -> n -> Int -> [n] -white e l r n = take n (randomRs (l,r) (mkStdGen (fromEnum e))) +-- | Type-specialised ('Integral') 'white'. +-- +-- > whitei' 'α' 1 9 5 == [3,9,2,9,4] +whitei' :: (Random n,Integral n,Enum e) => e -> n -> n -> Int -> [n] +whitei' = white -wrand' :: (Enum e) =>e -> [[a]] -> [Double] -> [a] +-- | A variant of 'pwhite' that generates integral (rounded) values. +-- +-- > whitei 'α' 1 9 5 == [5,1,7,7,8] +whitei :: (Random n,S.RealFracE n,Enum e) => e -> n -> n -> Int -> [n] +whitei e l r = fmap S.floorE . white e l r + +-- | Underlying 'wrand'. +wrand' :: (Enum e,Fractional n,Ord n,Random n) => e -> [[a]] -> [n] -> [[a]] wrand' e a w = let f g = let (r,g') = R.wchoose a w g - in r ++ f g' + in r : f g' in f (mkStdGen (fromEnum e)) -wrand :: (Enum e) => e -> [[a]] -> [Double] -> Int -> [a] -wrand e a w n = take n (wrand' e a w) - +-- | Underlying 'xrand'. xrand' :: Enum e => e -> [[a]] -> [a] xrand' e a = let k = length a - 1 f j g = let (i,g') = randomR (0,k) g in if i == j then f j g' else (a !! i) ++ f i g' in f (-1) (mkStdGen (fromEnum e)) - -xrand :: Enum e => e -> [[a]] -> Int -> [a] -xrand e a n = take n (xrand' e a) - -countpost :: [Bool] -> [Int] -countpost = - let f i p = if null p - then [i] - else let (x:xs) = p - r = i : f 0 xs - in if not x then f (i + 1) xs else r - in tail . f 0 - -countpre :: [Bool] -> [Int] -countpre = - let f i p = if null p - then if i == 0 then [] else [i] - else let (x:xs) = p - r = i : f 0 xs - in if x then r else f (i + 1) xs - in f 0 - -interleave :: [a] -> [a] -> [a] -interleave p q = - case (p,q) of - ([],_) -> q - (_,[]) -> p - (x:xs,y:ys) -> x : y : interleave xs ys - -rsd :: (Eq a) => [a] -> [a] -rsd = - let f (p,_) i = (Just i,if Just i == p then Nothing else Just i) - in mapMaybe snd . scanl f (Nothing,Nothing) - --- > let tr = map toEnum [0,0,1,0,0,0,1,1] --- > in trigger tr [1,2,3] -trigger :: [Bool] -> [a] -> [Maybe a] -trigger p q = - let r = countpre p - f i x = replicate i Nothing ++ [Just x] - in concat (C.zipWith_c f r q) - diff --git a/Sound/SC3/Lang/Random/Gen.hs b/Sound/SC3/Lang/Random/Gen.hs --- a/Sound/SC3/Lang/Random/Gen.hs +++ b/Sound/SC3/Lang/Random/Gen.hs @@ -1,12 +1,13 @@ -- | 'RandomGen' based @sclang@ random number functions. module Sound.SC3.Lang.Random.Gen where -import Data.Maybe -import qualified Sound.SC3.Lang.Collection as C -import qualified Sound.SC3.Lang.Math as M +import Data.Maybe {- base -} import System.Random {- random -} import System.Random.Shuffle {- random-shuffle -} +import qualified Sound.SC3.Lang.Collection as C +import qualified Sound.SC3.Lang.Math as M + -- | @SimpleNumber.rand@ is 'randomR' in (0,/n/). rand :: (RandomGen g,Random n,Num n) => n -> g -> (n,g) rand n = randomR (0,n) @@ -57,7 +58,7 @@ exprand :: (Floating n,Random n,RandomGen g) => n -> n -> g -> (n,g) exprand l r g = let (n,g') = rrand 0.0 1.0 g - in (M.exprandrng l r n,g') + in (M.exprange l r n,g') -- | Variant of 'exprand' generating /k/ values. nexprand :: (Floating n,Random n,RandomGen g) => diff --git a/Sound/SC3/Lang/Random/IO.hs b/Sound/SC3/Lang/Random/IO.hs --- a/Sound/SC3/Lang/Random/IO.hs +++ b/Sound/SC3/Lang/Random/IO.hs @@ -1,10 +1,12 @@ -- | 'getStdRandom' based @sclang@ random number functions. module Sound.SC3.Lang.Random.IO where -import Control.Monad.IO.Class -import Sound.SC3.Lang.Random.Gen as R +import Control.Monad.IO.Class {- transformers -} import System.Random {- random -} +import Sound.SC3.Lang.Random.Gen as R + +-- | 'liftIO' of 'randomRIO'. randomM :: (Random a, MonadIO m) => (a, a) -> m a randomM = liftIO . randomRIO @@ -16,6 +18,7 @@ rand2 :: (MonadIO m,Random n,Num n) => n -> m n rand2 n = randomM (-n,n) +-- | 'liftIO' of 'getStdRandom'. randomG :: MonadIO m => (StdGen -> (a, StdGen)) -> m a randomG = liftIO . getStdRandom diff --git a/Sound/SC3/Lang/Random/Lorrain_1980.hs b/Sound/SC3/Lang/Random/Lorrain_1980.hs --- a/Sound/SC3/Lang/Random/Lorrain_1980.hs +++ b/Sound/SC3/Lang/Random/Lorrain_1980.hs @@ -1,36 +1,77 @@ --- | Denis Lorrain. \"A Panoply of Stochastic 'Cannons'\". /Computer --- Music Journal/, 4(1):53-81, Spring 1980. +-- | Denis Lorrain. +-- \"A Panoply of Stochastic \'Cannons\'\". +-- /Computer Music Journal/, 4(1):53-81, Spring 1980. module Sound.SC3.Lang.Random.Lorrain_1980 where --- | 4.3.1 (g=1) +-- | §4.3.1 (g=1) +-- +-- > import System.Random +-- > let r = take 32768 (randomRs (0.0,1.0) (mkStdGen 12345)) +-- +-- > import Sound.SC3.Plot +-- > import Sound.SC3.Plot.Histogram +-- > let h = plotHistogram . map (histogram 512) +-- +-- > h [map (linear 1.0) r] linear :: Floating a => a -> a -> a linear g u = g * (1 - sqrt u) --- | 4.3.2 (δ=[0.5,1,2]) +-- | §4.3.2 (δ=[0.5,1,2]) +-- +-- > h (map (\d -> map (exponential d) r) [0.5,1,2]) exponential :: Floating a => a -> a -> a exponential delta u = (- (log u)) / delta --- | 4.3.5 (τ=1) +-- | §4.3.5 (τ=1) +-- +-- > import Data.Maybe +-- > let narrow z n = if n < -z || n > z then Nothing else Just n +-- > h [mapMaybe (narrow 10 . cauchy 1.0) r] cauchy :: Floating a => a -> a -> a cauchy tau u = tau * tan (pi * u) --- | 4.3.5 (iopt=False,τ=1) (Algorithm 10) +-- | §4.3.5 (iopt=False,τ=1) (Algorithm 10) +-- +-- > h [mapMaybe (narrow 20 . cauchy' False 1.0) r] +-- > h [mapMaybe (narrow 20 . cauchy' True 1.0) r] cauchy' :: Floating a => Bool -> a -> a -> a cauchy' iopt tau u = let u' = if iopt then u / 2 else u u'' = pi * u' - in tau * tan u'' -- tan u'' == sin u'' / cos u'' + in tau * tan u'' -- tan n == sin n / cos n --- | 4.3.6 +-- | §4.3.6 +-- +-- > h [map hyperbolic_cosine r] hyperbolic_cosine :: Floating a => a -> a hyperbolic_cosine u = log (tan (pi * u / 2)) --- | 4.3.7 (β=0,α=1) +-- | §4.3.7 (β=0,α=1) +-- +-- > h [map (logistic 0.0 1.0) r] logistic :: Floating a => a -> a -> a -> a -logistic beta alpha u = (- beta - log (recip u - 1)) / alpha +logistic beta' alpha u = (- beta' - log (recip u - 1)) / alpha --- | 4.3.8 +-- | §4.3.8 +-- +-- > h [map arc_sine r] arc_sine :: Floating a => a -> a arc_sine u = let x = sin (pi * u / 2) in x * x + +-- | §4.4.2 (Algorithm 15) +-- +-- > let adj l = case l of {[] -> []; p:q:l' -> (p,q) : adj l'} +-- > h [mapMaybe (beta 0.5 0.5) (adj r)] +-- > h [mapMaybe (beta 0.25 0.25) (adj r)] +-- > h [mapMaybe (beta 0.75 0.5) (adj r)] +-- > h [mapMaybe (beta 0.5 0.75) (adj r)] +beta :: (Floating a,Ord a) => a -> a -> (a,a) -> Maybe a +beta a b (u1,u2) = + let ea = 1.0 / a + eb = 1.0 / b + y1 = u1 ** ea + y2 = u2 ** eb + s = y1 + y2 + in if s <= 1.0 then Just (y1 / s) else Nothing diff --git a/Sound/SC3/Lang/Random/Monad.hs b/Sound/SC3/Lang/Random/Monad.hs --- a/Sound/SC3/Lang/Random/Monad.hs +++ b/Sound/SC3/Lang/Random/Monad.hs @@ -1,8 +1,9 @@ -- | 'Rand' monad based @sclang@ random number functions. module Sound.SC3.Lang.Random.Monad where -import Control.Monad +import Control.Monad {- base -} import Control.Monad.Random {- MonadRandom -} + import qualified Sound.SC3.Lang.Math as M -- | @SimpleNumber.rand@ is 'getRandomR' in (0,/n/). @@ -64,7 +65,7 @@ exprand :: (Floating n,Random n,RandomGen g) => n -> n -> Rand g n exprand l r = do n <- rrand 0.0 1.0 - return (M.exprandrng l r n) + return (M.exprange l r n) -- | Variant of 'exprand' generating /k/ values. -- diff --git a/hsc3-lang.cabal b/hsc3-lang.cabal --- a/hsc3-lang.cabal +++ b/hsc3-lang.cabal @@ -1,11 +1,11 @@ Name: hsc3-lang -Version: 0.13 +Version: 0.14 Synopsis: Haskell SuperCollider Language Description: Haskell library defining operations from the SuperCollider language class library License: GPL Category: Sound -Copyright: (c) Rohan Drape, 2007-2012 +Copyright: (c) Rohan Drape, 2007-2013 Author: Rohan Drape Maintainer: rd@slavepianos.org Stability: Experimental @@ -19,14 +19,15 @@ Library Build-Depends: array, base == 4.*, + bifunctors, bytestring, containers, data-default, hmatrix-special, - hosc == 0.13.*, - hsc3 == 0.13.*, + hosc == 0.14.*, + hsc3 == 0.14.*, MonadRandom, - mtl, + transformers, split, random, random-shuffle, @@ -48,6 +49,7 @@ Sound.SC3.Lang.Math Sound.SC3.Lang.Math.Warp Sound.SC3.Lang.Math.Window + Sound.SC3.Lang.Pattern Sound.SC3.Lang.Pattern.ID Sound.SC3.Lang.Pattern.List Sound.SC3.Lang.Random.Lorrain_1980