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-2013, [gpl][gpl]. +© [rohan drape][rd], 2007-2014, [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,10 +3,13 @@ -- becomes @m i j c@. module Sound.SC3.Lang.Collection where -import qualified Data.List.Split as S {- split -} +import qualified Data.List.Split as L {- split -} import Data.List as L {- base -} import Data.Maybe {- base -} +import qualified Sound.SC3 as S {- hsc3 -} +import Sound.SC3.Lang.Core + -- * Collection -- | @Collection.*fill@ is 'map' over indices to /n/. @@ -77,21 +80,21 @@ -- -- > any' (\i _ -> even i) [1,2,3,4] == True any' :: Integral i => (a -> i -> Bool) -> [a] -> Bool -any' f = isJust . detect f +any' = isJust .: detect -- | @Collection.every@ is 'True' if /f/ applies at all elements. -- -- > every (\i _ -> even i) [1,2,3,4] == False every :: Integral i => (a -> i -> Bool) -> [a] -> Bool every f = - let g e = not . f e + let g = not .: f in not . any' g --- | @Collection.count@ is 'length' '.' 'select'. +-- | @Collection.count@ is 'length' of 'select'. -- -- > count (\i _ -> even i) [1,2,3,4] == 2 count :: Integral i => (a -> i -> Bool) -> [a] -> i -count f = genericLength . select f +count = genericLength .: select -- | @Collection.occurencesOf@ is an '==' variant of 'count'. -- @@ -100,23 +103,23 @@ occurencesOf :: (Integral i,Eq a) => a -> [a] -> i occurencesOf k = count (\e _ -> e == k) --- | @Collection.sum@ is 'sum' '.' 'collect'. +-- | @Collection.sum@ is 'sum' of 'collect'. -- -- > sum' (ignoringIndex (* 2)) [1,2,3,4] == 20 sum' :: (Num a,Integral i) => (b -> i -> a) -> [b] -> a -sum' f = sum . collect f +sum' = sum .: collect --- | @Collection.maxItem@ is 'maximum' '.' 'collect'. +-- | @Collection.maxItem@ is 'maximum' of 'collect'. -- -- > maxItem (ignoringIndex (* 2)) [1,2,3,4] == 8 maxItem :: (Ord b,Integral i) => (a -> i -> b) -> [a] -> b -maxItem f = maximum . collect f +maxItem = maximum .: collect -- | @Collection.minItem@ is 'maximum' '.' 'collect'. -- -- > minItem (ignoringIndex (* 2)) [1,2,3,4] == 2 minItem :: (Integral i,Ord b) => (a -> i -> b) -> [a] -> b -minItem f = minimum . collect f +minItem = minimum .: collect -- | Variant of 'zipWith' that cycles the shorter input. -- @@ -250,7 +253,7 @@ -- | 'fromJust' variant of 'indexOf'. indexOf' :: Eq a => [a] -> a -> Int -indexOf' l = fromJust . indexOf l +indexOf' = fromJust .: indexOf -- | @SequenceableCollection.indexOfEqual@ is just 'indexOf'. indexOfEqual :: Eq a => [a] -> a -> Maybe Int @@ -276,8 +279,10 @@ in maybe (size l - 1) f (indexOfGreaterThan e l) -- | @SequenceableCollection.indexInBetween@ is the linearly --- interpolated fractional index. +-- interpolated fractional index. Collection must be sorted. The +-- inverse operation is 'blendAt'. -- +-- > > [2,3,5,6].indexInBetween(5.2) == 2.2 -- > indexInBetween 5.2 [2,3,5,6] == 2.2 indexInBetween :: (Ord a,Fractional a) => a -> [a] -> a indexInBetween e l = @@ -412,7 +417,7 @@ -- > > [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 = S.chunksOf +clump = L.chunksOf -- | @SequenceableCollection.clumps@ is a synonym for -- 'Data.List.Split.splitPlaces'. @@ -428,6 +433,47 @@ [] -> [] _ -> f (cycle m) s +-- | 'blendAt' with @clip@ function as argument. +blendAtBy :: (Integral i,RealFrac n) => (i -> t -> n) -> n -> t -> n +blendAtBy f ix c = + let m = floor ix + m' = fromIntegral m + in blend (absdif ix m') (f m c) (f (m + 1) c) + +-- | @SequenceableCollection.blendAt@ returns a linearly interpolated +-- value between the two closest indices. Inverse operation is +-- 'indexInBetween'. +-- +-- > > [2,5,6].blendAt(0.4) == 3.2 +-- +-- > blendAt 0 [2,5,6] == 2 +-- > blendAt 0.4 [2,5,6] == 3.2 +blendAt :: RealFrac a => a -> [a] -> a +blendAt = blendAtBy clipAt + +-- | Resampling function, /n/ is destination length, /r/ is source +-- length, /f/ is the indexing function, /c/ is the collection. +resamp1_gen :: (Integral i,RealFrac n) => i -> i -> (i -> t -> n) -> t -> i -> n +resamp1_gen n r f c = + let n' = fromIntegral n + fwd = (fromIntegral r - 1) / (n' - 1) + gen i = blendAtBy f (fromIntegral i * fwd) c + in gen + +-- | @SequenceableCollection.resamp1@ returns a new collection of the +-- desired length, with values resampled evenly-spaced from the +-- receiver with linear interpolation. +-- +-- > > [1,2,3,4].resamp1(12) +-- > > [1,2,3,4].resamp1(3) == [1,2.5,4] +-- +-- > resamp1 12 [1,2,3,4] +-- > resamp1 3 [1,2,3,4] == [1,2.5,4] +resamp1 :: (Enum n,RealFrac n) => Int -> [n] -> [n] +resamp1 n c = + let gen = resamp1_gen n (length c) clipAt c + in map gen [0 .. n - 1] + -- * List and Array -- | @List.lace@ is a concatenated transposition of cycled @@ -490,6 +536,37 @@ let n = sum l in map (/ n) l +-- | @ArrayedCollection.normalize@ returns a new Array with the receiver +-- items normalized between min and max. +-- +-- > > [1,2,3].normalize == [0,0.5,1] +-- > > [1,2,3].normalize(-20,10) == [-20,-5,10] +-- +-- > normalize 0 1 [1,2,3] == [0,0.5,1] +-- > normalize (-20) 10 [1,2,3] == [-20,-5,10] +normalize :: (S.TernaryOp b,Fractional b, Ord b) => b -> b -> [b] -> [b] +normalize l r c = + let cl = minimum c + cr = maximum c + in map (\e -> S.linlin e cl cr l r) c + +-- | @ArrayedCollection.asRandomTable@ returns an integral table that +-- can be used to generate random numbers with a specified +-- distribution. +-- +-- > > [1,0,1,0,1,0,1].asRandomTable(256).plot +-- > > ((0..100) ++ (100..50) / 100).asRandomTable.plot +-- +-- > import Sound.SC3.Plot +-- > plotTable [asRandomTable 256 [1,0,1,0,1,0,1]] +-- > plotTable [asRandomTable 256 (map (/ 100) ([0..100] ++ [100,99..50]))] +asRandomTable :: (S.TernaryOp a,Enum a, RealFrac a) => Int -> [a] -> [a] +asRandomTable n c = + let n' = fromIntegral n + a = integrate (resamp1 n c) + b = normalize 0 (n' - 1) a + in map (\i -> indexInBetween i b / n') [0 .. n' - 1] + -- | @List.slide@ is an identity window function with subsequences of -- length /w/ and stride of /n/. -- @@ -636,3 +713,91 @@ to_wavetable = let f (e0,e1) = (2 * e0 - e1,e1 - e0) in t2_concat . map f . t2_overlap . (++ [0]) + +-- | Variant of 'sineFill' that gives each component table. +-- +-- > let t = sineGen 1024 (map recip [1,2,3,5,8,13,21,34,55]) (replicate 9 0) +-- > map length t == replicate 9 1024 +-- +-- > import Sound.SC3.Plot +-- > plotTable t +sineGen :: (Floating n,Enum n) => Int -> [n] -> [n] -> [[n]] +sineGen n = + let incr = (2 * pi) / fromIntegral n + ph partial = take n [0,incr * fromIntegral partial ..] + f h amp iph = map (\z -> sin (z + iph) * amp) (ph h) + in zipWith3 f [1..] + +-- | @Signal.*sineFill@ is a table generator. Frequencies are +-- partials, amplitudes and initial phases are as given. Result is +-- normalised. +-- +-- > let t = let a = [[21,5,34,3,2,13,1,8,55] +-- > ,[13,8,55,34,5,21,3,1,2] +-- > ,[55,34,1,3,2,13,5,8,21]] +-- > in map (\amp -> sineFill 1024 (map recip amp) (replicate 9 0)) a +-- +-- > import Sound.SC3.Plot +-- > plotTable t +sineFill :: (S.TernaryOp n,Ord n,Floating n,Enum n) => Int -> [n] -> [n] -> [n] +sineFill n amp iph = + let t = sineGen n amp iph + in normalize (-1) 1 (map sum (transpose t)) + +-- * Required + +-- | /z/ ranges from 0 (for /i/) to 1 (for /j/). +-- +-- > > 1.5.blend(2.0,0.50) == 1.75 +-- > > 1.5.blend(2.0,0.75) == 1.875 +-- +-- > blend 0.50 1.5 2 == 1.75 +-- > blend 0.75 1.5 2 == 1.875 +blend :: Num a => a -> a -> a -> a +blend z i j = i + (z * (j - i)) + +-- | Variant of '(!!)' but values for index greater than the size of +-- the collection will be clipped to the last index. +clipAt :: Int -> [a] -> a +clipAt ix c = + if ix > length c - 1 + then L.last c + else c !! ix + +-- | 'abs' of '(-)'. +absdif :: Num a => a -> a -> a +absdif i j = abs (j - i) + +-- * Variants + +-- | Variant where all inputs are lists and the result is not +-- catentated. Does not generate partial windows. +-- +-- > let r = ["abc","bc","def","ef","ghi","hi"] +-- > in slide1 (cycle [3,2]) (cycle [1,2]) ['a'..'i'] == r +-- +-- > let r = ["abc","bc","bcd","cd","cde","de"] +-- > in slide1 (cycle [3,2]) (cycle [1,0]) ['a'..'e'] == r +slide1 :: Integral i => [i] -> [i] -> [a] -> [[a]] +slide1 w n l = + case (w,n,l) of + (w0:w',n0:n',_) -> case genericTakeMaybe w0 l of + Nothing -> [] + Just r -> let l' = genericDrop n0 l + in r : slide1 w' n' l' + _ -> [] + +-- | 'concat' of 'slide1'. +slide2 :: Integral i => [i] -> [i] -> [a] -> [a] +slide2 = concat .:: slide1 + +-- | Variant where stutter input is a list and the result is not +-- catentated. +-- +-- > stutter1 [2,1,2] [1,2,3] == [[1,1],[2],[3,3]] +stutter1 :: Integral i => [i] -> [a] -> [[a]] +stutter1 = zipWith genericReplicate + +-- | 'concat' of 'stutter1'. +stutter2 :: Integral i => [i] -> [a] -> [a] +stutter2 = concat .: stutter1 diff --git a/Sound/SC3/Lang/Collection/Array.hs b/Sound/SC3/Lang/Collection/Array.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Collection/Array.hs @@ -0,0 +1,31 @@ +-- | 'A.Array' variants of "Sound.SC3.Lang.Collection". +module Sound.SC3.Lang.Collection.Array where + +import qualified Data.Array as A {- array -} + +import qualified Sound.SC3.Lang.Collection as C + +-- | 'C.clipAt'. +clipAt :: Int -> A.Array Int a -> a +clipAt ix c = + let (l,r) = A.bounds c + f = (A.!) c + in if ix < l then f l else if ix > r then f r else f ix + +-- | 'C.blendAtBy' of 'clipAt'. +-- +-- > blendAt 0 (A.listArray (0,2) [2,5,6]) == 2 +-- > blendAt 0.4 (A.listArray (0,2) [2,5,6]) == 3.2 +blendAt :: RealFrac a => a -> A.Array Int a -> a +blendAt = C.blendAtBy clipAt + +-- | 'C.resamp1'. +-- +-- > resamp1 12 (A.listArray (0,3) [1,2,3,4]) +-- > resamp1 3 (A.listArray (0,3) [1,2,3,4]) == A.listArray (0,2) [1,2.5,4] +resamp1 :: (Enum n,RealFrac n) => Int -> A.Array Int n -> A.Array Int n +resamp1 n c = + let (_,r) = A.bounds c + gen = C.resamp1_gen n (r + 1) clipAt c + rs = map gen [0 .. n - 1] + in A.listArray (0,n - 1) rs diff --git a/Sound/SC3/Lang/Collection/Numerical/Extending.hs b/Sound/SC3/Lang/Collection/Numerical/Extending.hs --- a/Sound/SC3/Lang/Collection/Numerical/Extending.hs +++ b/Sound/SC3/Lang/Collection/Numerical/Extending.hs @@ -23,6 +23,28 @@ signum = map signum fromInteger n = [fromInteger n] +instance Real a => Real [a] where + toRational = error "[Real], toRational" + +instance Enum a => Enum [a] where + succ = map succ + pred = map pred + toEnum = return . toEnum + fromEnum = error "[Enum], fromEnum" + enumFrom = error "[Enum]" + enumFromThen = error "[Enum]" + enumFromTo = error "[Enum]" + enumFromThenTo = error "[Enum]" + +instance Integral a => Integral [a] where + quot = zipWith_c quot + rem = zipWith_c rem + div = zipWith_c div + mod = zipWith_c mod + quotRem = error "[Integral] is partial" + divMod = error "[Integral] is partial" + toInteger = error "[Integral] is partial" + instance Fractional a => Fractional [a] where recip = map recip (/) = zipWith_c (/) diff --git a/Sound/SC3/Lang/Collection/Numerical/Truncating.hs b/Sound/SC3/Lang/Collection/Numerical/Truncating.hs --- a/Sound/SC3/Lang/Collection/Numerical/Truncating.hs +++ b/Sound/SC3/Lang/Collection/Numerical/Truncating.hs @@ -45,8 +45,3 @@ asinh = map asinh acosh = map acosh atanh = map atanh - -{- -[1,2,3] * [4,5] -[1,2,3] * 2 --} diff --git a/Sound/SC3/Lang/Collection/Vector.hs b/Sound/SC3/Lang/Collection/Vector.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Collection/Vector.hs @@ -0,0 +1,30 @@ +-- | 'V.Vector' variants of "Sound.SC3.Lang.Collection". +module Sound.SC3.Lang.Collection.Vector where + +import qualified Data.Vector as V {- vector -} + +import qualified Sound.SC3.Lang.Collection as C + +-- | 'C.clipAt'. +clipAt :: Int -> V.Vector a -> a +clipAt ix c = + let r = V.length c + f = (V.!) c + in if ix > r - 1 then f (r - 1) else f ix + +-- | 'C.blendAtBy' of 'clipAt'. +-- +-- > blendAt 0 (V.fromList [2,5,6]) == 2 +-- > blendAt 0.4 (V.fromList [2,5,6]) == 3.2 +-- > blendAt 2.1 (V.fromList [2,5,6]) == 6 +blendAt :: RealFrac a => a -> V.Vector a -> a +blendAt = C.blendAtBy clipAt + +-- | 'C.resamp1'. +-- +-- > resamp1 12 (V.fromList [1,2,3,4]) +-- > resamp1 3 (V.fromList [1,2,3,4]) == V.fromList [1,2.5,4] +resamp1 :: (Enum n,RealFrac n) => Int -> V.Vector n -> V.Vector n +resamp1 n c = + let gen = C.resamp1_gen n (V.length c) clipAt c + in V.generate n gen 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 @@ -2,26 +2,45 @@ module Sound.SC3.Lang.Control.Duration where import Data.Maybe {- base -} +import Data.Ratio {- base -} --- * Durational +-- * Duration --- | Values that have duration. +-- | There are three parts to a duration: -- --- @occ@ is the interval from the start through to the end of the --- current event, ie. the time span the event /occupies/. +-- 'delta' is the /logical/ or /notated/ duration. -- --- @delta@ is the interval from the start of the current event to the --- start of the next /sequential/ event. +-- 'occ' is the /sounding/ duration, the interval that a value +-- actually occupies in time. If 'occ' '<' 'delta' there will be a +-- /hole/, if 'occ' '>' 'delta' there will be an /overlap/. -- --- @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 +-- 'fwd' is the /forward/ duration, the interval to the start time of +-- the next value in the sequence, which may be /parallel/ to the +-- current value. Ordinarily 'fwd' is either 'delta' or @0@. +class Duration d where delta :: d -> Double - delta = occ + occ :: d -> Double + occ = delta fwd :: d -> Double - fwd = occ + fwd = delta +instance Duration Int where delta = fromIntegral +instance Duration Integer where delta = fromIntegral +instance Duration Float where delta = realToFrac +instance Duration Double where delta = id +instance Integral i => Duration (Ratio i) where delta = realToFrac + +{- FlexibleInstances +instance Real i => Duration (i,i,i) where + delta (i,_,_) = realToFrac i + occ (_,i,_) = realToFrac i + fwd (_,_,i) = realToFrac i +-} + +-- | Composite of 'delta', 'occ', and 'fwd'. +duration :: Duration d => d -> (Double,Double,Double) +duration d = (delta d,occ d,fwd d) + -- * Dur -- | Variant of the @SC3@ 'Duration' model. @@ -41,9 +60,9 @@ } deriving (Eq,Show) -instance Durational Dur where - occ d = fromMaybe (delta d * legato d) (sustain' d) +instance Duration Dur where delta d = fromMaybe (dur d * stretch d * (60 / tempo d)) (delta' d) + occ d = fromMaybe (delta d * legato d) (sustain' d) fwd d = maybe (delta d) (* stretch d) (fwd' d) -- | Default 'Dur' value, equal to one second. 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 @@ -11,6 +11,7 @@ import System.Random {- base -} import qualified Sound.SC3.Lang.Collection as C +import Sound.SC3.Lang.Core 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 @@ -228,7 +229,7 @@ floatDigits = f_atf floatDigits floatRange = f_atf floatRange decodeFloat = f_atf decodeFloat - encodeFloat i = F_Double . encodeFloat i + encodeFloat = F_Double .: encodeFloat exponent = f_atf exponent significand = f_uop significand scaleFloat i = f_uop (scaleFloat i) @@ -248,9 +249,9 @@ 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) + enumFromThen = f_atf2 (map F_Double .: enumFromThen) + enumFromTo = f_atf2 (map F_Double .: enumFromTo) + enumFromThenTo = f_atf3 (map F_Double .:: enumFromThenTo) toEnum = F_Double . fromIntegral instance Random Field where @@ -697,7 +698,7 @@ -- | Transform (productively) an 'Event_Seq' into an 'NRT' score. -- -- > let {n1 = nrt_bundles (e_nrt (Event_Seq (replicate 5 mempty))) --- > ;n2 = take 10 (nrt_bundles (e_nrt (Event_Seq (repeat mempty))))} +-- > ;n2 = take 11 (nrt_bundles (e_nrt (Event_Seq (repeat mempty))))} -- > in n1 == n2 e_nrt :: Event_Seq -> NRT e_nrt = @@ -706,18 +707,14 @@ [] -> 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 + g0 = Bundle 0 [g_new [(1,AddToTail,0)]] + in NRT . (g0 :) . 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) +e_play = play . e_nrt -instance Audible Event_Seq where play = e_play +instance Audible Event_Seq where play_at _ = e_play -- * Aliases 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 @@ -2,7 +2,7 @@ module Sound.SC3.Lang.Control.Instrument where import Data.Default {- data-default -} -import Sound.SC3.ID {- hsc3 -} +import Sound.SC3 {- hsc3 -} -- | An 'Instr' is either a 'Synthdef' or the 'String' naming a -- 'Synthdef'. 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,16 +1,11 @@ --- | For a single input controller, key events always arrive in --- 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. +-- | Trivial midi functions. module Sound.SC3.Lang.Control.Midi where -import qualified Control.Exception as E {- base -} -import Control.Monad {- base -} -import Control.Monad.IO.Class {- transformers -} -import Control.Monad.Trans.State {- transformers -} +import Control.Exception {- base -} import Data.Bits {- base -} import qualified Data.ByteString.Lazy as B {- bytestring -} import qualified Data.Map as M {- containers -} +import Data.Maybe {- base -} import Sound.OSC.FD {- hosc -} -- * Bits @@ -129,58 +124,66 @@ -- | @SC3@ node identifiers are integers. type Node_Id = Int --- | Map of allocated 'Node_Id's. -data K a = K (M.Map (a,a) Node_Id) Node_Id +-- | Map of allocated 'Node_Id's. For a single input controller, key +-- events always arrive in 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. +data KY a = KY (M.Map a Node_Id) Node_Id --- | 'StateT' of 'K' specialised to 'Int'. -type KT = StateT (K Int) IO +-- | Initialise 'KY' with starting 'Node_Id'. +ky_init :: Node_Id -> KY a +ky_init = KY M.empty --- | Initialise 'K' with starting 'Node_Id'. -k_init :: Node_Id -> K a -k_init = K M.empty +-- | 'KY' 'Node_Id' allocator. +ky_alloc :: Ord a => KY a -> a -> (KY a,Node_Id) +ky_alloc (KY m i) n = (KY (M.insert n i m) (i + 1),i) --- | 'K' 'Node_Id' allocator. -k_alloc :: (Int,Int) -> KT Node_Id -k_alloc n = do - (K m i) <- get - put (K (M.insert n i m) (i + 1)) - return i +-- | 'KY' 'Node_Id' removal. +ky_free :: Ord a => KY a -> a -> (KY a,Node_Id) +ky_free (KY m i) n = + let r = m M.! n + in (KY (M.delete n m) i,r) --- | 'K' 'Node_Id' retrieval. -k_get :: (Int,Int) -> KT Node_Id -k_get n = do - (K m _) <- get - return (m M.! n) +-- | Lookup 'Node_Id'. +ky_get :: Ord a => KY a -> a -> Node_Id +ky_get (KY m _) n = m M.! n --- * IO +-- | All 'Node_Id'. +ky_all :: KY a -> [Node_Id] +ky_all (KY m _) = M.foldl (flip (:)) [] m --- | 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@. -type Midi_Receiver m n = Midi_Message n -> Int -> m () +-- * IO (midi-osc) --- | Parse incoming midi messages, do 'K' allocation, and run --- 'Midi_Receiver'. -midi_act :: Midi_Receiver IO Int -> Message -> StateT (K Int) IO () -midi_act f o = do +type Midi_Init_f st = (UDP -> IO st) + +-- | 'Midi_Recv_f' is passed the @SC3@ connection, the user state, a +-- 'Midi_Message' and, for 'Note_On' and 'Note_Off' messages, a +-- 'Node_Id'. +type Midi_Recv_f st = UDP -> st -> Midi_Message Int -> IO st + +-- | Parse incoming midi messages and run 'Midi_Receiver'. +midi_act :: Midi_Recv_f st -> UDP -> st -> Message -> IO st +midi_act recv_f fd st o = do let m = parse_m o - n <- case m of - Note_Off ch k _ -> k_get (ch,k) - Note_On ch k _ -> k_alloc (ch,k) - _ -> return (-1) - liftIO (f m n) + st' <- recv_f fd st m + return st' --- | Run midi system, handles 'E.AsyncException's. -start_midi :: (UDP -> Midi_Receiver IO Int) -> IO () -start_midi receiver = do - s_fd <- openUDP "127.0.0.1" 57110 -- midi-osc +-- | Connect to @midi-osc@ and @sc3@, run initialiser, and then +-- receiver for each incoming message. +run_midi :: Midi_Init_f st -> Midi_Recv_f st -> IO () +run_midi init_f recv_f = do m_fd <- openUDP "127.0.0.1" 57150 -- midi-osc + s_fd <- openUDP "127.0.0.1" 57110 -- scsynth 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)) >> - close m_fd >> - close s_fd - runs = void (runStateT (forever step) (k_init 1000)) - E.catch runs ex - return () + init_st <- init_f s_fd + finally + (iterateM_ init_st (\st -> recvMessage m_fd >>= + midi_act recv_f s_fd st . fromJust)) + (sendMessage m_fd (Message "/receive" [Int32 (-1)])) + +-- * Monad + +iterateM_ :: (Monad m) => st -> (st -> m st) -> m () +iterateM_ st f = do + st' <- f st + iterateM_ st' f diff --git a/Sound/SC3/Lang/Control/Midi/ST.hs b/Sound/SC3/Lang/Control/Midi/ST.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Control/Midi/ST.hs @@ -0,0 +1,82 @@ +-- | Maintain midi state, query functions. +module Sound.SC3.Lang.Control.Midi.ST where + +import Control.Concurrent {- base -} +import qualified Data.Map as M {- containers -} + +import Sound.SC3.Lang.Control.Midi {- hsc3-lang -} + +type Midi_7bit = Int +type Midi_Note = Midi_7bit +type Midi_Velocity = Midi_7bit +type Midi_Program = Midi_7bit +type Midi_CC_Ix = Midi_7bit +type Midi_CC_Value = Midi_7bit + +type Midi_Key_Map = M.Map Midi_Note Midi_Velocity +type Midi_CC_Map = M.Map Midi_CC_Ix Midi_CC_Value + +type Midi_State = MVar (Midi_Key_Map,Midi_Program,Midi_CC_Map) + +st_edit_km :: Midi_State -> (Midi_Note,Midi_Velocity) -> IO Midi_State +st_edit_km mv (k,v) = + let f (m,p,c) = (if v == 0 then M.delete k m else M.insert k v m,p,c) + in modifyMVar_ mv (return . f) >> return mv + +st_edit_cc :: Midi_State -> (Midi_CC_Ix,Midi_CC_Value) -> IO Midi_State +st_edit_cc mv (k,v) = + let f (m,p,c) = (m,p,M.insert k v c) + in modifyMVar_ mv (return . f) >> return mv + +st_edit_pc :: Midi_State -> Midi_Program -> IO Midi_State +st_edit_pc mv p = + let f (m,_,c) = (m,p,c) + in modifyMVar_ mv (return . f) >> return mv + +p3_fst :: (t,u,v) -> t +p3_fst (t,_,_) = t + +p3_third :: (t,u,v) -> v +p3_third (_,_,v) = v + +st_access_km :: (Midi_Key_Map -> r) -> Midi_State -> IO r +st_access_km f mv = withMVar mv (return . f . p3_fst) + +st_access_cc :: (Midi_CC_Map -> r) -> Midi_State -> IO r +st_access_cc f mv = withMVar mv (return . f . p3_third) + +st_read_note :: Midi_State -> Midi_Note -> IO (Maybe Midi_Velocity) +st_read_note st k = st_access_km (M.lookup k) st + +st_read_cc :: Midi_State -> Midi_CC_Ix -> IO Midi_CC_Value +st_read_cc st k = st_access_cc (M.findWithDefault 0 k) st + +st_chord :: Midi_State -> IO [Midi_Note] +st_chord = st_access_km (map fst . M.toAscList) + +st_init_f :: Midi_State -> Midi_Init_f Midi_State +st_init_f v _ = return v + +st_recv_f :: Midi_Recv_f Midi_State +st_recv_f _ st msg = + case msg of + Note_Off _ j _ -> st_edit_km st (j,0) + Note_On _ j k -> st_edit_km st (j,k) + Control_Change _ j k -> st_edit_cc st (j,k) + Program_Change _ j -> st_edit_pc st j + _ -> print msg >> return st + +st_run :: IO (Midi_State,ThreadId) +st_run = do + v <- newMVar (M.empty,0,M.empty) + th <- forkIO (run_midi (st_init_f v) st_recv_f) + return (v,th) + +{- +(st,th) <- st_run +st_chord st +readMVar st +st_read_note 55 st +st_read_cc 0 st +killThread th +-} 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 @@ -5,34 +5,75 @@ -- and calculate inter-onset times and durations. There are variants -- for different graph constructors, and to allow for a -- post-processing stage. +-- +-- Here the implementation of texture adds sumOut nodes at bus 0 to +-- the head of group 1, post-processing adds a replaceOut node at bus +-- 0 to the tail of group 1. module Sound.SC3.Lang.Control.OverlapTexture where -import Control.Applicative {- base -} import Data.List {- base -} +import Data.Hashable {- hashable -} + import Sound.OSC {- hosc -} import Sound.SC3 {- hsc3 -} -import Sound.SC3.Lang.Control.Event -import Sound.SC3.Lang.Control.Instrument -import Sound.SC3.Lang.Pattern.ID +-- * Envelope +-- | Envelope defined by /sustain/ and /transition/ times. +type Env_ST n = (n,n) + +-- | Location in node tree, given as (/group/,/bus/). +type Loc_GB = (Int,UGen) + -- | Make an 'envGen' 'UGen' with 'envLinen'' structure with given --- /sustain/ and /transition/ times. -mk_env :: UGen -> UGen -> UGen -mk_env s t = +-- by 'Env_ST'. +mk_env :: Env_ST UGen -> UGen +mk_env (s,t) = let c = EnvNum 4 p = envLinen' t s t 1 (c,c,c) in envGen KR 1 1 0 1 RemoveSynth p --- | Apply 'mk_env' envelope to input signal and write to output bus @0@. -with_env_u :: UGen -> UGen -> UGen -> UGen -with_env_u g a = out 0 . (*) g . mk_env a +-- | Add multiplier stage and 'out' UGen writing to /bus/. +with_env_u :: UGen -> UGen -> Env_ST UGen -> UGen +with_env_u bus sig = out bus . (* sig) . mk_env -- | Variant of 'with_env_u' where envelope parameters are lifted from -- 'Double' to 'UGen'. -with_env :: (Double,Double) -> UGen -> UGen -with_env (s,t) g = with_env_u g (constant s) (constant t) +with_env :: UGen -> Env_ST Double -> UGen -> UGen +with_env bus (s,t) sig = with_env_u bus sig (constant s,constant t) +gen_nm :: UGen -> String +gen_nm = show . hash . show + +-- | Generate 'Synthdef', perhaps with envelope parameters for +-- 'with_env', and a continuous signal. +gen_synth :: UGen -> Maybe (Env_ST Double) -> UGen -> Synthdef +gen_synth bus k g = + let g' = maybe (out bus g) (flip (with_env bus) g) k + in synthdef (gen_nm g) g' + +-- | Require envelope. +gen_synth' :: UGen -> Env_ST Double -> UGen -> Synthdef +gen_synth' bus k = gen_synth bus (Just k) + +-- | Schedule 'Synthdef' at indicated intervals. Synthdef is sent once at time zero. +nrt_sy1 :: Int -> Synthdef -> [Double] -> NRT +nrt_sy1 grp sy dur = + let tm = dx_d' dur + f t = bundle t [s_new0 (synthdefName sy) (-1) AddToHead grp] + in NRT (bundle 0 [d_recv sy] : map f tm) + +-- | Schedule 'Synthdef's at indicated intervals. Synthdef is sent in +-- activation bundle. +nrt_sy :: Int -> [Synthdef] -> [Time] -> NRT +nrt_sy grp sy dur = + let tm = dx_d' dur + f t s = bundle t [d_recv s + ,s_new0 (synthdefName s) (-1) AddToHead grp] + in NRT (zipWith f tm sy) + +-- * Overlap texture + -- | Control parameters for 'overlapTextureU' and related functions. -- Components are: 1. sustain time, 2. transition time, 3. number of -- overlaping (simultaneous) nodes and 4. number of nodes altogether. @@ -47,142 +88,148 @@ -- | Extract envelope parameters (sustain and transition times) for -- 'with_env' from 'OverlapTexture'. -overlapTexture_env :: OverlapTexture -> (Double,Double) +overlapTexture_env :: OverlapTexture -> Env_ST Double overlapTexture_env (s,t,_,_) = (s,t) --- | (/legato/,/duration/) parameters. The /duration/ is the --- inter-offset time, /legato/ is the scalar giving the sounding time --- in relation to the inter-offset time. -type Texture_DT = (Double,Double) +-- | Inter-offset time given 'OverlapTexture'. +-- +-- > overlapTexture_iot (3,1,5,maxBound) == 1 +overlapTexture_iot :: OverlapTexture -> Double +overlapTexture_iot (s,t,o,_) = (t + s + t) / o --- | Extract /legato/ (duration of sound proportional to inter-offset --- time) and /duration/ (inter-offset time) parameters from --- 'OverlapTexture'. +-- | Generate an 'NRT' score from 'OverlapTexture' control +-- parameters and a continuous signal. +overlapTexture_nrt :: Loc_GB -> OverlapTexture -> UGen -> NRT +overlapTexture_nrt (grp,bus) k g = + let s = gen_synth' bus (overlapTexture_env k) g + d = overlapTexture_iot k + (_,_,_,c) = k + in nrt_sy1 grp s (replicate c d) + +-- | 'audition' of 'overlapTexture_nrt'. -- --- > overlapTexture_dt (3,1,5,maxBound) == (5,1) -overlapTexture_dt :: OverlapTexture -> Texture_DT -overlapTexture_dt (s,t,o,_) = (o,(t + s + t) / o) +-- > import Sound.SC3.ID +-- > import Sound.SC3.Lang.Control.OverlapTexture +-- > +-- > let {o = sinOsc AR (rand 'α' 440 880) 0 +-- > ;u = pan2 o (rand 'β' (-1) 1) (rand 'γ' 0.1 0.2)} +-- > in overlapTextureU (3,1,6,9) u +overlapTextureU :: OverlapTexture -> UGen -> IO () +overlapTextureU t = audition . overlapTexture_nrt (1,0) t +-- * XFade texture + -- | Control parameters for 'xfadeTextureU' and related functions. -- Components are: 1. sustain time, 2. transition time, 3. number of --- nodes instatiated altogether. +-- nodes instantiated altogether. type XFadeTexture = (Double,Double,Int) -- | Extract envelope parameters for 'with_env' from 'XFadeTexture'. -xfadeTexture_env :: XFadeTexture -> (Double,Double) +xfadeTexture_env :: XFadeTexture -> Env_ST Double xfadeTexture_env (s,t,_) = (s,t) --- | Extract /legato/ and /duration/ paramaters from 'XFadeTexture'. -xfadeTexture_dt :: XFadeTexture -> Texture_DT -xfadeTexture_dt (s,t,_) = let r = t + s in ((r + t) / r,r) - --- | Generate 'Synthdef' from envelope parameters for 'with_env' and --- a continuous signal. -gen_synth :: (Double,Double) -> UGen -> Synthdef -gen_synth k g = - let n = show (hashUGen g) - g' = with_env k g - in synthdef n g' +-- | Inter-offset time from 'XFadeTexture'. +xfadeTexture_iot :: XFadeTexture -> Double +xfadeTexture_iot (s,t,_) = s + t --- | 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 - in pbind [(K_instr,pinstr' (Instr_Def s False)) - ,(K_dur,pn (return (F_Double d)) c) - ,(K_legato,pure (F_Double l))] +-- | Generate an 'NRT' score from 'XFadeTexture' control parameters +-- and a continuous signal. +xfadeTexture_nrt :: Loc_GB -> XFadeTexture -> UGen -> NRT +xfadeTexture_nrt (grp,bus) k g = + let s = gen_synth' bus (xfadeTexture_env k) g + d = xfadeTexture_iot k + (_,_,c) = k + in nrt_sy1 grp s (replicate c d) --- | Audition pattern given by 'overlapTextureP'. +-- | 'audition' of 'xfadeTexture_nrt'. -- --- > import Sound.SC3.ID --- > import Sound.SC3.Lang.Control.OverlapTexture --- > -- > let {o = sinOsc AR (rand 'α' 440 880) 0 -- > ;u = pan2 o (rand 'β' (-1) 1) (rand 'γ' 0.1 0.2)} --- > in overlapTextureU (3,1,6,9) u -overlapTextureU :: OverlapTexture -> UGen -> IO () -overlapTextureU k = audition . overlapTextureP k +-- > in xfadeTextureU (1,3,6) u +xfadeTextureU :: XFadeTexture -> UGen -> IO () +xfadeTextureU t = audition . xfadeTexture_nrt (1,0) t +-- * Spawn texture + +-- | Duration a function of the iteration number. +type Spawn_Texture = (Int -> Double,Int) + +-- | Generate an 'NRT' score from 'OverlapTexture' control parameters +-- and a continuous signal. +spawnTexture_nrt :: Loc_GB -> Spawn_Texture -> UGen -> NRT +spawnTexture_nrt (grp,bus) (t,c) g = nrt_sy1 grp (gen_synth bus Nothing g) (map t [0 .. c - 1]) + +-- | 'audition' 'spawnTexture_nrt'. +spawnTextureU :: Spawn_Texture -> UGen -> IO () +spawnTextureU sp = audition . spawnTexture_nrt (1,0) sp + +-- * Post-process + +type PP_Bus = Either UGen (UGen,UGen) + -- | Generate 'Synthdef' from a signal processing function over the --- indicated number of channels. -post_process_s :: Int -> (UGen -> UGen) -> Synthdef -post_process_s nc f = - let i = in' nc AR 0 - u = replaceOut 0 (f i) - nm = show (hashUGen u) - in synthdef nm u +-- indicated number of channels. If there is a single bus, writes +-- using 'replaceOut', else using 'out'. +post_process_s :: Int -> PP_Bus -> (UGen -> UGen) -> Synthdef +post_process_s nc b f = + let (src,dst,wr) = case b of + Left b' -> (b',b',replaceOut) + Right (b',b'') -> (b',b'',out) + i = in' nc AR src + u = wr dst (f i) + in synthdef (gen_nm u) u --- | 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 +-- | Run post-processing function. +post_process :: (Transport m) => Int -> PP_Bus -> Int -> (UGen -> UGen) -> m () +post_process nc bus grp f = do + let s = post_process_s nc bus f _ <- async (d_recv s) - send (s_new0 (synthdefName s) (-1) AddToTail 2) - play p + send (s_new0 (synthdefName s) (-1) AddToTail grp) +-- | Audition 'NRT' with specified post-processing function. +post_process_nrt :: (Transport m) => Loc_GB -> NRT -> Int -> (UGen -> UGen) -> m () +post_process_nrt (grp,bus) sc nc f = post_process nc (Left bus) grp f >> play sc + -- | Post processing function. type PPF = (UGen -> UGen) -- | Variant of 'overlapTextureU' with post-processing stage. overlapTextureU_pp :: OverlapTexture -> UGen -> Int -> PPF -> IO () overlapTextureU_pp k u nc f = do - let p = overlapTextureP k u - withSC3 (post_process_a p nc f) - --- | 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 - 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'. --- --- > let {o = sinOsc AR (rand 'α' 440 880) 0 --- > ;u = pan2 o (rand 'β' (-1) 1) (rand 'γ' 0.1 0.2)} --- > in xfadeTextureU (1,3,6) u -xfadeTextureU :: XFadeTexture -> UGen -> IO () -xfadeTextureU k = audition . xfadeTextureP k + let p = overlapTexture_nrt (1,0) k u + withSC3 (post_process_nrt (1,0) p nc f) -- | Variant of 'xfadeTextureU' with post-processing stage. xfadeTextureU_pp :: XFadeTexture -> UGen -> Int -> PPF -> IO () xfadeTextureU_pp k u nc f = do - let p = xfadeTextureP k u - withSC3 (post_process_a p nc f) + let p = xfadeTexture_nrt (1,0) k u + withSC3 (post_process_nrt (1,0) p nc f) +-- * State + -- | UGen generating state transform function. type USTF st = (st -> (UGen,st)) --- | Variant of 'overlapTextureP' where the continuous signal for each +-- | Variant of 'overlapTexture_nrt' 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 +overlapTexture_nrt_st :: Loc_GB -> OverlapTexture -> USTF st -> st -> NRT +overlapTexture_nrt_st (grp,bus) k u i_st = + let d = overlapTexture_iot k (_,_,_,c) = k g = take c (unfoldr (Just . u) i_st) - 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))] + s = map (gen_synth' bus (overlapTexture_env k)) g + in nrt_sy grp s (replicate c d) --- | Audition pattern given by 'overlapTextureP_st'. +-- | 'audition' of 'overlapTexture_nrt_st'. overlapTextureS :: OverlapTexture -> USTF st -> st -> IO () -overlapTextureS k u = audition . overlapTextureP_st k u +overlapTextureS t f = audition . overlapTexture_nrt_st (1,0) t f -- | Variant of 'overlapTextureS' with post-processing stage. overlapTextureS_pp :: OverlapTexture -> USTF st -> st -> Int -> PPF -> IO () overlapTextureS_pp k u i_st nc f = do - let p = overlapTextureP_st k u i_st - withSC3 (post_process_a p nc f) + let sc = overlapTexture_nrt_st (1,0) k u i_st + withSC3 (post_process_nrt (1,0) sc nc f) -- | Monadic state transform function. type MSTF st m = (st -> m (Maybe st)) @@ -192,23 +239,23 @@ -- the function. dt_rescheduler_m :: MonadIO m => MSTF (st,Time) m -> (st,Time) -> m () dt_rescheduler_m f = - let rec (st,t) = do + let recur (st,t) = do pauseThreadUntil t r <- f (st,t) case r of - Just (st',dt) -> rec (st',t + dt) + Just (st',dt) -> recur (st',t + dt) Nothing -> return () - in rec + in recur -- | Underlying function of 'overlapTextureM' with explicit 'Transport'. overlapTextureR :: Transport m => OverlapTexture -> IO UGen -> MSTF (Int,Time) m overlapTextureR k uf = let nm = "ot_" ++ show k - (_,dt) = overlapTexture_dt k + dt = overlapTexture_iot k in \(st,_) -> do u <- liftIO uf - let g = with_env (overlapTexture_env k) u + let g = with_env 0 (overlapTexture_env k) u _ <- async (d_recv (synthdef nm g)) send (s_new0 nm (-1) AddToTail 1) case st of 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 @@ -67,7 +67,7 @@ ,scale :: [Double] ,degree :: Double ,stepsPerOctave :: Double - ,detune :: Double + ,detune :: Double -- Hz ,harmonic :: Double ,freq' :: Maybe Double ,midinote' :: Maybe Double diff --git a/Sound/SC3/Lang/Core.hs b/Sound/SC3/Lang/Core.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Core.hs @@ -0,0 +1,139 @@ +-- | Core (shared) functions. +module Sound.SC3.Lang.Core where + +import Data.Maybe {- base -} +import Data.Monoid {- base -} + +-- * "Data.Function" variants + +-- | 'fmap' '.' 'fmap', ie. @(t -> c) -> (a -> b -> t) -> a -> b -> c@. +(.:) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) +(.:) = fmap . fmap + +-- | 'fmap' '.' '.:', ie. @(t -> d) -> (a -> b -> c -> t) -> a -> b -> c -> d@. +(.::) :: (Functor f, Functor g, Functor h) => (a -> b) -> f (g (h a)) -> f (g (h b)) +(.::) = fmap . (.:) + +-- | 'fmap' '.' '.::'. +(.:::) :: (Functor f, Functor g, Functor h,Functor i) => (a -> b) -> f (g (h (i a))) -> f (g (h (i b))) +(.:::) = fmap . (.::) + +-- | 'fmap' '.' '.:::'. +(.::::) :: (Functor f, Functor g, Functor h,Functor i,Functor j) => (a -> b) -> f (g (h (i (j a)))) -> f (g (h (i (j b)))) +(.::::) = fmap . (.:::) + +-- | 'fmap' '.' '.::::'. +(.:::::) :: (Functor f, Functor g, Functor h,Functor i,Functor j,Functor k) => (a -> b) -> f (g (h (i (j (k a))))) -> f (g (h (i (j (k b))))) +(.:::::) = fmap . (.::::) + +-- * "Data.List" variants + +-- | Variant that either takes precisely /n/ elements or 'Nothing'. +-- +-- > map (genericTake 3) (inits "abc") == inits "abc" +-- > Data.Maybe.mapMaybe (genericTakeMaybe 3) (inits "abc") == ["abc"] +genericTakeMaybe :: Integral i => i -> [a] -> Maybe [a] +genericTakeMaybe n l = + case compare n 0 of + LT -> Nothing + EQ -> Just [] + GT -> case l of + [] -> Nothing + e : l' -> fmap (e :) (genericTakeMaybe (n - 1) l') + +-- | 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) + +-- | 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. +-- +-- > transpose_st [[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 + diff --git a/Sound/SC3/Lang/Data/CMUdict.hs b/Sound/SC3/Lang/Data/CMUdict.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Data/CMUdict.hs @@ -0,0 +1,239 @@ +-- | Arpabet phoneme definitions and CMU dictionary functions. +-- +-- +-- +module Sound.SC3.Lang.Data.CMUdict where + +import Data.Char {- base -} +import Data.Maybe {- base -} +import Data.List {- base -} +import Data.List.Split {- split -} +import qualified Data.Map as M {- containers -} + +-- | Stress indicators, placed at the stressed syllabic vowel. +data Stress = No_stress | Primary_stress | Secondary_stress + deriving (Eq,Ord,Enum,Bounded,Read,Show) + +-- | Arpabet phonemes as used at CMU dictionary. +-- +-- > [AO .. NX] == [minBound .. maxBound] +-- > length [AO .. NX] == 48 +data Phoneme + -- Vowels (Monophthongs) + = AO | AA | IY | UW | EH | IH | UH | AH | AX | AE + -- Vowels (Diphthongs) + | EY | AY | OW | AW | OY + -- Vowels (R-colored) + | ER | AXR + -- Semivowels + | Y | W | Q + -- Consonants (Stops) + | P | B | T | D | K | G + -- Consonants (Affricates) + | CH | JH + -- Consonants (Fricatives) + | F | V | TH | DH | S | Z | SH | ZH + -- Consonants (Aspirate) + | HH + -- Nasals + | M | EM | N | EN | NG | ENG + -- Liquids + | L | EL | R | DX | NX + deriving (Eq,Ord,Enum,Bounded,Read,Show) + +-- | 'Phoneme' with 'Stress', if given. +type Phoneme_str = (Phoneme,Maybe Stress) + +-- | There is a variant CMU dictionary with syllable marks. +-- +type SYLLABLE = [Phoneme_str] + +-- | An ARPABET word. +type ARPABET = [Phoneme_str] + +-- | An ARPABET word, with syllables. +type ARPABET_syl = [SYLLABLE] + +-- | Parameterised CMU dictionary. +type CMU_Dict_ty a = M.Map String a + +-- | The CMU dictionary. +type CMU_Dict = CMU_Dict_ty ARPABET + +-- | The syllabic CMU dictionary. +type CMU_Dict_syl = CMU_Dict_ty ARPABET_syl + +-- | Parse 'Phoneme_str' +-- +-- > parse_phoneme_str "EY1" == (EY,Just Primary_stress) +-- > parse_phoneme_str "R" == (R,Nothing) +parse_phoneme_str :: String -> Phoneme_str +parse_phoneme_str w = + case reverse w of + '0':w' -> (read (reverse w'),Just No_stress) + '1':w' -> (read (reverse w'),Just Primary_stress) + '2':w' -> (read (reverse w'),Just Secondary_stress) + _ -> (read w,Nothing) + +parse_arpabet :: String -> (String,ARPABET) +parse_arpabet e = + case words e of + w:p -> (w,map parse_phoneme_str p) + _ -> error "parse_arpabet" + +parse_arpabet_syl :: String -> (String,ARPABET_syl) +parse_arpabet_syl e = + case words e of + w:p -> let p' = wordsBy (== "-") p + in (w,map (map parse_phoneme_str) p') + _ -> error "parse_arpabet_syl" + +-- | Classification of 'Phoneme's. +data Phoneme_Class = Monophthong | Diphthong | R_Coloured + | Semivowel + | Stop | Affricate | Fricative | Aspirate + | Nasal + | Liquid + deriving (Eq,Ord,Enum,Bounded,Read,Show) + +-- | Classification table for 'Phoneme'. +arpabet_classification_table :: [(Phoneme_Class,[Phoneme])] +arpabet_classification_table = + [(Monophthong,[AO,AA,IY,UW,EH,IH,UH,AH,AX,AE]) + ,(Diphthong,[EY,AY,OW,AW,OY]) + ,(R_Coloured,[ER,AXR]) + ,(Semivowel,[Y,W,Q]) + ,(Stop,[P,B,T,D,K,G]) + ,(Affricate,[CH,JH]) + ,(Fricative,[F,V,TH,DH,S,Z,SH,ZH]) + ,(Aspirate,[HH]) + ,(Nasal,[M,EM,N,EN,NG,ENG]) + ,(Liquid,[L,EL,R,DX,NX])] + +-- | Consult 'arpabet_classification_table'. +-- +-- > arpabet_classification HH == Aspirate +-- > map arpabet_classification [minBound .. maxBound] +arpabet_classification :: Phoneme -> Phoneme_Class +arpabet_classification p = + let f (_,l) = p `elem` l + in fromMaybe (error "arpabet_classification") $ + fmap fst $ + find f arpabet_classification_table + +cmudict_load_ty :: (String -> (String,a)) -> FilePath -> IO (CMU_Dict_ty a) +cmudict_load_ty pf fn = do + s <- readFile fn + let is_comment w = case w of {';':_ -> True;_ -> False} + l = filter (not . is_comment) (lines s) + return (M.fromList (map pf l)) + +-- | Load CMU dictionary from file. +-- +-- > d <- cmudict_load "/home/rohan/data/cmudict/cmudict.0.7a" +-- > M.size d == 133313 +cmudict_load :: FilePath -> IO CMU_Dict +cmudict_load = cmudict_load_ty parse_arpabet + +-- | Load syllable CMU dictionary from file. +-- +-- > d <- cmudict_syl_load "/home/rohan/data/cmudict/cmudict.0.6d.syl" +-- > M.size d == 129463 +cmudict_syl_load :: FilePath -> IO CMU_Dict_syl +cmudict_syl_load = cmudict_load_ty parse_arpabet_syl + +-- | Dictionary lookup. +-- +-- > let r = [(R,Nothing),(EY,Just Primary_stress) +-- > ,(N,Nothing),(ER,Just No_stress),(D,Nothing)] +-- > in d_lookup d "reynard" == Just r +d_lookup :: CMU_Dict_ty a -> String -> Maybe a +d_lookup d w = M.lookup (map toUpper w) d + +-- | Variant that retains query string if not in dictionary. +d_lookup' :: CMU_Dict_ty a -> String -> Either String a +d_lookup' d w = maybe (Left w) Right (d_lookup d w) + +-- * IPA + +-- | Table mapping /Arpabet/ phonemes to /IPA/ strings. +-- +-- > length arpabet_ipa_table == 48 +arpabet_ipa_table :: [(Phoneme,Either String [(Stress,String)])] +arpabet_ipa_table = + -- Vowels (Monophthongs) + [(AO,Left "ɔ") + ,(AA,Left "ɑ") + ,(IY,Left "i") + ,(UW,Left "u") + ,(EH,Left "ɛ") + ,(IH,Left "ɪ") + ,(UH,Left "ʊ") + ,(AH,Right [(Primary_stress,"ʌ"),(No_stress,"ə")]) + ,(AX,Left "ə") + ,(AE,Left "æ") + -- Vowels (Diphthongs) + ,(EY,Left "eɪ") + ,(AY,Left "aɪ") + ,(OW,Left "oʊ") + ,(AW,Left "aʊ") + ,(OY,Left "ɔɪ") + -- Vowels (R-colored) + ,(ER,Left "ɝ") + ,(AXR,Left "ɚ") + -- Semivowels + ,(Y,Left "j") + ,(W,Left "w") + ,(Q,Left "ʔ") + -- Consonants (Stops) + ,(P,Left "p") + ,(B,Left "b") + ,(T,Left "t") + ,(D,Left "d") + ,(K,Left "k") + ,(G,Left "ɡ") + -- Consonants (Affricates) + ,(CH,Left "tʃ") + ,(JH,Left "dʒ") + -- Consonants (Fricatives) + ,(F,Left "f") + ,(V,Left "v") + ,(TH,Left "θ") + ,(DH,Left "ð") + ,(S,Left "s") + ,(Z,Left "z") + ,(SH,Left "ʃ") + ,(ZH,Left "ʒ") + -- Consonants (Aspirate) + ,(HH,Left "h") + -- Nasals + ,(M,Left "m") + ,(EM,Left "m̩") + ,(N,Left "n") + ,(EN,Left "n̩") + ,(NG,Left "ŋ") + ,(ENG,Left "ŋ̍") + -- Liquids + ,(L,Left "ɫ") + ,(EL,Left "ɫ̩") + ,(R,Left "ɹ") + ,(DX,Left "ɾ") + ,(NX,Left "ɾ̃") + ] + +-- | Consult 'arpabet_ipa_table'. +-- +-- > map (phoneme_ipa (Just Primary_stress)) [minBound .. maxBound] +phoneme_ipa :: Maybe Stress -> Phoneme -> String +phoneme_ipa s = + either id (fromMaybe (error (show ("phoneme_ipa: no stressed phoneme",s))) . + lookup (fromMaybe (error "phoneme_ipa: no stress") s)) . + fromMaybe (error "phoneme_ipa: no phoneme") . + flip lookup arpabet_ipa_table + +-- | Consult 'arpabet_ipa_table'. +-- +-- > let r = map parse_phoneme_str (words "R EY1 N ER0 D") +-- > in arpabet_ipa r == "ɹeɪnɝd" +arpabet_ipa :: ARPABET -> String +arpabet_ipa = concatMap (\(p,s) -> phoneme_ipa s p) 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 @@ -28,7 +28,7 @@ -- > > (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 +-- > map (degreeToKey [0,2,4,5,7,9,11] 12) [5,6,7,8] == [9,11,12,14] degreeToKey :: (RealFrac a) => [a] -> a -> a -> a degreeToKey s n d = let l = length s @@ -64,6 +64,9 @@ log10 :: Floating a => a -> a log10 = logBase 10 +octpc_to_midi :: Num a => (a,a) -> a +octpc_to_midi (o,pc) = 60 + ((o - 4) * 12) + pc + -- | @SimpleNumber.midicps@ translates from midi note number to cycles -- per second. -- @@ -71,6 +74,20 @@ -- > map midicps [57,69] == [220,440] midicps :: (Floating a) => a -> a midicps a = 440.0 * (2.0 ** ((a - 69.0) * (1.0 / 12.0))) + +-- | 'midicps' of 'octpc_to_midi'. +octpc_to_cps :: (Floating a) => (a,a) -> a +octpc_to_cps = midicps . octpc_to_midi + +-- | 'octpc_to_cps' of 'degreeToKey'. +degree_to_cps :: (Floating a, RealFrac a) => [a] -> a -> a -> a -> a +degree_to_cps sc n d o = + let pc = degreeToKey sc n d + in octpc_to_cps (o,pc) + +-- | Variant with list inputs for degree and octave, and scalar inputs for scale and steps. +degree_to_cps' :: (Floating a, RealFrac a) => [a] -> a -> [a] -> [a] -> [a] +degree_to_cps' sc n = zipWith (degree_to_cps sc n) -- * UGen 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 @@ -2,6 +2,9 @@ -- space /[l,r]/. module Sound.SC3.Lang.Math.Warp where +import Numeric {- base -} +import Sound.SC3.UGen.Math {- hsc3 -} + import Sound.SC3.Lang.Math -- | Warp direction. 'W_Map' is forward, 'W_Unmap' is reverse. @@ -39,6 +42,9 @@ -- > > [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] +-- +-- > import Sound.SC3.Plot +-- > plotTable1 (map (warpExponential 1 2 W_Map) [0,0.01 .. 1]) warpExponential :: (Floating a) => a -> a -> Warp a warpExponential l r d n = let z = r / l @@ -52,6 +58,8 @@ -- > > [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] +-- +-- > plotTable1 (map (warpCosine 1 2 W_Map) [0,0.01 .. 1]) warpCosine :: (Floating a) => a -> a -> Warp a warpCosine l r d n = let w = warpLinear 0 (r - l) d @@ -62,6 +70,8 @@ -- | Sine warp -- -- > map (warpSine 1 2 W_Map) [0,0.25,0.5,0.75,1] +-- +-- > plotTable1 (map (warpSine 1 2 W_Map) [0,0.01 .. 1]) warpSine :: (Floating a) => a -> a -> Warp a warpSine l r d n = let w = warpLinear 0 (r - l) d @@ -69,26 +79,38 @@ then w (sin (pi * 0.5 * n)) else asin (w n) / (pi / 2) --- | Fader warp. Left and right values are implicitly zero and one. +-- | Fader warp. Left and right values are ordinarily zero and one. -- --- > map (warpFader W_Map) [0,0.5,1] == [0,0.25,1] -warpFader :: Floating a => Warp a -warpFader d n = if d == W_Map then n * n else sqrt n +-- > map (warpFader 0 1 W_Map) [0,0.5,1] == [0,0.25,1] +-- +-- > plotTable1 (map (warpFader 0 1 W_Map) [0,0.01 .. 1]) +-- > plotTable1 (map (warpFader 0 2 W_Map) [0,0.01 .. 1]) +warpFader :: Floating a => a -> a -> Warp a +warpFader l r d n = + let n' = if d == W_Map then n * n else sqrt n + in warpLinear l r d n' --- | DB fader warp. Left and right values are implicitly negative +-- | DB fader warp. Left and right values are ordinarily negative -- infinity and zero. An input of @0@ gives @-180@. -- -- > map (round . warpDbFader W_Map) [0,0.5,1] == [-180,-12,0] -warpDbFader :: (Eq a,Floating a) => Warp a -warpDbFader d n = +-- +-- > plotTable1 (map (warpDbFader (-60) 0 W_Map) [0,0.01 .. 1]) +-- > plotTable1 (map (warpDbFader 0 60 W_Unmap) [0 .. 60]) +warpDbFader :: (TernaryOp a,Eq a,Floating a) => a -> a -> Warp a +warpDbFader l r d n = if d == W_Map - then if n == 0 then -180 else ampdb (n * n) - else sqrt (dbamp n) + then let n' = if n == 0 then -180 else ampdb (n * n) + in linlin n' (-180) 0 l r + else sqrt (dbamp (linlin n l r (-180) 0)) -- | A curve warp given by a real /n/. -- -- > w_map (warpCurve (-3) 1 2) 0.25 == 1.5552791692202022 -- > w_map (warpCurve (-3) 1 2) 0.50 == 1.8175744761936437 +-- +-- > plotTable1 (map (warpCurve (-3) 1 2 W_Map) [0,0.01 .. 1]) +-- > plotTable1 (map (warpCurve 9 1 2 W_Map) [0,0.01 .. 1]) warpCurve :: (Ord a,Floating a) => a -> a -> a -> Warp a warpCurve k l r d n = let e = exp k @@ -99,3 +121,25 @@ else if d == W_Map then b - ((e ** n) * a) else log ((b - n) / a) / k + +-- | Select warp function by name. Numerical names are interpreted as +-- /curve/ values for 'warpCurve'. +-- +-- > let Just w = warpNamed "lin" +-- > let Just w = warpNamed "-3" +-- > let Just w = warpNamed "6" +-- > plotTable1 (map (w 1 2 W_Map) [0,0.01 .. 1]) +warpNamed :: (TernaryOp a,Ord a,Eq a,RealFrac a,Floating a) => + String -> Maybe (a -> a -> Warp a) +warpNamed nm = + case nm of + "lin" -> Just warpLinear + "exp" -> Just warpExponential + "sin" -> Just warpSine + "cos" -> Just warpCosine + "amp" -> Just warpFader + "db" -> Just warpDbFader + _ -> case readSigned readFloat nm of + [(c,"")] -> Just (warpCurve c) + _ -> Nothing + diff --git a/Sound/SC3/Lang/Pattern.hs b/Sound/SC3/Lang/Pattern.hs --- a/Sound/SC3/Lang/Pattern.hs +++ b/Sound/SC3/Lang/Pattern.hs @@ -6,4 +6,6 @@ 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 + +import Sound.SC3.Lang.Pattern.P as P +import Sound.SC3.Lang.Pattern.P.Event as P diff --git a/Sound/SC3/Lang/Pattern/Bind.hs b/Sound/SC3/Lang/Pattern/Bind.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Pattern/Bind.hs @@ -0,0 +1,94 @@ +-- | Minimal functions for binding values to parameter names and sending to scsynth. +module Sound.SC3.Lang.Pattern.Bind where + +import Data.List {- base -} +import qualified Data.List.Ordered as O {- data-ordlist -} +import Data.Maybe {- base -} + +import Sound.OSC {- hosc -} +import Sound.SC3 {- hsc3 -} + +import qualified Sound.SC3.Lang.Core as L {- hsc3-lang -} + +type Param = [(String,[Double])] + +pr_unused :: Synthdef -> Param -> [String] +pr_unused sy pr = (map fst pr \\ synthdefParam sy) \\ ["dur","sustain"] + +-- * Synthdef bind + +sbind_init :: Int -> [Synthdef] -> [Bundle] +sbind_init grp sy = + let sy_b = bundle 0 (map d_recv sy) + grp_b = bundle 0 [g_new [(grp,AddToHead,0)]] + in [sy_b,grp_b] + +sbind_tseq :: Int -> [Int] -> (Synthdef,[Time],Maybe [Time],Param) -> [Bundle] +sbind_tseq grp nid (sy,tm,sus,pr) = + let sy_pr = synthdefParam sy + has_gate = "gate" `elem` sy_pr + nd (t,k,ar) = let nm = synthdefName sy + in bundle t [s_new nm k AddToHead grp ar] + pr' = let f (p,l) = zip (repeat p) l + in L.transpose_st (map f pr) + gt = if has_gate + then let sus' = fromMaybe (d_dx' tm) sus + -- pr' may be finite, zipped here to halt if required... + f (t,g,k,_) = bundle (t + g) [n_set1 k "gate" 0] + in map f (zip4 tm sus' nid pr') + else if isNothing sus || "sustain" `elem` sy_pr + then [] + else error ("sbind_tseq: sus given but no gate parameter") + in case pr_unused sy pr of + [] -> O.merge (map nd (zip3 tm nid pr')) gt + u -> error (show ("sbind_tseq: unused parameters",u)) + +sbind_deriv :: Int -> [Int] -> (Synthdef,Param) -> [Bundle] +sbind_deriv grp nid (sy,pr) = + let dur = fromMaybe (error "sbind_deriv: no dur parameter") (lookup "dur" pr) + sus = lookup "sustain" pr + tm = dx_d' dur + in sbind_tseq grp nid (sy,tm,sus,pr) + +sbind :: [(Synthdef,Param)] -> NRT +sbind set = + let grp = 1 + nid = map (\n -> [n..]) [1000,6000 ..] + in NRT (sbind_init grp (map fst set) ++ foldl1 O.merge (zipWith (sbind_deriv grp) nid set)) + +sbind1 :: (Synthdef,Param) -> NRT +sbind1 = sbind . return + +-- * Node bind + +nbind_init :: Int -> [(Synthdef,Int,Param)] -> [Bundle] +nbind_init grp m = + let (sy,nid,_) = unzip3 m + sy_b = bundle 0 (map d_recv sy) + grp_b = bundle 0 [g_new [(grp,AddToHead,0)]] + nd_b = bundle 0 (map (\(s,k) -> s_new (synthdefName s) k AddToHead grp []) (zip sy nid)) + in [sy_b,grp_b,nd_b] + +nbind_tseq :: (Synthdef,Int,[Time],Param) -> [Bundle] +nbind_tseq (sy,nid,tm,pr) = + let m (t,k,ar) = bundle t [n_set k ar] + pr' = let f (p,l) = zip (repeat p) l + in L.transpose_st (map f pr) + in case pr_unused sy pr of + [] -> map m (zip3 tm (repeat nid) pr') + u -> error (show ("nbind_tseq: unused parameters",u)) + +nbind_deriv :: (Synthdef,Int,Param) -> [Bundle] +nbind_deriv (sy,k,pr) = + let dur = fromMaybe (error "nbind_deriv: no dur parameter") (lookup "dur" pr) + tm = dx_d' dur + in nbind_tseq (sy,k,tm,pr) + +nbind :: [(Synthdef,Int,Param)] -> NRT +nbind set = + let grp = 1 + set' = map nbind_deriv set + in NRT (nbind_init grp set ++ foldl1 O.merge set') + +nbind1 :: (Synthdef,Int,Param) -> NRT +nbind1 = nbind . return diff --git a/Sound/SC3/Lang/Pattern/ID.hs b/Sound/SC3/Lang/Pattern/ID.hs deleted file mode 100644 --- a/Sound/SC3/Lang/Pattern/ID.hs +++ /dev/null @@ -1,1960 +0,0 @@ -{-# Language FlexibleInstances #-} --- | @sclang@ pattern library functions. --- See for tutorial. --- --- 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 @@ -2,15 +2,13 @@ module Sound.SC3.Lang.Pattern.List where 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 Sound.SC3.Lang.Core +import qualified Sound.SC3.Lang.Pattern.Stream as I -- * Data.Bool variants @@ -47,112 +45,6 @@ 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. @@ -209,15 +101,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 @@ -237,7 +120,7 @@ -- -- > [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) +brown e l r s = I.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 @@ -248,19 +131,19 @@ -- > ;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 = +durStutter = let f s d = case s of 0 -> [] 1 -> [d] _ -> replicate s (d / fromIntegral s) - in concat . zipWith f p + in concat .: zipWith f -- | 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) +exprand e l r n = take_inf n (I.exprand e l r) -- | Pfuncn. Variant of the SC3 pattern that evaluates a closure at -- each step that has a 'StdGen' form. @@ -286,10 +169,7 @@ -- -- > 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 - i = white e 0 k n - in map (a !!) i +rand' e a n = take_inf n (I.rand e a) -- | Pseq. 'concat' of 'replicate' of 'concat'. -- @@ -302,20 +182,14 @@ -- > 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 - l = enumFromThen i (i + s) - r = map (+ (j - 1)) l - in if wr - then concat (take n (map (segment a k) (zip l r))) - else error "slide: non-wrap variant not implemented" +slide a n j s i wr = concat (take n (I.slide a j s i wr)) -- | 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 +stutter = concat .: zipWith replicate -- | Pswitch. SC3 pattern to select elements from a list of patterns -- by a pattern of indices. @@ -356,18 +230,18 @@ -- > 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))) +white e l r n = take_inf n (I.white e l r) -- | 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. +-- should sum to 1.0 and must be equal in length to the selection list. -- -- > 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)) +wrand e a w n = concat (take_inf n (I.wrand_generic e a w)) -- | Pxrand. SC3 pattern that is like 'rand' but filters successive -- duplicates. @@ -378,26 +252,6 @@ -- * 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 = @@ -428,13 +282,13 @@ 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_n = concat .: zipWith rorate_n' 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 +rorate_l = concat .: zipWith rorate_l' -- | 'white' with pattern inputs. -- @@ -456,19 +310,8 @@ -- -- > 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 f (mkStdGen (fromEnum e)) +whitei = fmap S.floorE .::: white -- | 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' e = concat . I.xrand e diff --git a/Sound/SC3/Lang/Pattern/P.hs b/Sound/SC3/Lang/Pattern/P.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Pattern/P.hs @@ -0,0 +1,7 @@ +-- | Composite of Pattern.P modules. +-- See for tutorial. +module Sound.SC3.Lang.Pattern.P (module P) where + +import Sound.SC3.Lang.Pattern.P.Core as P +import Sound.SC3.Lang.Pattern.P.Base as P +import Sound.SC3.Lang.Pattern.P.SC3 as P diff --git a/Sound/SC3/Lang/Pattern/P/Base.hs b/Sound/SC3/Lang/Pattern/P/Base.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Pattern/P/Base.hs @@ -0,0 +1,333 @@ +-- | Pattern functions. +-- +-- Haskell: `pappend`, `pconcat`, `pcons`, `pcycle`, +-- `pempty`,`pfilter`, `pjoin`, `prepeat`, `preplicate`, `pscanl`, +-- `psplitPlaces`, `ptail`, `ptake`, `pzip`, `pzipWith`. +-- +-- Non SC3: `pbool`, `pcountpost`, `pcountpre`,`phold`, `pinterleave`, +-- `prsd`, `ptrigger`. +module Sound.SC3.Lang.Pattern.P.Base where + +import Control.Applicative {- base -} +import Control.Monad {- base -} +import qualified Data.Foldable as F {- base -} +import qualified Data.List as L {- base -} +import qualified Data.List.Split as S {- split -} +import Data.Monoid {- base -} +import qualified Data.Traversable as T {- base -} + +import Sound.SC3.Lang.Pattern.P.Core + +import Sound.SC3.Lang.Core +import qualified Sound.SC3.Lang.Pattern.List as P +import qualified Sound.SC3.Lang.Pattern.Stream as I + +-- * 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) + +-- * Data.List.Split + +-- | 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 = fmap toP .: psplitPlaces' + +-- | Pattern variant of '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 (take_inf n) + +-- | Type specialised '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 = 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 = liftP (drop 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 'transpose_st'. +ptranspose_st_repeat :: [P a] -> P [a] +ptranspose_st_repeat l = toP (transpose_st (map unP_repeat l)) + +-- * 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 = mconcat .: replicate + +-- | 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 'I.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 I.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) + +-- * 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 diff --git a/Sound/SC3/Lang/Pattern/P/Core.hs b/Sound/SC3/Lang/Pattern/P/Core.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Pattern/P/Core.hs @@ -0,0 +1,261 @@ +-- | 'P' type, instance and core functions. +module Sound.SC3.Lang.Pattern.P.Core 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 Data.Monoid {- base -} +import qualified Data.Traversable as T {- base -} + +import Sound.SC3 (OrdE(..)) {- hsc3 -} + +-- * 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, as for 'ZipList'. '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 combinatorial +-- instance for ordinary lists, ie. where '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'. In the documentation functions that resolve using +-- 'pure' are annotated as /implicitly repeating/. +-- +-- > 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" + +There is a @default@ sound, given by 'defaultSynthdef' from "Sound.SC3". + +> audition defaultSynthdef + +If no instrument is specified we hear the default. + +> 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) diff --git a/Sound/SC3/Lang/Pattern/P/Event.hs b/Sound/SC3/Lang/Pattern/P/Event.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Pattern/P/Event.hs @@ -0,0 +1,574 @@ +-- | @sclang@ event pattern functions. +-- +-- SC3 /event/ patterns: `padd` (Padd), `pbind` (Pbind), `pkey` +-- (Pkey), `pmono` (Pmono), `pmul` (Pmul), `ppar` (Ppar), `pstretch` +-- (Pstretch), `ptpar` (Ptpar). `pedit`, `pinstr`, `pmce2`, `psynth`, +-- `punion`. +module Sound.SC3.Lang.Pattern.P.Event where + +import qualified Data.Foldable as F {- base -} +import Data.Maybe {- base -} +import Data.Monoid {- base -} + +import Sound.OSC {- hsc3 -} +import Sound.SC3 {- hsc3 -} + +import Sound.SC3.Lang.Control.Duration +import Sound.SC3.Lang.Control.Event +import Sound.SC3.Lang.Control.Instrument +import Sound.SC3.Lang.Core +import Sound.SC3.Lang.Pattern.P + +-- * SC3 Event Patterns + +-- | NewType for event patterns. +newtype P_Event = P_Event {p_Event :: P Event} + +-- | 'P_Event' is audible, 'P' 'Event' could be as well but it'd be an orphan instance. +instance Audible P_Event where + play_at _ = e_play . Event_Seq . unP . p_Event + +pplay :: Transport m => P Event -> m () +pplay = play . P_Event + +-- | 'audition' of 'P_Event'. +paudition :: P Event -> IO () +paudition = audition . P_Event + +-- | 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 + +> paudition (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 paudition (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; + +> paudition (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; + +> paudition (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; + +> paudition (pbind [(K_freq,prand 'α' [1,1.2,2,2.5,3,4] inf * 200) +> ,(K_dur,0.1)]) + +> paudition (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; + +> paudition (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: + +> paudition (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. + +> paudition (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 + +> paudition (pbind [(K_instr,psynth test) +> ,(K_freq,prand 'α' [1,1.2,2,2.5,3,4] inf * 200) +> ,(K_dur,0.1)]) + +> paudition (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 + +> paudition (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 + +> paudition (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; + +> paudition (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 + +> paudition (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 + +> paudition (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 paudition (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 paudition (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 paudition (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 paudition (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 paudition (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 paudition (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 paudition (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/. +-- +-- > paudition (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 paudition 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 + +> paudition (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 paudition (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. + +> paudition (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' = 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 paudition (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 + +-- * 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 diff --git a/Sound/SC3/Lang/Pattern/P/SC3.hs b/Sound/SC3/Lang/Pattern/P/SC3.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Pattern/P/SC3.hs @@ -0,0 +1,883 @@ +-- | @sclang@ value pattern functions. +-- +-- 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 variant patterns: `pbrown`', `prand'`, `prorate'`, `pseq1`, +-- `pseqn`, `pser1`, `pseqr`, `pwhite'`, `pwhitei`. +-- +-- SC3 collection patterns: `pfold` +module Sound.SC3.Lang.Pattern.P.SC3 where + +import Control.Monad {- base -} +import qualified Data.List as L {- base -} +import Data.Monoid {- base -} +import System.Random {- random -} + +import Sound.SC3 {- hsc3 -} + +import Sound.SC3.Lang.Core +import Sound.SC3.Lang.Pattern.P.Core +import Sound.SC3.Lang.Pattern.P.Base + +import qualified Sound.SC3.Lang.Collection as C +import qualified Sound.SC3.Lang.Math as M +import qualified Sound.SC3.Lang.Pattern.List as P +import qualified Sound.SC3.Lang.Pattern.Stream as I +import qualified Sound.SC3.Lang.Random.Gen as R + +-- * 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 . 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 (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 = join .:: prand' + +-- | 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 = pjoin_repeat .: pzipWith prorate' + +-- | 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 = toP .::::: P.slide + +{- | 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 = toP .::: P.white + +{- | 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 (I.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 = toP .::: P.whitei + +-- * 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/Plain.hs b/Sound/SC3/Lang/Pattern/Plain.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Pattern/Plain.hs @@ -0,0 +1,5 @@ +module Sound.SC3.Lang.Pattern.Plain (module P) where + +import Sound.SC3.Lang.Math as P +import Sound.SC3.Lang.Pattern.Bind as P +import Sound.SC3.Lang.Pattern.Stream as P diff --git a/Sound/SC3/Lang/Pattern/Stream.hs b/Sound/SC3/Lang/Pattern/Stream.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Pattern/Stream.hs @@ -0,0 +1,139 @@ +-- | Infinte list @SC3@ pattern functions. +module Sound.SC3.Lang.Pattern.Stream where + +import Data.List {- base -} +import Data.Maybe {- base -} +import System.Random {- random -} + +import qualified Sound.SC3 as S {- hsc3 -} + +import Sound.SC3.Lang.Core {- hsc3-lang -} +import qualified Sound.SC3.Lang.Math as M {- hsc3-lang -} +import qualified Sound.SC3.Lang.Random.Gen as R + +-- | Remove successive duplicates. +-- +-- > 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) + +-- | True if /a/ is initially equal to /b/. +iEq :: Eq a => [a] -> [a] -> Bool +iEq = flip isPrefixOf + +-- | Take elements from /l/ until all elements in /s/ have been seen. +-- If /s/ contains duplicate elements these must be seen multiple +-- times. +-- +-- > take_until_forms_set "abc" "a random sentence beginning" == "a random sentence b" +take_until_forms_set :: Eq a => [a] -> [a] -> [a] +take_until_forms_set s l = + if null s + then [] + else case l of + [] -> [] + e:l' -> e : take_until_forms_set (delete e s) l' + +-- | 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 l `iEq` [415,419,420,428] +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_) + +-- | 'M.exprange' of 'white' +exprand :: (Enum e,Random a,Floating a) => e -> a -> a -> [a] +exprand e l r = fmap (M.exprange l r) (white e 0 1) + +-- | Geometric series. +-- +-- > geom 3 6 `iEq` [3,18,108,648,3888,23328,139968] +geom :: Num a => a -> a -> [a] +geom i s = iterate (* s) i + +-- > lace [[0],[1,2],[3,4,5]] `iEq` [0,1,3,0,2,4,0,1,5] +-- > lace [[1],[2,5],[3,6]] `iEq` [1,2,3,1,5,6] +-- > lace [[1],[2,5],[3,6..]] `iEq` [1,2,3,1,5,6,1,2,9,1,5,12] +lace :: [[a]] -> [a] +lace = concat . transpose . map cycle + +-- | Random elements from list. +-- +-- > take_until_forms_set "string" (rand 'α' "string") == "grtrsiirn" +rand :: Enum e => e -> [a] -> [a] +rand e a = + let k = length a - 1 + in map (a !!) (white e 0 k) + +-- | 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 + +-- > slide [1,2,3,4] 4 1 0 True `iEq` [[1,2,3,4],[2,3,4,1],[3,4,1,2],[4,1,2,3]] +-- > slide [1,2,3,4,5] 3 (-1) 0 True `iEq` [[1,2,3],[5,1,2],[4,5,1],[3,4,5],[2,3,4]] +slide :: [a] -> Int -> Int -> Int -> Bool -> [[a]] +slide a j s i wr = + let k = length a + l = enumFromThen i (i + s) + r = map (+ (j - 1)) l + in if wr + then map (segment a k) (zip l r) + else error "slide: non-wrap variant not implemented" + +-- | 'concat' of 'slide'. +slidec :: [a] -> Int -> Int -> Int -> Bool -> [a] +slidec = concat .:::: slide + +-- | White noise. +-- +-- > take_until_forms_set [1..5] (white 'α' 1 5) == [4,1,2,2,2,1,2,1,2,5,1,4,3] +white :: (Random n,Enum e) => e -> n -> n -> [n] +white e l r = randomRs (l,r) (mkStdGen (fromEnum e)) + +-- | Weighted selection of elements from a list. +wrand_generic :: (Enum e,Fractional n,Ord n,Random n) => e -> [a] -> [n] -> [a] +wrand_generic e a w = + let f g = let (r,g') = R.wchoose a w g + in r : f g' + in if length a /= length w + then error "wrand_generic: a/w must be of equal length" + else f (mkStdGen (fromEnum e)) + +-- | Type restricted variant. +-- +-- > import qualified Sound.SC3.Lang.Collection as C +-- +-- > let {w = C.normalizeSum [1..5] +-- > ;r = wrand 'ζ' "wrand" w} +-- > in take_until_forms_set "wrand" r == "dnanrdnaddrnrrndrrdw" +wrand :: Enum e => e -> [a] -> [Double] -> [a] +wrand = wrand_generic + +-- | Select elements from /l/ in random sequence, but do not immediately repeat an element. +-- +-- > take_until_forms_set "string" (xrand 'α' "string") == "grtrsirn" +xrand :: Enum e => e -> [a] -> [a] +xrand e a = + let g = mkStdGen (fromEnum e) + k = length a - 1 + r = rsd (randomRs (0,k) g) + in map (a !!) r 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,36 +1,71 @@ -- | 'RandomGen' based @sclang@ random number functions. module Sound.SC3.Lang.Random.Gen where +import qualified Data.DList as DL {- dlist -} import Data.Maybe {- base -} import System.Random {- random -} import System.Random.Shuffle {- random-shuffle -} import qualified Sound.SC3.Lang.Collection as C +import Sound.SC3.Lang.Core 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) --- | Construct variant of /f/ generating /k/ values. -kvariant :: Int -> (g->(a,g)) -> g->([a],g) -kvariant k f = +-- | State modifying variant of 'iterate'. Lifts random generator +-- functions to infinte lists. +-- +-- > let r = [3,1,7,0,12,1,6,4,12,11,7,4] +-- > in take 12 (r_iterate (rand 12) (mkStdGen 0)) == r +r_iterate :: (t -> (a, t)) -> t -> [a] +r_iterate f g = let (r,g') = f g in r : r_iterate f g' + +-- | Function underlying both 'kvariant' and 'kvariant''. +mk_kvariant :: r -> (t -> r -> r) -> (r -> r') -> Int -> (g -> (t,g)) -> g -> (r',g) +mk_kvariant k_nil k_join un_k k f = let go x i g = case i of - 0 -> (x,g) + 0 -> (un_k x,g) _ -> let (y,g') = f g - in go (y:x) (i - 1) g' - in go [] k + in go (k_join y x) (i - 1) g' + in go k_nil k +-- | Construct variant of /f/ generating /k/ values. Note that the +-- result is the reverse of the initial sequence given by 'r_iterate'. +-- +-- > let r = [3,1,7,0,12,1,6,4,12,11,7,4] +-- > in fst (kvariant 12 (rand 12) (mkStdGen 0)) == reverse r +kvariant :: Int -> (g->(a,g)) -> g->([a],g) +kvariant = mk_kvariant [] (:) id + +-- | Variant of 'kvariant' that generates sequence in the same order +-- as 'r_iterate'. There is perhaps a slight overhead from using a +-- difference list. +-- +-- > let r = [3,1,7,0,12,1,6,4,12,11,7,4] +-- > in fst (kvariant' 12 (rand 12) (mkStdGen 0)) == r +kvariant' :: Int -> (g->(a,g)) -> g->([a],g) +kvariant' = mk_kvariant DL.empty (flip DL.snoc) DL.toList + -- | Variant of 'rand' generating /k/ values. -- -- > fst (nrand 10 (5::Int) (mkStdGen 246873)) == [0,5,4,0,4,5,3,2,3,1] nrand :: (RandomGen g,Random n,Num n) => Int -> n -> g -> ([n],g) nrand k = kvariant k . rand +-- | Stream variant of 'rand'. +s_rand :: (RandomGen g,Random n,Num n) => n -> g -> [n] +s_rand = r_iterate . rand + -- | @SimpleNumber.rand2@ is 'randomR' in (-/n/,/n/). rand2 :: (RandomGen g,Random n,Num n) => n -> g -> (n,g) rand2 n = randomR (-n,n) +-- | Stream variant of 'rand2'. +s_rand2 :: (RandomGen g,Random n,Num n) => n -> g -> [n] +s_rand2 = r_iterate . rand2 + -- | Variant of 'rand2' generating /k/ values. nrand2 :: (RandomGen g,Random a,Num a) => Int -> a -> g -> ([a],g) nrand2 k = kvariant k . rand2 @@ -41,7 +76,7 @@ -- | Variant of 'rrand' generating /k/ values. nrrand :: (RandomGen g,Random a,Num a) => Int -> a -> a -> g -> ([a],g) -nrrand k l = kvariant k . rrand l +nrrand k = kvariant k .: rrand -- | @SequenceableCollection.choose@ selects an element at random. choose :: RandomGen g => [a] -> g -> (a,g) @@ -63,7 +98,7 @@ -- | Variant of 'exprand' generating /k/ values. nexprand :: (Floating n,Random n,RandomGen g) => Int -> n -> n -> g -> ([n],g) -nexprand k l = kvariant k . exprand l +nexprand k = kvariant k .: exprand -- | @SimpleNumber.coin@ is 'True' at given probability, which is in -- range (0,1). @@ -88,8 +123,21 @@ -- | @SequenceableCollection.wchoose@ selects an element from a list -- given a list of weights which sum to @1@. +-- +-- > kvariant 10 (wchoose "abcd" (C.normalizeSum [8,4,2,1])) (mkStdGen 0) wchoose :: (RandomGen g,Random a,Ord a,Fractional a) => [b] -> [a] -> g -> (b,g) wchoose l w g = let (i,g') = randomR (0.0,1.0) g n = fromMaybe (error "wchoose: windex") (C.windex w i) in (l !! n,g') + +-- | Variant that applies 'C.normalizeSum' to weights. +-- +-- > let r = "dcbbacaadd" +-- > in r == fst (kvariant 10 (wchoose_N "abcd" [8,4,2,1]) (mkStdGen 0)) +wchoose_N :: (Fractional a,Ord a,RandomGen g,Random a) => [b] -> [a] -> g -> (b, g) +wchoose_N l w = wchoose l (C.normalizeSum w) + +-- | 'kvariant' of 'wchoose_N'. +nwchoose_N :: (Fractional a,Ord a,RandomGen g,Random a) => Int -> [b] -> [a] -> g -> ([b], g) +nwchoose_N n = kvariant n .: wchoose_N diff --git a/Sound/SC3/Lang/Random/ID.hs b/Sound/SC3/Lang/Random/ID.hs new file mode 100644 --- /dev/null +++ b/Sound/SC3/Lang/Random/ID.hs @@ -0,0 +1,18 @@ +-- | 'ID' variants of "Sound.SC3.Lang.Random.Gen". +module Sound.SC3.Lang.Random.ID where + +import System.Random {- random -} + +import qualified Sound.SC3.Lang.Random.Gen as G + +id_rand :: Enum e => e -> (StdGen -> (a,StdGen)) -> a +id_rand e f = fst (f (mkStdGen (fromEnum e))) + +nchoose :: Enum e => e -> Int -> [a] -> [a] +nchoose e n l = id_rand e (G.nchoose n l) + +rand :: (Random a, Num a, Enum e) => e -> a -> a +rand e n = id_rand e (G.rand n) + +rrand :: (Random a, Num a, Enum e) => e -> a -> a -> a +rrand e l r = id_rand e (G.rrand l r) 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 @@ -4,6 +4,7 @@ import Control.Monad.IO.Class {- transformers -} import System.Random {- random -} +import Sound.SC3.Lang.Core import Sound.SC3.Lang.Random.Gen as R -- | 'liftIO' of 'randomRIO'. @@ -24,7 +25,7 @@ -- | Variant of 'rand2' generating /k/ values. nrand2 :: (Random a, Num a) => Int -> a -> IO [a] -nrand2 k = randomG . R.nrand2 k +nrand2 = randomG .: R.nrand2 -- | @SimpleNumber.rrand@ is 'curry' 'randomRIO'. rrand :: (MonadIO m,Random n) => n -> n -> m n @@ -32,7 +33,7 @@ -- | Variant of 'rrand' generating /k/ values. nrrand :: (MonadIO m,Random a, Num a) => Int -> a -> a -> m [a] -nrrand k l = randomG . R.nrrand k l +nrrand = randomG .:: R.nrrand -- | @SequenceableCollection.choose@ selects an element at random. choose :: MonadIO m => [a] -> m a @@ -41,7 +42,7 @@ -- | @SimpleNumber.exprand@ generates exponentially distributed random -- number in the given interval. exprand :: (MonadIO m,Floating n,Random n) => n -> n -> m n -exprand l = randomG . R.exprand l +exprand = randomG .: R.exprand -- | @SimpleNumber.coin@ is 'True' at given probability, which is in -- range (0,1). @@ -55,5 +56,5 @@ -- | @SequenceableCollection.wchoose@ selects an element from a list -- given a list of weights which sum to @1@. wchoose :: (MonadIO m,Random a,Ord a,Fractional a) => [b] -> [a] -> m b -wchoose l = randomG . R.wchoose l +wchoose = randomG .: R.wchoose 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 @@ -24,6 +24,8 @@ -- | §4.3.5 (τ=1) -- +-- > h [map (cauchy 1.0) r] +-- -- > 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] @@ -63,10 +65,13 @@ -- | §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)] +-- > let r' = adj r +-- > h [mapMaybe (beta 0.45 0.45) r' +-- > ,mapMaybe (beta 0.65 0.45) r' +-- > ,mapMaybe (beta 0.45 0.65) r'] +-- +-- > h [mapMaybe (beta 0.35 0.5) r' +-- > ,mapMaybe (beta 0.5 0.65) r'] beta :: (Floating a,Ord a) => a -> a -> (a,a) -> Maybe a beta a b (u1,u2) = let ea = 1.0 / a 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 @@ -3,7 +3,10 @@ import Control.Monad {- base -} import Control.Monad.Random {- MonadRandom -} +import Data.Maybe {- base -} +import qualified Sound.SC3.Lang.Collection as C +import Sound.SC3.Lang.Core import qualified Sound.SC3.Lang.Math as M -- | @SimpleNumber.rand@ is 'getRandomR' in (0,/n/). @@ -41,7 +44,7 @@ -- -- > evalRand (nrrand 4 3 9) (mkStdGen 1) == [5,8,9,6] nrrand :: (RandomGen g,Random n,Num n) => Int -> n -> n -> Rand g [n] -nrrand k l = replicateM k . rrand l +nrrand k = replicateM k .: rrand -- | @SequenceableCollection.choose@ selects an element at random. -- @@ -51,6 +54,15 @@ i <- rand (length l - 1) return (l !! i) +wchoose :: (RandomGen g,Fractional t,Ord t,Random t) => [a] -> [t] -> Rand g a +wchoose l w = do + i <- rrand 0.0 1.0 + let n = fromMaybe (error "wchoose: windex") (C.windex w i) + return (l !! n) + +wchoose_N :: (RandomGen g,Fractional t,Ord t,Random t) => [a] -> [t] -> Rand g a +wchoose_N l w = wchoose l (C.normalizeSum w) + -- | Variant of 'choose' generating /k/ values. -- -- > evalRand (nchoose 4 [3..9]) (mkStdGen 1) == [5,8,9,6] @@ -72,4 +84,5 @@ -- > let r = nexprand 3 10 100 >>= return . map floor -- > in evalRand r (mkStdGen 1) == [22,21,13] nexprand :: (Floating n,Random n,RandomGen g) => Int -> n -> n -> Rand g [n] -nexprand k l = replicateM k . exprand l +nexprand k = replicateM k .: exprand + diff --git a/hsc3-lang.cabal b/hsc3-lang.cabal --- a/hsc3-lang.cabal +++ b/hsc3-lang.cabal @@ -1,16 +1,16 @@ Name: hsc3-lang -Version: 0.14 +Version: 0.15 Synopsis: Haskell SuperCollider Language Description: Haskell library defining operations from the SuperCollider language class library License: GPL Category: Sound -Copyright: (c) Rohan Drape, 2007-2013 +Copyright: (c) Rohan Drape, 2007-2014 Author: Rohan Drape Maintainer: rd@slavepianos.org Stability: Experimental -Homepage: http://rd.slavepianos.org/?t=hsc3-lang -Tested-With: GHC == 7.6.1 +Homepage: http://rd.slavepianos.org/t/hsc3-lang +Tested-With: GHC == 7.8.2 Build-Type: Simple Cabal-Version: >= 1.8 @@ -23,37 +23,54 @@ bytestring, containers, data-default, + data-ordlist, + dlist, + hashable, hmatrix-special, - hosc == 0.14.*, - hsc3 == 0.14.*, + hosc == 0.15.*, + hsc3 == 0.15.*, MonadRandom, transformers, split, random, random-shuffle, - transformers + transformers, + vector GHC-Options: -Wall -fwarn-tabs Exposed-modules: Sound.SC3.Lang.Collection + Sound.SC3.Lang.Collection.Array Sound.SC3.Lang.Collection.Extension Sound.SC3.Lang.Collection.Numerical.Extending Sound.SC3.Lang.Collection.Numerical.Truncating Sound.SC3.Lang.Collection.Universal.Datum + Sound.SC3.Lang.Collection.Vector Sound.SC3.Lang.Control.Duration Sound.SC3.Lang.Control.Event Sound.SC3.Lang.Control.Instrument Sound.SC3.Lang.Control.Midi + Sound.SC3.Lang.Control.Midi.ST Sound.SC3.Lang.Control.Pitch Sound.SC3.Lang.Control.OverlapTexture + Sound.SC3.Lang.Core + Sound.SC3.Lang.Data.CMUdict Sound.SC3.Lang.Data.Modal Sound.SC3.Lang.Data.Vowel 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.Bind Sound.SC3.Lang.Pattern.List + Sound.SC3.Lang.Pattern.P + Sound.SC3.Lang.Pattern.P.Base + Sound.SC3.Lang.Pattern.P.Core + Sound.SC3.Lang.Pattern.P.Event + Sound.SC3.Lang.Pattern.P.SC3 + Sound.SC3.Lang.Pattern.Plain + Sound.SC3.Lang.Pattern.Stream Sound.SC3.Lang.Random.Lorrain_1980 Sound.SC3.Lang.Random.Gen + Sound.SC3.Lang.Random.ID Sound.SC3.Lang.Random.IO Sound.SC3.Lang.Random.Monad