{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}

{-
    UI.hs - Tidal's main 'user interface' functions, for transforming
    patterns, building on the Core ones.
    Copyright (C) 2025, Alex McLean and contributors

    This library is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this library.  If not, see <http://www.gnu.org/licenses/>.
-}

-- |
--    This module provides the main user interface functions, including sources
--    of randomness and transformations of patterns. All these functions are available
--    in the context of the TidalCycles REPL.
--
--    Many functions in this module taking 'Pattern' values as arguments have a
--    corresponding function with an underscore prepended to its name (e.g.
--    'degradeBy' and '_degradeBy'). These functions accept plain values, not
--    'Pattern's, and are generally intended for those developing or extending Tidal.
module Sound.Tidal.UI where

import Data.Bits (Bits, shiftL, shiftR, testBit, xor)
import Data.Bool (bool)
import Data.Char (digitToInt, isDigit, ord)
import Data.Fixed (mod')
import Data.List
  ( elemIndex,
    findIndex,
    findIndices,
    groupBy,
    intercalate,
    sort,
    sortOn,
    transpose,
  )
import qualified Data.Map.Strict as Map
import Data.Maybe
  ( catMaybes,
    fromJust,
    fromMaybe,
    isJust,
    mapMaybe,
  )
import Data.Ratio (Ratio, (%))
import qualified Data.Text as T
import Sound.Tidal.Bjorklund (bjorklund)
import Sound.Tidal.Core
import qualified Sound.Tidal.Params as P
import Sound.Tidal.Pattern
import Sound.Tidal.Utils
  ( accumulate,
    enumerate,
    mid,
    wordsBy,
    (!!!),
  )
import Prelude hiding ((*>), (<*))

------------------------------------------------------------------------

-- * UI

-- ** Randomisation

-- |
-- An implementation of the well-known @xorshift@ random number generator.
-- Given a seed number, generates a reasonably random number out of it.
-- This is an efficient algorithm suitable for use in tight loops and used
-- to implement the below functions, which are used to implement 'rand'.
--
-- See George Marsaglia (2003). ["Xorshift RNGs"](https://www.jstatsoft.org/article/view/v008i14),
-- in Journal of Statistical Software, pages 8–14.
xorwise :: Int -> Int
xorwise :: Int -> Int
xorwise Int
x =
  let a :: Int
a = Int -> Int -> Int
forall a. Bits a => a -> a -> a
xor (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftL Int
x Int
13) Int
x
      b :: Int
b = Int -> Int -> Int
forall a. Bits a => a -> a -> a
xor (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftR Int
a Int
17) Int
a
   in Int -> Int -> Int
forall a. Bits a => a -> a -> a
xor (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftL Int
b Int
5) Int
b

-- stretch 300 cycles over the range of [0,2**29 == 536870912) then apply the xorshift algorithm
timeToIntSeed :: (RealFrac a) => a -> Int
timeToIntSeed :: forall a. RealFrac a => a -> Int
timeToIntSeed = Int -> Int
xorwise (Int -> Int) -> (a -> Int) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall b. Integral b => a -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (a -> Int) -> (a -> a) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> a
forall a. Num a => a -> a -> a
* a
536870912) (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, a) -> a
forall a b. (a, b) -> b
snd ((Int, a) -> a) -> (a -> (Int, a)) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> (Int, a)
forall b. Integral b => a -> (b, a)
forall {a}. RealFrac a => a -> (Int, a)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction :: ((RealFrac a) => a -> (Int, a))) (a -> (Int, a)) -> (a -> a) -> a -> (Int, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
300)

intSeedToRand :: (Fractional a) => Int -> a
intSeedToRand :: forall a. Fractional a => Int -> a
intSeedToRand = (a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
536870912) (a -> a) -> (Int -> a) -> Int -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Int -> a) -> (Int -> Int) -> Int -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
536870912)

timeToRand :: (RealFrac a, Fractional b) => a -> b
timeToRand :: forall a b. (RealFrac a, Fractional b) => a -> b
timeToRand = Int -> b
forall a. Fractional a => Int -> a
intSeedToRand (Int -> b) -> (a -> Int) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a. RealFrac a => a -> Int
timeToIntSeed

timeToRands :: (RealFrac a, Fractional b) => a -> Int -> [b]
timeToRands :: forall a b. (RealFrac a, Fractional b) => a -> Int -> [b]
timeToRands a
0 Int
n = Int -> Int -> [b]
forall a. Fractional a => Int -> Int -> [a]
timeToRands' (Double -> Int
forall a. RealFrac a => a -> Int
timeToIntSeed (Double
9999999 :: Double)) Int
n
timeToRands a
t Int
n = Int -> Int -> [b]
forall a. Fractional a => Int -> Int -> [a]
timeToRands' (a -> Int
forall a. RealFrac a => a -> Int
timeToIntSeed a
t) Int
n

timeToRands' :: (Fractional a) => Int -> Int -> [a]
timeToRands' :: forall a. Fractional a => Int -> Int -> [a]
timeToRands' Int
seed Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = []
  | Bool
otherwise = Int -> a
forall a. Fractional a => Int -> a
intSeedToRand Int
seed a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Int -> Int -> [a]
forall a. Fractional a => Int -> Int -> [a]
timeToRands' (Int -> Int
xorwise Int
seed) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

-- |
--
-- @rand@ is an oscillator that generates a continuous pattern of (pseudo-)random
-- numbers between 0 and 1.
--
-- For example, to randomly pan around the stereo field:
--
-- > d1 $ sound "bd*8" # pan rand
--
-- Or to enjoy a randomised speed from 0.5 to 1.5, add 0.5 to it:
--
-- > d1 $ sound "arpy*4" # speed (rand + 0.5)
--
-- To make the snares randomly loud and quiet:
--
-- > sound "sn sn ~ sn" # gain rand
--
-- Numbers coming from this pattern are \'seeded\' by time. So if you reset time
-- (using 'resetCycles', 'setCycle', or 'cps') the random pattern will emit the
-- exact same _random_ numbers again.
--
-- In cases where you need two different random patterns, you can shift
-- one of them around to change the time from which the _random_ pattern
-- is read, note the difference:
--
-- > jux (# gain rand) $ sound "sn sn ~ sn" # gain rand
--
-- and with the juxed version shifted backwards for 1024 cycles:
--
-- > jux (# ((1024 <~) $ gain rand)) $ sound "sn sn ~ sn" # gain rand
rand :: (Fractional a) => Pattern a
rand :: forall a. Fractional a => Pattern a
rand = (State -> [Event a]) -> Pattern a
forall a. (State -> [Event a]) -> Pattern a
pattern (\(State a :: Arc
a@(Arc Time
s Time
e) ValueMap
_) -> [Context -> Maybe Arc -> Arc -> a -> Event a
forall a b. Context -> Maybe a -> a -> b -> EventF a b
Event ([((Int, Int), (Int, Int))] -> Context
Context []) Maybe Arc
forall a. Maybe a
Nothing Arc
a (Double -> a
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> a) -> Double -> a
forall a b. (a -> b) -> a -> b
$ (Time -> Double
forall a b. (RealFrac a, Fractional b) => a -> b
timeToRand ((Time
e Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
s) Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Time
2) :: Double))])

-- | Boolean rand - a continuous stream of true\/false values, with a 50\/50 chance.
brand :: Pattern Bool
brand :: Pattern Bool
brand = Double -> Pattern Bool
_brandBy Double
0.5

-- | Boolean rand with probability as input, e.g. @brandBy 0.25@ produces trues 25% of the time.
brandBy :: Pattern Double -> Pattern Bool
brandBy :: Pattern Double -> Pattern Bool
brandBy Pattern Double
probpat = Pattern (Pattern Bool) -> Pattern Bool
forall a. Pattern (Pattern a) -> Pattern a
innerJoin (Pattern (Pattern Bool) -> Pattern Bool)
-> Pattern (Pattern Bool) -> Pattern Bool
forall a b. (a -> b) -> a -> b
$ Double -> Pattern Bool
_brandBy (Double -> Pattern Bool)
-> Pattern Double -> Pattern (Pattern Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Double
probpat

_brandBy :: Double -> Pattern Bool
_brandBy :: Double -> Pattern Bool
_brandBy Double
prob = (Double -> Bool) -> Pattern Double -> Pattern Bool
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
prob) Pattern Double
forall a. Fractional a => Pattern a
rand

-- | Just like `rand` but for whole numbers, @irand n@ generates a pattern of (pseudo-) random whole numbers between @0@ to @n-1@ inclusive. Notably used to pick a random
-- samples from a folder:
--
-- @
-- d1 $ segment 4 $ n (irand 5) # sound "drum"
-- @
irand :: (Num a) => Pattern Int -> Pattern a
irand :: forall a. Num a => Pattern Int -> Pattern a
irand = (Pattern Int -> (Int -> Pattern a) -> Pattern a
forall a b. Pattern a -> (a -> Pattern b) -> Pattern b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Pattern a
forall a. Num a => Int -> Pattern a
_irand)

_irand :: (Num a) => Int -> Pattern a
_irand :: forall a. Num a => Int -> Pattern a
_irand Int
i = Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> a) -> (Double -> Int) -> Double -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor :: Double -> Int) (Double -> Int) -> (Double -> Double) -> Double -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i) (Double -> a) -> Pattern Double -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Double
forall a. Fractional a => Pattern a
rand

-- | 1D Perlin (smooth) noise, works like 'rand' but smoothly moves between random
-- values each cycle. @perlinWith@ takes a pattern as the random number generator's
-- "input" instead of automatically using the cycle count.
--
-- > d1 $ s "arpy*32" # cutoff (perlinWith (saw * 4) * 2000)
--
-- will generate a smooth random pattern for the cutoff frequency which will
-- repeat every cycle (because the saw does).
--
-- The `perlin` function uses the cycle count as input and can be used much like @rand@.
perlinWith :: (Fractional a) => Pattern Double -> Pattern a
perlinWith :: forall a. Fractional a => Pattern Double -> Pattern a
perlinWith Pattern Double
p = (Double -> a) -> Pattern Double -> Pattern a
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> a
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Pattern Double -> Pattern a) -> Pattern Double -> Pattern a
forall a b. (a -> b) -> a -> b
$ (Double -> Double -> Double -> Double
forall {a}. Floating a => a -> a -> a -> a
interp) (Double -> Double -> Double -> Double)
-> Pattern Double -> Pattern (Double -> Double -> Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern Double
p Pattern Double -> Pattern Double -> Pattern Double
forall a. Num a => a -> a -> a
- Pattern Double
pa) Pattern (Double -> Double -> Double)
-> Pattern Double -> Pattern (Double -> Double)
forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Double -> Double
forall a b. (RealFrac a, Fractional b) => a -> b
timeToRand (Double -> Double) -> Pattern Double -> Pattern Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Double
pa) Pattern (Double -> Double) -> Pattern Double -> Pattern Double
forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Double -> Double
forall a b. (RealFrac a, Fractional b) => a -> b
timeToRand (Double -> Double) -> Pattern Double -> Pattern Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Double
pb)
  where
    pa :: Pattern Double
pa = (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int -> Double) (Int -> Double) -> (Double -> Int) -> Double -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Double) -> Pattern Double -> Pattern Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Double
p
    pb :: Pattern Double
pb = (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int -> Double) (Int -> Double) -> (Double -> Int) -> Double -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> Int) -> (Double -> Int) -> Double -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Double) -> Pattern Double -> Pattern Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Double
p
    interp :: a -> a -> a -> a
interp a
x a
a a
b = a
a a -> a -> a
forall a. Num a => a -> a -> a
+ a -> a
forall {a}. Floating a => a -> a
smootherStep a
x a -> a -> a
forall a. Num a => a -> a -> a
* (a
b a -> a -> a
forall a. Num a => a -> a -> a
- a
a)
    smootherStep :: a -> a
smootherStep a
x = a
6.0 a -> a -> a
forall a. Num a => a -> a -> a
* a
x a -> a -> a
forall a. Floating a => a -> a -> a
** a
5 a -> a -> a
forall a. Num a => a -> a -> a
- a
15.0 a -> a -> a
forall a. Num a => a -> a -> a
* a
x a -> a -> a
forall a. Floating a => a -> a -> a
** a
4 a -> a -> a
forall a. Num a => a -> a -> a
+ a
10.0 a -> a -> a
forall a. Num a => a -> a -> a
* a
x a -> a -> a
forall a. Floating a => a -> a -> a
** a
3

-- | As 'perlin' with a suitable choice of input pattern (@'sig' 'fromRational'@).
--
--  The @perlin@ function produces a new random value to move to every cycle. If
--  you want a new random value to be generated more or less frequently, you can use
--  fast or slow, respectively:
--
--  > d1 $ sound "bd*32" # speed (fast 4 $ perlin + 0.5)
--  > d1 $ sound "bd*32" # speed (slow 4 $ perlin + 0.5)
perlin :: (Fractional a) => Pattern a
perlin :: forall a. Fractional a => Pattern a
perlin = Pattern Double -> Pattern a
forall a. Fractional a => Pattern Double -> Pattern a
perlinWith ((Time -> Double) -> Pattern Double
forall a. (Time -> a) -> Pattern a
sig Time -> Double
forall a. Fractional a => Time -> a
fromRational)

-- | @perlin2With@ is Perlin noise with a 2-dimensional input. This can be
-- useful for more control over how the randomness repeats (or doesn't).
--
-- @
-- d1
--  $ s "[supersaw:-12*32]"
--  # lpf (rangex 60 5000 $ perlin2With (cosine*2) (sine*2))
--  # lpq 0.3
-- @
--
-- The above will generate a smooth random cutoff pattern that repeats every cycle
-- without any reversals or discontinuities (because the 2D path is a circle).
--
-- See also: `perlin2`, which only needs one input because it uses the cycle count
-- as the second input.
perlin2With :: Pattern Double -> Pattern Double -> Pattern Double
perlin2With :: Pattern Double -> Pattern Double -> Pattern Double
perlin2With Pattern Double
x Pattern Double
y = (Pattern Double -> Pattern Double -> Pattern Double
forall a. Fractional a => a -> a -> a
/ Pattern Double
2) (Pattern Double -> Pattern Double)
-> (Pattern Double -> Pattern Double)
-> Pattern Double
-> Pattern Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pattern Double -> Pattern Double -> Pattern Double
forall a. Num a => a -> a -> a
+ Pattern Double
1) (Pattern Double -> Pattern Double)
-> Pattern Double -> Pattern Double
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double -> Double -> Double -> Double -> Double
forall {a}. Floating a => a -> a -> a -> a -> a -> a -> a
interp2 (Double
 -> Double -> Double -> Double -> Double -> Double -> Double)
-> Pattern Double
-> Pattern
     (Double -> Double -> Double -> Double -> Double -> Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Double
xfrac Pattern (Double -> Double -> Double -> Double -> Double -> Double)
-> Pattern Double
-> Pattern (Double -> Double -> Double -> Double -> Double)
forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern Double
yfrac Pattern (Double -> Double -> Double -> Double -> Double)
-> Pattern Double -> Pattern (Double -> Double -> Double -> Double)
forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern Double
dota Pattern (Double -> Double -> Double -> Double)
-> Pattern Double -> Pattern (Double -> Double -> Double)
forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern Double
dotb Pattern (Double -> Double -> Double)
-> Pattern Double -> Pattern (Double -> Double)
forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern Double
dotc Pattern (Double -> Double) -> Pattern Double -> Pattern Double
forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern Double
dotd
  where
    fl :: Pattern Double -> Pattern Double
fl = (Double -> Double) -> Pattern Double -> Pattern Double
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int -> Double) (Int -> Double) -> (Double -> Int) -> Double -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor)
    ce :: Pattern Double -> Pattern Double
ce = (Double -> Double) -> Pattern Double -> Pattern Double
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int -> Double) (Int -> Double) -> (Double -> Int) -> Double -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> Int) -> (Double -> Int) -> Double -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor)
    xfrac :: Pattern Double
xfrac = Pattern Double
x Pattern Double -> Pattern Double -> Pattern Double
forall a. Num a => a -> a -> a
- Pattern Double -> Pattern Double
fl Pattern Double
x
    yfrac :: Pattern Double
yfrac = Pattern Double
y Pattern Double -> Pattern Double -> Pattern Double
forall a. Num a => a -> a -> a
- Pattern Double -> Pattern Double
fl Pattern Double
y
    randAngle :: a -> a -> a
randAngle a
a a
b = a
2 a -> a -> a
forall a. Num a => a -> a -> a
* a
forall a. Floating a => a
pi a -> a -> a
forall a. Num a => a -> a -> a
* a -> a
forall a b. (RealFrac a, Fractional b) => a -> b
timeToRand (a
a a -> a -> a
forall a. Num a => a -> a -> a
+ a
0.0001 a -> a -> a
forall a. Num a => a -> a -> a
* a
b)
    pcos :: f a -> f a -> f b
pcos f a
x' f a
y' = f b -> f b
forall {a}. Floating a => a -> a
cos (f b -> f b) -> f b -> f b
forall a b. (a -> b) -> a -> b
$ a -> a -> b
forall {a} {a}. (Floating a, RealFrac a) => a -> a -> a
randAngle (a -> a -> b) -> f a -> f (a -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
x' f (a -> b) -> f a -> f b
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f a
y'
    psin :: f a -> f a -> f b
psin f a
x' f a
y' = f b -> f b
forall {a}. Floating a => a -> a
sin (f b -> f b) -> f b -> f b
forall a b. (a -> b) -> a -> b
$ a -> a -> b
forall {a} {a}. (Floating a, RealFrac a) => a -> a -> a
randAngle (a -> a -> b) -> f a -> f (a -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
x' f (a -> b) -> f a -> f b
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f a
y'
    dota :: Pattern Double
dota = Pattern Double -> Pattern Double -> Pattern Double
forall {f :: * -> *} {b} {a}.
(Applicative f, Floating b, Floating (f b), RealFrac a) =>
f a -> f a -> f b
pcos (Pattern Double -> Pattern Double
fl Pattern Double
x) (Pattern Double -> Pattern Double
fl Pattern Double
y) Pattern Double -> Pattern Double -> Pattern Double
forall a. Num a => a -> a -> a
* Pattern Double
xfrac Pattern Double -> Pattern Double -> Pattern Double
forall a. Num a => a -> a -> a
+ Pattern Double -> Pattern Double -> Pattern Double
forall {f :: * -> *} {b} {a}.
(Applicative f, Floating b, Floating (f b), RealFrac a) =>
f a -> f a -> f b
psin (Pattern Double -> Pattern Double
fl Pattern Double
x) (Pattern Double -> Pattern Double
fl Pattern Double
y) Pattern Double -> Pattern Double -> Pattern Double
forall a. Num a => a -> a -> a
* Pattern Double
yfrac
    dotb :: Pattern Double
dotb = Pattern Double -> Pattern Double -> Pattern Double
forall {f :: * -> *} {b} {a}.
(Applicative f, Floating b, Floating (f b), RealFrac a) =>
f a -> f a -> f b
pcos (Pattern Double -> Pattern Double
ce Pattern Double
x) (Pattern Double -> Pattern Double
fl Pattern Double
y) Pattern Double -> Pattern Double -> Pattern Double
forall a. Num a => a -> a -> a
* (Pattern Double
xfrac Pattern Double -> Pattern Double -> Pattern Double
forall a. Num a => a -> a -> a
- Pattern Double
1) Pattern Double -> Pattern Double -> Pattern Double
forall a. Num a => a -> a -> a
+ Pattern Double -> Pattern Double -> Pattern Double
forall {f :: * -> *} {b} {a}.
(Applicative f, Floating b, Floating (f b), RealFrac a) =>
f a -> f a -> f b
psin (Pattern Double -> Pattern Double
ce Pattern Double
x) (Pattern Double -> Pattern Double
fl Pattern Double
y) Pattern Double -> Pattern Double -> Pattern Double
forall a. Num a => a -> a -> a
* Pattern Double
yfrac
    dotc :: Pattern Double
dotc = Pattern Double -> Pattern Double -> Pattern Double
forall {f :: * -> *} {b} {a}.
(Applicative f, Floating b, Floating (f b), RealFrac a) =>
f a -> f a -> f b
pcos (Pattern Double -> Pattern Double
fl Pattern Double
x) (Pattern Double -> Pattern Double
ce Pattern Double
y) Pattern Double -> Pattern Double -> Pattern Double
forall a. Num a => a -> a -> a
* Pattern Double
xfrac Pattern Double -> Pattern Double -> Pattern Double
forall a. Num a => a -> a -> a
+ Pattern Double -> Pattern Double -> Pattern Double
forall {f :: * -> *} {b} {a}.
(Applicative f, Floating b, Floating (f b), RealFrac a) =>
f a -> f a -> f b
psin (Pattern Double -> Pattern Double
fl Pattern Double
x) (Pattern Double -> Pattern Double
ce Pattern Double
y) Pattern Double -> Pattern Double -> Pattern Double
forall a. Num a => a -> a -> a
* (Pattern Double
yfrac Pattern Double -> Pattern Double -> Pattern Double
forall a. Num a => a -> a -> a
- Pattern Double
1)
    dotd :: Pattern Double
dotd = Pattern Double -> Pattern Double -> Pattern Double
forall {f :: * -> *} {b} {a}.
(Applicative f, Floating b, Floating (f b), RealFrac a) =>
f a -> f a -> f b
pcos (Pattern Double -> Pattern Double
ce Pattern Double
x) (Pattern Double -> Pattern Double
ce Pattern Double
y) Pattern Double -> Pattern Double -> Pattern Double
forall a. Num a => a -> a -> a
* (Pattern Double
xfrac Pattern Double -> Pattern Double -> Pattern Double
forall a. Num a => a -> a -> a
- Pattern Double
1) Pattern Double -> Pattern Double -> Pattern Double
forall a. Num a => a -> a -> a
+ Pattern Double -> Pattern Double -> Pattern Double
forall {f :: * -> *} {b} {a}.
(Applicative f, Floating b, Floating (f b), RealFrac a) =>
f a -> f a -> f b
psin (Pattern Double -> Pattern Double
ce Pattern Double
x) (Pattern Double -> Pattern Double
ce Pattern Double
y) Pattern Double -> Pattern Double -> Pattern Double
forall a. Num a => a -> a -> a
* (Pattern Double
yfrac Pattern Double -> Pattern Double -> Pattern Double
forall a. Num a => a -> a -> a
- Pattern Double
1)
    interp2 :: a -> a -> a -> a -> a -> a -> a
interp2 a
x' a
y' a
a a
b a
c a
d =
      (a
1.0 a -> a -> a
forall a. Num a => a -> a -> a
- a -> a
forall {a}. Floating a => a -> a
s a
x') a -> a -> a
forall a. Num a => a -> a -> a
* (a
1.0 a -> a -> a
forall a. Num a => a -> a -> a
- a -> a
forall {a}. Floating a => a -> a
s a
y') a -> a -> a
forall a. Num a => a -> a -> a
* a
a
        a -> a -> a
forall a. Num a => a -> a -> a
+ a -> a
forall {a}. Floating a => a -> a
s a
x' a -> a -> a
forall a. Num a => a -> a -> a
* (a
1.0 a -> a -> a
forall a. Num a => a -> a -> a
- a -> a
forall {a}. Floating a => a -> a
s a
y') a -> a -> a
forall a. Num a => a -> a -> a
* a
b
        a -> a -> a
forall a. Num a => a -> a -> a
+ (a
1.0 a -> a -> a
forall a. Num a => a -> a -> a
- a -> a
forall {a}. Floating a => a -> a
s a
x') a -> a -> a
forall a. Num a => a -> a -> a
* a -> a
forall {a}. Floating a => a -> a
s a
y' a -> a -> a
forall a. Num a => a -> a -> a
* a
c
        a -> a -> a
forall a. Num a => a -> a -> a
+ a -> a
forall {a}. Floating a => a -> a
s a
x' a -> a -> a
forall a. Num a => a -> a -> a
* a -> a
forall {a}. Floating a => a -> a
s a
y' a -> a -> a
forall a. Num a => a -> a -> a
* a
d
    s :: a -> a
s a
x' = a
6.0 a -> a -> a
forall a. Num a => a -> a -> a
* a
x' a -> a -> a
forall a. Floating a => a -> a -> a
** a
5 a -> a -> a
forall a. Num a => a -> a -> a
- a
15.0 a -> a -> a
forall a. Num a => a -> a -> a
* a
x' a -> a -> a
forall a. Floating a => a -> a -> a
** a
4 a -> a -> a
forall a. Num a => a -> a -> a
+ a
10.0 a -> a -> a
forall a. Num a => a -> a -> a
* a
x' a -> a -> a
forall a. Floating a => a -> a -> a
** a
3

-- | As 'perlin2' with a suitable choice of input pattern (@'sig' 'fromRational'@).
perlin2 :: Pattern Double -> Pattern Double
perlin2 :: Pattern Double -> Pattern Double
perlin2 = Pattern Double -> Pattern Double -> Pattern Double
perlin2With ((Time -> Double) -> Pattern Double
forall a. (Time -> a) -> Pattern a
sig Time -> Double
forall a. Fractional a => Time -> a
fromRational)

-- | Generates values in [0,1] that follows a normal (bell-curve) distribution.
-- One possible application is to "humanize" drums with a slight random delay:
-- @
-- d1 $
--  s "bd sn bd sn"
--  # nudge (segment 4 (0.01 * normal))
-- @
-- Implemented with the Box-Muller transform.
--  * the max ensures we don't calculate log 0
--  * the rot in u2 ensures we don't just get the same value as u1
--  * clamp the Box-Muller generated values in a [-3,3] range
normal :: (Floating a, Ord a) => Pattern a
normal :: forall a. (Floating a, Ord a) => Pattern a
normal = do
  a
u1 <- a -> a -> a
forall a. Ord a => a -> a -> a
max a
0.001 (a -> a) -> Pattern a -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a
forall a. Fractional a => Pattern a
rand
  a
u2 <- Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
rotL Time
1000 Pattern a
forall a. Fractional a => Pattern a
rand
  let r1 :: a
r1 = a -> a
forall {a}. Floating a => a -> a
sqrt (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ -(a
2 a -> a -> a
forall a. Num a => a -> a -> a
* a -> a
forall {a}. Floating a => a -> a
log a
u1)
      r2 :: a
r2 = a -> a
forall {a}. Floating a => a -> a
cos (a
2 a -> a -> a
forall a. Num a => a -> a -> a
* a
forall a. Floating a => a
pi a -> a -> a
forall a. Num a => a -> a -> a
* a
u2)
      clamp :: a -> a
clamp a
n = a -> a -> a
forall a. Ord a => a -> a -> a
max (-a
3) (a -> a -> a
forall a. Ord a => a -> a -> a
min a
3 a
n)
  a -> Pattern a
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Pattern a) -> a -> Pattern a
forall a b. (a -> b) -> a -> b
$ a -> a
forall {a}. (Ord a, Num a) => a -> a
clamp (a
r1 a -> a -> a
forall a. Num a => a -> a -> a
* a
r2 a -> a -> a
forall a. Num a => a -> a -> a
+ a
3) a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
6

-- | Randomly picks an element from the given list.
--
-- @
-- sound "superpiano(3,8)" # note (choose ["a", "e", "g", "c"])
-- @
--
-- plays a melody randomly choosing one of the four notes \"a\", \"e\", \"g\", \"c\".
--
-- As with all continuous patterns, you have to be careful to give them structure; in this case choose gives you an infinitely detailed stream of random choices.
--
-- > choose = 'chooseBy' 'rand'
choose :: [a] -> Pattern a
choose :: forall a. [a] -> Pattern a
choose = Pattern Double -> [a] -> Pattern a
forall a. Pattern Double -> [a] -> Pattern a
chooseBy Pattern Double
forall a. Fractional a => Pattern a
rand

-- | Given a pattern of doubles, @chooseBy@ normalizes them so that each
-- corresponds to an index in the provided list. The returned pattern
-- contains the corresponding elements in the list.
--
-- It is like choose, but instead of selecting elements of the list randomly, it
-- uses the given pattern to select elements.
--
-- @'choose' = chooseBy 'rand'@
--
-- The following results in the pattern @"a b c"@:
--
-- > chooseBy "0 0.25 0.5" ["a","b","c","d"]
chooseBy :: Pattern Double -> [a] -> Pattern a
chooseBy :: forall a. Pattern Double -> [a] -> Pattern a
chooseBy Pattern Double
_ [] = Pattern a
forall a. Pattern a
silence
chooseBy Pattern Double
f [a]
xs = ([a]
xs [a] -> Int -> a
forall a. [a] -> Int -> a
!!!) (Int -> a) -> (Double -> Int) -> Double -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> a) -> Pattern Double -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Double
-> Pattern Double -> Pattern Double -> Pattern Double
forall a. Num a => Pattern a -> Pattern a -> Pattern a -> Pattern a
range Pattern Double
0 (Int -> Pattern Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Pattern Double) -> Int -> Pattern Double
forall a b. (a -> b) -> a -> b
$ [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs) Pattern Double
f

-- | Like @choose@, but works on an a list of tuples of values and weights
--
-- @
-- sound "superpiano(3,8)" # note (wchoose [("a",1), ("e",0.5), ("g",2), ("c",1)])
-- @
--
-- In the above example, the "a" and "c" notes are twice as likely to
-- play as the "e" note, and half as likely to play as the "g" note.
--
-- > wchoose = 'wchooseBy' 'rand'
wchoose :: [(a, Double)] -> Pattern a
wchoose :: forall a. [(a, Double)] -> Pattern a
wchoose = Pattern Double -> [(a, Double)] -> Pattern a
forall a. Pattern Double -> [(a, Double)] -> Pattern a
wchooseBy Pattern Double
forall a. Fractional a => Pattern a
rand

-- | Given a pattern of probabilities and a list of @(value, weight)@ pairs,
-- @wchooseBy@ creates a @'Pattern' value@ by choosing values based on those
-- probabilities and weighted appropriately by the weights in the list of pairs.
wchooseBy :: Pattern Double -> [(a, Double)] -> Pattern a
wchooseBy :: forall a. Pattern Double -> [(a, Double)] -> Pattern a
wchooseBy Pattern Double
pat [(a, Double)]
pairs = Double -> a
match (Double -> a) -> Pattern Double -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Double
pat
  where
    match :: Double -> a
match Double
r = [a]
values [a] -> Int -> a
forall a. HasCallStack => [a] -> Int -> a
!! [Int] -> Int
forall a. HasCallStack => [a] -> a
head ((Double -> Bool) -> [Double] -> [Int]
forall a. (a -> Bool) -> [a] -> [Int]
findIndices (Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> (Double
r Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
total)) [Double]
cweights)
    cweights :: [Double]
cweights = (Double -> Double -> Double) -> [Double] -> [Double]
forall a. (a -> a -> a) -> [a] -> [a]
scanl1 Double -> Double -> Double
forall a. Num a => a -> a -> a
(+) (((a, Double) -> Double) -> [(a, Double)] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (a, Double) -> Double
forall a b. (a, b) -> b
snd [(a, Double)]
pairs)
    values :: [a]
values = ((a, Double) -> a) -> [(a, Double)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, Double) -> a
forall a b. (a, b) -> a
fst [(a, Double)]
pairs
    total :: Double
total = [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Double] -> Double) -> [Double] -> Double
forall a b. (a -> b) -> a -> b
$ ((a, Double) -> Double) -> [(a, Double)] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (a, Double) -> Double
forall a b. (a, b) -> b
snd [(a, Double)]
pairs

-- | @randcat ps@: does a @slowcat@ on the list of patterns @ps@ but
--  randomises the order in which they are played.
--
--  > d1 $ sound (randcat ["bd*2 sn", "jvbass*3", "drum*2", "ht mt"])
randcat :: [Pattern a] -> Pattern a
randcat :: forall a. [Pattern a] -> Pattern a
randcat [Pattern a]
ps = (Time -> Pattern a -> Pattern a)
-> Pattern Time -> Pattern a -> Pattern a
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> m c) -> m a -> b -> m c
spread' Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
rotL (Time -> Pattern Time -> Pattern Time
forall a. Time -> Pattern a -> Pattern a
_segment Time
1 (Pattern Time -> Pattern Time) -> Pattern Time -> Pattern Time
forall a b. (a -> b) -> a -> b
$ (Integer -> Integer -> Time
forall a. Integral a => a -> a -> Ratio a
% Integer
1) (Integer -> Time) -> (Int -> Integer) -> Int -> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Time) -> Pattern Int -> Pattern Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Pattern Int
forall a. Num a => Int -> Pattern a
_irand ([Pattern a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern a]
ps) :: Pattern Int)) ([Pattern a] -> Pattern a
forall a. [Pattern a] -> Pattern a
slowcat [Pattern a]
ps)

-- | As 'randcat', but allowing weighted choice.
--
--  In the following, the first pattern is the most likely and will play about half the time, and the last pattern is the less likely, with only a 10% probability.
--
--  > d1 $ sound
--  >    $ wrandcat
--  >        [ ("bd*2 sn", 5), ("jvbass*3", 2), ("drum*2", 2), ("ht mt", 1) ]
wrandcat :: [(Pattern a, Double)] -> Pattern a
wrandcat :: forall a. [(Pattern a, Double)] -> Pattern a
wrandcat [(Pattern a, Double)]
ps = Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
unwrap (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ Pattern Double -> [(Pattern a, Double)] -> Pattern (Pattern a)
forall a. Pattern Double -> [(a, Double)] -> Pattern a
wchooseBy (Pattern Time -> Pattern Double -> Pattern Double
forall a. Pattern Time -> Pattern a -> Pattern a
segment Pattern Time
1 Pattern Double
forall a. Fractional a => Pattern a
rand) [(Pattern a, Double)]
ps

-- | @degrade@ randomly removes events from a pattern 50% of the time:
--
-- > d1 $ slow 2 $ degrade $ sound "[[[feel:5*8,feel*3] feel:3*8], feel*4]"
-- >    # accelerate "-6"
-- >    # speed "2"
--
-- The shorthand syntax for @degrade@ is a question mark: @?@. Using @?@
-- will allow you to randomly remove events from a portion of a pattern:
--
-- > d1 $ slow 2 $ sound "bd ~ sn bd ~ bd? [sn bd?] ~"
--
-- You can also use @?@ to randomly remove events from entire sub-patterns:
--
-- > d1 $ slow 2 $ sound "[[[feel:5*8,feel*3] feel:3*8]?, feel*4]"
degrade :: Pattern a -> Pattern a
degrade :: forall a. Pattern a -> Pattern a
degrade = Double -> Pattern a -> Pattern a
forall a. Double -> Pattern a -> Pattern a
_degradeBy Double
0.5

-- |
-- Similar to `degrade`, @degradeBy@ allows you to control the percentage of events that
-- are removed. For example, to remove events 90% of the time:
--
-- @
-- d1 $ slow 2 $ degradeBy 0.9 $ sound "[[[feel:5*8,feel*3] feel:3*8], feel*4]"
--    # accelerate "-6"
--    # speed "2"
-- @
--
-- You can also invoke this behavior in the shorthand notation by specifying a percentage, as a
-- number between 0 and 1, after the question mark:
--
-- @
-- d1 $ s "bd hh?0.8 bd hh?0.4"
-- @
degradeBy :: Pattern Double -> Pattern a -> Pattern a
degradeBy :: forall a. Pattern Double -> Pattern a -> Pattern a
degradeBy = (Double -> Pattern a -> Pattern a)
-> Pattern Double -> Pattern a -> Pattern a
forall b c a.
(b -> Pattern c -> Pattern a)
-> Pattern b -> Pattern c -> Pattern a
patternify' Double -> Pattern a -> Pattern a
forall a. Double -> Pattern a -> Pattern a
_degradeBy

_degradeBy :: Double -> Pattern a -> Pattern a
_degradeBy :: forall a. Double -> Pattern a -> Pattern a
_degradeBy = Pattern Double -> Double -> Pattern a -> Pattern a
forall a. Pattern Double -> Double -> Pattern a -> Pattern a
_degradeByUsing Pattern Double
forall a. Fractional a => Pattern a
rand

-- Useful for manipulating random stream, e.g. to change 'seed'
_degradeByUsing :: Pattern Double -> Double -> Pattern a -> Pattern a
_degradeByUsing :: forall a. Pattern Double -> Double -> Pattern a -> Pattern a
_degradeByUsing Pattern Double
prand Double
x Pattern a
p = ((a, Double) -> a) -> Pattern (a, Double) -> Pattern a
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, Double) -> a
forall a b. (a, b) -> a
fst (Pattern (a, Double) -> Pattern a)
-> Pattern (a, Double) -> Pattern a
forall a b. (a -> b) -> a -> b
$ ((a, Double) -> Bool) -> Pattern (a, Double) -> Pattern (a, Double)
forall a. (a -> Bool) -> Pattern a -> Pattern a
filterValues ((Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
x) (Double -> Bool) -> ((a, Double) -> Double) -> (a, Double) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Double) -> Double
forall a b. (a, b) -> b
snd) (Pattern (a, Double) -> Pattern (a, Double))
-> Pattern (a, Double) -> Pattern (a, Double)
forall a b. (a -> b) -> a -> b
$ (,) (a -> Double -> (a, Double))
-> Pattern a -> Pattern (Double -> (a, Double))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a
p Pattern (Double -> (a, Double))
-> Pattern Double -> Pattern (a, Double)
forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
<* Pattern Double
prand

-- |
-- As 'degradeBy', but the pattern of probabilities represents the chances to retain rather
-- than remove the corresponding element.
unDegradeBy :: Pattern Double -> Pattern a -> Pattern a
unDegradeBy :: forall a. Pattern Double -> Pattern a -> Pattern a
unDegradeBy = (Double -> Pattern a -> Pattern a)
-> Pattern Double -> Pattern a -> Pattern a
forall b c a.
(b -> Pattern c -> Pattern a)
-> Pattern b -> Pattern c -> Pattern a
patternify' Double -> Pattern a -> Pattern a
forall a. Double -> Pattern a -> Pattern a
_unDegradeBy

_unDegradeBy :: Double -> Pattern a -> Pattern a
_unDegradeBy :: forall a. Double -> Pattern a -> Pattern a
_unDegradeBy Double
x Pattern a
p = ((a, Double) -> a) -> Pattern (a, Double) -> Pattern a
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, Double) -> a
forall a b. (a, b) -> a
fst (Pattern (a, Double) -> Pattern a)
-> Pattern (a, Double) -> Pattern a
forall a b. (a -> b) -> a -> b
$ ((a, Double) -> Bool) -> Pattern (a, Double) -> Pattern (a, Double)
forall a. (a -> Bool) -> Pattern a -> Pattern a
filterValues ((Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
x) (Double -> Bool) -> ((a, Double) -> Double) -> (a, Double) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Double) -> Double
forall a b. (a, b) -> b
snd) (Pattern (a, Double) -> Pattern (a, Double))
-> Pattern (a, Double) -> Pattern (a, Double)
forall a b. (a -> b) -> a -> b
$ (,) (a -> Double -> (a, Double))
-> Pattern a -> Pattern (Double -> (a, Double))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a
p Pattern (Double -> (a, Double))
-> Pattern Double -> Pattern (a, Double)
forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
<* Pattern Double
forall a. Fractional a => Pattern a
rand

degradeOverBy :: Int -> Pattern Double -> Pattern a -> Pattern a
degradeOverBy :: forall a. Int -> Pattern Double -> Pattern a -> Pattern a
degradeOverBy Int
i Pattern Double
tx Pattern a
p = Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
unwrap (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ (\Double
x -> ((a, Double) -> a) -> Pattern (a, Double) -> Pattern a
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, Double) -> a
forall a b. (a, b) -> a
fst (Pattern (a, Double) -> Pattern a)
-> Pattern (a, Double) -> Pattern a
forall a b. (a -> b) -> a -> b
$ ((a, Double) -> Bool) -> Pattern (a, Double) -> Pattern (a, Double)
forall a. (a -> Bool) -> Pattern a -> Pattern a
filterValues ((Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
x) (Double -> Bool) -> ((a, Double) -> Double) -> (a, Double) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Double) -> Double
forall a b. (a, b) -> b
snd) (Pattern (a, Double) -> Pattern (a, Double))
-> Pattern (a, Double) -> Pattern (a, Double)
forall a b. (a -> b) -> a -> b
$ (,) (a -> Double -> (a, Double))
-> Pattern a -> Pattern (Double -> (a, Double))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a
p Pattern (Double -> (a, Double))
-> Pattern Double -> Pattern (a, Double)
forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
<* Int -> Pattern Double -> Pattern Double
forall a. Int -> Pattern a -> Pattern a
fastRepeatCycles Int
i Pattern Double
forall a. Fractional a => Pattern a
rand) (Double -> Pattern a) -> Pattern Double -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Time -> Pattern Double -> Pattern Double
forall a. Pattern Time -> Pattern a -> Pattern a
slow (Int -> Pattern Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i) Pattern Double
tx

-- | Use @sometimesBy@ to apply a given function "sometimes". For example, the
-- following code results in @density 2@ being applied about 25% of the time:
--
-- @
-- d1 $ sometimesBy 0.25 (density 2) $ sound "bd*8"
-- @
--
-- There are some aliases as well:
--
-- @
-- 'sometimes' = sometimesBy 0.5
-- 'often' = sometimesBy 0.75
-- 'rarely' = sometimesBy 0.25
-- 'almostNever' = sometimesBy 0.1
-- 'almostAlways' = sometimesBy 0.9
-- @
sometimesBy :: Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
sometimesBy :: forall a.
Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
sometimesBy Pattern Double
x Pattern a -> Pattern a
f Pattern a
pat = Pattern a -> Pattern a -> Pattern a
forall a. Pattern a -> Pattern a -> Pattern a
overlay (Pattern Double -> Pattern a -> Pattern a
forall a. Pattern Double -> Pattern a -> Pattern a
degradeBy Pattern Double
x Pattern a
pat) (Pattern a -> Pattern a
f (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ Pattern Double -> Pattern a -> Pattern a
forall a. Pattern Double -> Pattern a -> Pattern a
unDegradeBy Pattern Double
x Pattern a
pat)

-- | As 'sometimesBy', but applies the given transformation to the pattern in its entirety
-- before filtering its actual appearances. Less efficient than 'sometimesBy' but may
-- be useful when the passed pattern transformation depends on properties of the
-- pattern before probabilities are taken into account.
--
-- @
-- 'sometimes'' = sometimesBy' 0.5
-- 'often'' = sometimesBy' 0.75
-- 'rarely'' = sometimesBy' 0.25
-- 'almostNever'' = sometimesBy' 0.1
-- 'almostAlways'' = sometimesBy' 0.9
-- @
sometimesBy' :: Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
sometimesBy' :: forall a.
Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
sometimesBy' Pattern Double
x Pattern a -> Pattern a
f Pattern a
pat = Pattern a -> Pattern a -> Pattern a
forall a. Pattern a -> Pattern a -> Pattern a
overlay (Pattern Double -> Pattern a -> Pattern a
forall a. Pattern Double -> Pattern a -> Pattern a
degradeBy Pattern Double
x Pattern a
pat) (Pattern Double -> Pattern a -> Pattern a
forall a. Pattern Double -> Pattern a -> Pattern a
unDegradeBy Pattern Double
x (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ Pattern a -> Pattern a
f Pattern a
pat)

-- | @sometimes@ is an alias for @'sometimesBy' 0.5@.
sometimes :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
sometimes :: forall a. (Pattern a -> Pattern a) -> Pattern a -> Pattern a
sometimes = Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a.
Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
sometimesBy Pattern Double
0.5

-- | @sometimes'@ is an alias for @'sometimesBy'' 0.5@.
sometimes' :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
sometimes' :: forall a. (Pattern a -> Pattern a) -> Pattern a -> Pattern a
sometimes' = Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a.
Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
sometimesBy' Pattern Double
0.5

-- | @often@ is an alias for @'sometimesBy' 0.75@.
often :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
often :: forall a. (Pattern a -> Pattern a) -> Pattern a -> Pattern a
often = Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a.
Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
sometimesBy Pattern Double
0.75

-- | @often'@ is an alias for @'sometimesBy'' 0.75@.
often' :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
often' :: forall a. (Pattern a -> Pattern a) -> Pattern a -> Pattern a
often' = Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a.
Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
sometimesBy' Pattern Double
0.75

-- | @rarely@ is an alias for @'sometimesBy' 0.25@.
rarely :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
rarely :: forall a. (Pattern a -> Pattern a) -> Pattern a -> Pattern a
rarely = Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a.
Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
sometimesBy Pattern Double
0.25

-- | @rarely'@ is an alias for @'sometimesBy'' 0.25@.
rarely' :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
rarely' :: forall a. (Pattern a -> Pattern a) -> Pattern a -> Pattern a
rarely' = Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a.
Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
sometimesBy' Pattern Double
0.25

-- | @almostNever@ is an alias for @'sometimesBy' 0.1@.
almostNever :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
almostNever :: forall a. (Pattern a -> Pattern a) -> Pattern a -> Pattern a
almostNever = Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a.
Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
sometimesBy Pattern Double
0.1

-- | @almostNever'@ is an alias for @'sometimesBy'' 0.1@.
almostNever' :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
almostNever' :: forall a. (Pattern a -> Pattern a) -> Pattern a -> Pattern a
almostNever' = Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a.
Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
sometimesBy Pattern Double
0.1

-- | @almostAlways@ is an alias for @'sometimesBy' 0.9@.
almostAlways :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
almostAlways :: forall a. (Pattern a -> Pattern a) -> Pattern a -> Pattern a
almostAlways = Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a.
Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
sometimesBy Pattern Double
0.9

-- | @almostAlways'@ is an alias for @'sometimesBy'' 0.9@.
almostAlways' :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
almostAlways' :: forall a. (Pattern a -> Pattern a) -> Pattern a -> Pattern a
almostAlways' = Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a.
Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
sometimesBy' Pattern Double
0.9

-- |
-- Never apply a transformation, returning the pattern unmodified.
--
-- @never = flip const@
never :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
never :: forall a. (Pattern a -> Pattern a) -> Pattern a -> Pattern a
never = (Pattern a -> (Pattern a -> Pattern a) -> Pattern a)
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Pattern a -> (Pattern a -> Pattern a) -> Pattern a
forall a b. a -> b -> a
const

-- |
-- Apply the transformation to the pattern unconditionally.
--
-- @always = id@
always :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
always :: forall a. (Pattern a -> Pattern a) -> Pattern a -> Pattern a
always = (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a. a -> a
id

-- | @someCyclesBy@ is a cycle-by-cycle version of @'sometimesBy'@.
--
--  For example the following will either distort all of the events in a cycle, or
--  none of them:
--
--  > d1 $ someCyclesBy 0.5 (# crush 2) $ n "0 1 [~ 2] 3" # sound "arpy"
someCyclesBy :: Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
someCyclesBy :: forall a.
Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
someCyclesBy Pattern Double
pd Pattern a -> Pattern a
f Pattern a
pat = Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
innerJoin (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ (\Double
d -> Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a.
Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
_someCyclesBy Double
d Pattern a -> Pattern a
f Pattern a
pat) (Double -> Pattern a) -> Pattern Double -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Double
pd

_someCyclesBy :: Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
_someCyclesBy :: forall a.
Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
_someCyclesBy Double
x = (Int -> Bool) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a.
(Int -> Bool) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
when Int -> Bool
forall {a}. Integral a => a -> Bool
test
  where
    test :: a -> Bool
test a
c = Double -> Double
forall a b. (RealFrac a, Fractional b) => a -> b
timeToRand (a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
c :: Double) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
x

-- | Alias of 'someCyclesBy'.
somecyclesBy :: Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
somecyclesBy :: forall a.
Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
somecyclesBy = Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a.
Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
someCyclesBy

-- | @someCycles = 'someCyclesBy' 0.5@
someCycles :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
someCycles :: forall a. (Pattern a -> Pattern a) -> Pattern a -> Pattern a
someCycles = Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a.
Pattern Double
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
someCyclesBy Pattern Double
0.5

-- | Alias of 'someCycles'.
somecycles :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
somecycles :: forall a. (Pattern a -> Pattern a) -> Pattern a -> Pattern a
somecycles = (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a. (Pattern a -> Pattern a) -> Pattern a -> Pattern a
someCycles

-- ** Pattern transformations

--

-- $patternTransformations
--
-- Pattern transformations are functions generally of type
-- @'Pattern' a -> 'Pattern' a@. This means they take a pattern of any type
-- and return a pattern of that type.

-- |
-- @brak@ makes a pattern sound a bit like a breakbeat. It does this by, every
-- other cycle, squashing the pattern to fit half a cycle, and offsetting it by a
-- quarter of a cycle.
--
-- @
-- d1 $ sound (brak "bd sn kurt")
-- d1 $ brak $ sound "[feel feel:3, hc:3 hc:2 hc:4 ho:1]"
-- @
brak :: Pattern a -> Pattern a
brak :: forall a. Pattern a -> Pattern a
brak = (Int -> Bool) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a.
(Int -> Bool) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
when ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool) -> (Int -> Int) -> Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
2)) (((Integer
1 Integer -> Integer -> Time
forall a. Integral a => a -> a -> Ratio a
% Integer
4) Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
`rotR`) (Pattern a -> Pattern a)
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\Pattern a
x -> [Pattern a] -> Pattern a
forall a. [Pattern a] -> Pattern a
fastcat [Pattern a
x, Pattern a
forall a. Pattern a
silence]))

-- | Divides a pattern into a given number of subdivisions, plays the subdivisions
-- in order, but increments the starting subdivision each cycle. The pattern
-- wraps to the first subdivision after the last subdivision is played.
--
-- Example:
--
-- @
-- d1 $ iter 4 $ sound "bd hh sn cp"
-- @
--
-- This will produce the following over four cycles:
--
-- @
-- bd hh sn cp
-- hh sn cp bd
-- sn cp bd hh
-- cp bd hh sn
-- @
--
-- There is also `iter'`, which shifts the pattern in the opposite direction.
iter :: Pattern Int -> Pattern c -> Pattern c
iter :: forall c. Pattern Int -> Pattern c -> Pattern c
iter Pattern Int
a Pattern c
pat = Pattern c -> Pattern c -> Pattern c
forall a b. Pattern a -> Pattern b -> Pattern b
keepTactus Pattern c
pat (Pattern c -> Pattern c) -> Pattern c -> Pattern c
forall a b. (a -> b) -> a -> b
$ (Int -> Pattern c -> Pattern c)
-> Pattern Int -> Pattern c -> Pattern c
forall b c a.
(b -> Pattern c -> Pattern a)
-> Pattern b -> Pattern c -> Pattern a
patternify' Int -> Pattern c -> Pattern c
forall a. Int -> Pattern a -> Pattern a
_iter Pattern Int
a Pattern c
pat

_iter :: Int -> Pattern a -> Pattern a
_iter :: forall a. Int -> Pattern a -> Pattern a
_iter Int
n Pattern a
p = [Pattern a] -> Pattern a
forall a. [Pattern a] -> Pattern a
slowcat ([Pattern a] -> Pattern a) -> [Pattern a] -> Pattern a
forall a b. (a -> b) -> a -> b
$ (Int -> Pattern a) -> [Int] -> [Pattern a]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i Integer -> Integer -> Time
forall a. Integral a => a -> a -> Ratio a
% Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
`rotL` Pattern a
p) [Int
0 .. (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)]

-- | @iter'@ is the same as @iter@, but decrements the starting
-- subdivision instead of incrementing it. For example,
--
-- @
-- d1 $ iter' 4 $ sound "bd hh sn cp"
-- @
--
-- produces
--
-- @
-- bd hh sn cp
-- cp bd hh sn
-- sn cp bd hh
-- hh sn cp bd
-- @
iter' :: Pattern Int -> Pattern c -> Pattern c
iter' :: forall c. Pattern Int -> Pattern c -> Pattern c
iter' = (Int -> Pattern c -> Pattern c)
-> Pattern Int -> Pattern c -> Pattern c
forall b c a.
(b -> Pattern c -> Pattern a)
-> Pattern b -> Pattern c -> Pattern a
patternify' Int -> Pattern c -> Pattern c
forall a. Int -> Pattern a -> Pattern a
_iter'

_iter' :: Int -> Pattern a -> Pattern a
_iter' :: forall a. Int -> Pattern a -> Pattern a
_iter' Int
n Pattern a
p = [Pattern a] -> Pattern a
forall a. [Pattern a] -> Pattern a
slowcat ([Pattern a] -> Pattern a) -> [Pattern a] -> Pattern a
forall a b. (a -> b) -> a -> b
$ (Int -> Pattern a) -> [Int] -> [Pattern a]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i Integer -> Integer -> Time
forall a. Integral a => a -> a -> Ratio a
% Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
`rotR` Pattern a
p) [Int
0 .. (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)]

-- | @palindrome p@ applies @rev@ to @p@ every other cycle, so that the pattern
-- alternates between forwards and backwards. For example, these are equivalent:
--
-- @
-- d1 $ palindrome $ sound "arpy:0 arpy:1 arpy:2 arpy:3"
-- d1 $ slow 2 $ sound "arpy:0 arpy:1 arpy:2 arpy:3 arpy:3 arpy:2 arpy:1 arpy:0"
-- d1 $ every 2 rev $ sound "arpy:0 arpy:1 arpy:2 arpy:3"
-- @
palindrome :: Pattern a -> Pattern a
palindrome :: forall a. Pattern a -> Pattern a
palindrome Pattern a
p = Pattern a -> Pattern a -> Pattern a
forall a. Pattern a -> Pattern a -> Pattern a
slowAppend Pattern a
p (Pattern a -> Pattern a
forall a. Pattern a -> Pattern a
rev Pattern a
p)

-- | Degrades a pattern over the given time.
fadeOut :: Time -> Pattern a -> Pattern a
fadeOut :: forall a. Time -> Pattern a -> Pattern a
fadeOut Time
dur Pattern a
p = Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
innerJoin (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ (Double -> Pattern a -> Pattern a
forall a. Double -> Pattern a -> Pattern a
`_degradeBy` Pattern a
p) (Double -> Pattern a) -> Pattern Double -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Time -> Pattern Double -> Pattern Double
forall a. Time -> Pattern a -> Pattern a
_slow Time
dur Pattern Double
envL

-- | Alternate version to @fadeOut@ where you can provide the time from which the fade starts
fadeOutFrom :: Time -> Time -> Pattern a -> Pattern a
fadeOutFrom :: forall a. Time -> Time -> Pattern a -> Pattern a
fadeOutFrom Time
from Time
dur Pattern a
p = Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
innerJoin (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ (Double -> Pattern a -> Pattern a
forall a. Double -> Pattern a -> Pattern a
`_degradeBy` Pattern a
p) (Double -> Pattern a) -> Pattern Double -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Time
from Time -> Pattern Double -> Pattern Double
forall a. Time -> Pattern a -> Pattern a
`rotR` Time -> Pattern Double -> Pattern Double
forall a. Time -> Pattern a -> Pattern a
_slow Time
dur Pattern Double
envL)

-- | ’Undegrades’ a pattern over the given time.
fadeIn :: Time -> Pattern a -> Pattern a
fadeIn :: forall a. Time -> Pattern a -> Pattern a
fadeIn Time
dur Pattern a
p = Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
innerJoin (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ (Double -> Pattern a -> Pattern a
forall a. Double -> Pattern a -> Pattern a
`_degradeBy` Pattern a
p) (Double -> Pattern a) -> Pattern Double -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Time -> Pattern Double -> Pattern Double
forall a. Time -> Pattern a -> Pattern a
_slow Time
dur Pattern Double
envLR

-- | Alternate version to @fadeIn@ where you can provide the time from
-- which the fade in starts
fadeInFrom :: Time -> Time -> Pattern a -> Pattern a
fadeInFrom :: forall a. Time -> Time -> Pattern a -> Pattern a
fadeInFrom Time
from Time
dur Pattern a
p = Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
innerJoin (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ (Double -> Pattern a -> Pattern a
forall a. Double -> Pattern a -> Pattern a
`_degradeBy` Pattern a
p) (Double -> Pattern a) -> Pattern Double -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Time
from Time -> Pattern Double -> Pattern Double
forall a. Time -> Pattern a -> Pattern a
`rotR` Time -> Pattern Double -> Pattern Double
forall a. Time -> Pattern a -> Pattern a
_slow Time
dur Pattern Double
envLR)

-- | The 'spread' function allows you to take a pattern transformation
-- which takes a parameter, such as `slow`, and provide several
-- parameters which are switched between. In other words it "spreads" a
-- function across several values.
--
-- Taking a simple high hat loop as an example:
--
-- > d1 $ sound "ho ho:2 ho:3 hc"
--
-- We can slow it down by different amounts, such as by a half:
--
-- > d1 $ slow 2 $ sound "ho ho:2 ho:3 hc"
--
-- Or by four thirds (i.e. speeding it up by a third; @4%3@ means four over
-- three):
--
-- > d1 $ slow (4%3) $ sound "ho ho:2 ho:3 hc"
--
-- But if we use `spread`, we can make a pattern which alternates between
-- the two speeds:
--
-- > d1 $ spread slow [2,4%3] $ sound "ho ho:2 ho:3 hc"
--
-- Note that if you pass @($)@ as the function to spread values over, you
-- can put functions as the list of values. ('spreadf' is an alias for @spread ($)@.)
-- For example:
--
-- > d1 $ spread ($) [density 2, rev, slow 2, striate 3, (# speed "0.8")]
-- >    $ sound "[bd*2 [~ bd]] [sn future]*2 cp jvbass*4"
--
-- Above, the pattern will have these transforms applied to it, one at a time, per cycle:
--
-- * cycle 1: @density 2@ - pattern will increase in speed
-- * cycle 2: @rev@ - pattern will be reversed
-- * cycle 3: @slow 2@ - pattern will decrease in speed
-- * cycle 4: @striate 3@ - pattern will be granualized
-- * cycle 5: @(# speed "0.8")@ - pattern samples will be played back more slowly
--
-- After @(# speed "0.8")@, the transforms will repeat and start at @density 2@ again.
spread :: (a -> t -> Pattern b) -> [a] -> t -> Pattern b
spread :: forall a t b. (a -> t -> Pattern b) -> [a] -> t -> Pattern b
spread a -> t -> Pattern b
f [a]
xs t
p = [Pattern b] -> Pattern b
forall a. [Pattern a] -> Pattern a
slowcat ([Pattern b] -> Pattern b) -> [Pattern b] -> Pattern b
forall a b. (a -> b) -> a -> b
$ (a -> Pattern b) -> [a] -> [Pattern b]
forall a b. (a -> b) -> [a] -> [b]
map (a -> t -> Pattern b
`f` t
p) [a]
xs

-- | An alias for 'spread' consistent with 'fastspread'.
slowspread :: (a -> t -> Pattern b) -> [a] -> t -> Pattern b
slowspread :: forall a t b. (a -> t -> Pattern b) -> [a] -> t -> Pattern b
slowspread = (a -> t -> Pattern b) -> [a] -> t -> Pattern b
forall a t b. (a -> t -> Pattern b) -> [a] -> t -> Pattern b
spread

-- | @fastspread@ works the same as `spread`, but the result is squashed into a single cycle. If you gave four values to @spread@, then the result would seem to speed up by a factor of four. Compare these two:
--
-- > d1 $ spread chop [4,64,32,16] $ sound "ho ho:2 ho:3 hc"
-- > d1 $ fastspread chop [4,64,32,16] $ sound "ho ho:2 ho:3 hc"
--
-- There is also `slowspread`, which is an alias of @spread@.
fastspread :: (a -> t -> Pattern b) -> [a] -> t -> Pattern b
fastspread :: forall a t b. (a -> t -> Pattern b) -> [a] -> t -> Pattern b
fastspread a -> t -> Pattern b
f [a]
xs t
p = [Pattern b] -> Pattern b
forall a. [Pattern a] -> Pattern a
fastcat ([Pattern b] -> Pattern b) -> [Pattern b] -> Pattern b
forall a b. (a -> b) -> a -> b
$ (a -> Pattern b) -> [a] -> [Pattern b]
forall a b. (a -> b) -> [a] -> [b]
map (a -> t -> Pattern b
`f` t
p) [a]
xs

-- | There's a version of this function, `spread'` (pronounced "spread prime"), which takes a /pattern/ of parameters, instead of a list:
--
-- > d1 $ spread' slow "2 4%3" $ sound "ho ho:2 ho:3 hc"
--
-- This is quite a messy area of Tidal—due to a slight difference of
-- implementation this sounds completely different! One advantage of
-- using `spread'` though is that you can provide polyphonic parameters, e.g.:
--
-- > d1 $ spread' slow "[2 4%3, 3]" $ sound "ho ho:2 ho:3 hc"
spread' :: (Monad m) => (a -> b -> m c) -> m a -> b -> m c
spread' :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> m c) -> m a -> b -> m c
spread' a -> b -> m c
f m a
vpat b
pat = m a
vpat m a -> (a -> m c) -> m c
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
v -> a -> b -> m c
f a
v b
pat

-- | @spreadChoose f xs p@ is similar to `slowspread` but picks values from
-- @xs@ at random, rather than cycling through them in order.
--
-- > d1 $ spreadChoose ($) [gap 4, striate 4] $ sound "ho ho:2 ho:3 hc"
spreadChoose :: (t -> t1 -> Pattern b) -> [t] -> t1 -> Pattern b
spreadChoose :: forall a t b. (a -> t -> Pattern b) -> [a] -> t -> Pattern b
spreadChoose t -> t1 -> Pattern b
f [t]
vs t1
p = do
  t
v <- Time -> Pattern t -> Pattern t
forall a. Time -> Pattern a -> Pattern a
_segment Time
1 ([t] -> Pattern t
forall a. [a] -> Pattern a
choose [t]
vs)
  t -> t1 -> Pattern b
f t
v t1
p

-- | A shorter alias for 'spreadChoose'.
spreadr :: (t -> t1 -> Pattern b) -> [t] -> t1 -> Pattern b
spreadr :: forall a t b. (a -> t -> Pattern b) -> [a] -> t -> Pattern b
spreadr = (t -> t1 -> Pattern b) -> [t] -> t1 -> Pattern b
forall a t b. (a -> t -> Pattern b) -> [a] -> t -> Pattern b
spreadChoose

-- | Decide whether to apply one or another function depending on the result of a test function, which is passed the current cycle as a number.
--
-- @
-- d1 $ ifp ((== 0) . flip mod 2)
--         (striate 4)
--         (# coarse "24 48")
--   $ sound "hh hc"
-- @
--
-- This will apply @'striate' 4@ for every /even/ cycle and apply @# coarse "24 48"@ for every /odd/.
--
-- Detail: As you can see the test function is arbitrary and does not rely on
-- anything Tidal specific. In fact it uses only plain Haskell functionality, that
-- is: it calculates the modulo of 2 of the current cycle which is either 0 (for
-- even cycles) or 1. It then compares this value against 0 and returns the result,
-- which is either @True@ or @False@. This is what the @ifp@ signature's first part
-- signifies: @(Int -> Bool)@, a function that takes a whole number and returns
-- either @True@ or @False@.
ifp :: (Int -> Bool) -> (Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
ifp :: forall a.
(Int -> Bool)
-> (Pattern a -> Pattern a)
-> (Pattern a -> Pattern a)
-> Pattern a
-> Pattern a
ifp Int -> Bool
test Pattern a -> Pattern a
f1 Pattern a -> Pattern a
f2 Pattern a
p = Pattern a -> Pattern a
forall a. Pattern a -> Pattern a
splitQueries (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ Pattern a
p {query = q, pureValue = Nothing}
  where
    q :: State -> [Event a]
q State
a
      | Int -> Bool
test (Time -> Int
forall b. Integral b => Time -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Time -> Int) -> Time -> Int
forall a b. (a -> b) -> a -> b
$ Arc -> Time
forall a. ArcF a -> a
start (Arc -> Time) -> Arc -> Time
forall a b. (a -> b) -> a -> b
$ State -> Arc
arc State
a) = Pattern a -> State -> [Event a]
forall a. Pattern a -> State -> [Event a]
query (Pattern a -> Pattern a
f1 Pattern a
p) State
a
      | Bool
otherwise = Pattern a -> State -> [Event a]
forall a. Pattern a -> State -> [Event a]
query (Pattern a -> Pattern a
f2 Pattern a
p) State
a

-- | @wedge t p p'@ combines patterns @p@ and @p'@ by squashing the
-- @p@ into the portion of each cycle given by @t@, and @p'@ into the
-- remainer of each cycle.
-- > d1 $ wedge (1/4) (sound "bd*2 arpy*3 cp sn*2") (sound "odx [feel future]*2 hh hh")
wedge :: Pattern Time -> Pattern a -> Pattern a -> Pattern a
wedge :: forall a. Pattern Time -> Pattern a -> Pattern a -> Pattern a
wedge Pattern Time
pt Pattern a
pa Pattern a
pb = Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
innerJoin (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ (\Time
t -> Time -> Pattern a -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a -> Pattern a
_wedge Time
t Pattern a
pa Pattern a
pb) (Time -> Pattern a) -> Pattern Time -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Time
pt

_wedge :: Time -> Pattern a -> Pattern a -> Pattern a
_wedge :: forall a. Time -> Pattern a -> Pattern a -> Pattern a
_wedge Time
0 Pattern a
_ Pattern a
p' = Pattern a
p'
_wedge Time
1 Pattern a
p Pattern a
_ = Pattern a
p
_wedge Time
t Pattern a
p Pattern a
p' = Pattern a -> Pattern a -> Pattern a
forall a. Pattern a -> Pattern a -> Pattern a
overlay (Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
_fastGap (Time
1 Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Time
t) Pattern a
p) (Time
t Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
`rotR` Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
_fastGap (Time
1 Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ (Time
1 Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
t)) Pattern a
p')

-- | @whenmod@ has a similar form and behavior to `every`, but requires an
-- additional number. It applies the function to the pattern when the
-- remainder of the current loop number divided by the first parameter
-- is greater or equal than the second parameter.
--
-- For example, the following makes every other block of four loops twice
-- as dense:
--
-- > d1 $ whenmod 8 4 (density 2) (sound "bd sn kurt")
whenmod :: Pattern Time -> Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
whenmod :: forall a.
Pattern Time
-> Pattern Time
-> (Pattern a -> Pattern a)
-> Pattern a
-> Pattern a
whenmod Pattern Time
a Pattern Time
b Pattern a -> Pattern a
f Pattern a
pat = Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
innerJoin (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ (\Time
a' Time
b' -> Time -> Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a.
Time -> Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
_whenmod Time
a' Time
b' Pattern a -> Pattern a
f Pattern a
pat) (Time -> Time -> Pattern a)
-> Pattern Time -> Pattern (Time -> Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Time
a Pattern (Time -> Pattern a) -> Pattern Time -> Pattern (Pattern a)
forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern Time
b

_whenmod :: Time -> Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
_whenmod :: forall a.
Time -> Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
_whenmod Time
a Time
b = (Time -> Bool)
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a.
(Time -> Bool)
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
whenT (\Time
t -> ((Time
t Time -> Time -> Time
forall a. Real a => a -> a -> a
`mod'` Time
a) Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
b))

-- |
-- > superimpose f p = stack [p, f p]
--
-- @superimpose@ plays a modified version of a pattern at the same time as the
-- original pattern, resulting in two patterns being played at the same time. The
-- following are equivalent:
--
-- > d1 $ superimpose (fast 2) $ sound "bd sn [cp ht] hh"
-- > d1 $ stack [sound "bd sn [cp ht] hh",
-- >             fast 2 $ sound "bd sn [cp ht] hh"
-- >            ]
--
-- More examples:
--
-- > d1 $ superimpose (density 2) $ sound "bd sn [cp ht] hh"
-- > d1 $ superimpose ((# speed "2") . (0.125 <~)) $ sound "bd sn cp hh"
superimpose :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
superimpose :: forall a. (Pattern a -> Pattern a) -> Pattern a -> Pattern a
superimpose Pattern a -> Pattern a
f Pattern a
p = [Pattern a] -> Pattern a
forall a. [Pattern a] -> Pattern a
stack [Pattern a
p, Pattern a -> Pattern a
f Pattern a
p]

-- | @trunc@ truncates a pattern so that only a fraction of the pattern is played.
-- The following example plays only the first quarter of the pattern:
--
-- > d1 $ trunc 0.25 $ sound "bd sn*2 cp hh*4 arpy bd*2 cp bd*2"
--
-- You can also pattern the first parameter, for example to cycle through three values, one per cycle:
--
-- > d1 $ trunc "<0.75 0.25 1>" $ sound "bd sn:2 [mt rs] hc"
trunc :: Pattern Time -> Pattern a -> Pattern a
trunc :: forall a. Pattern Time -> Pattern a -> Pattern a
trunc = (Time -> Pattern a -> Pattern a)
-> Pattern Time -> Pattern a -> Pattern a
forall b c a.
(b -> Pattern c -> Pattern a)
-> Pattern b -> Pattern c -> Pattern a
patternify' Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
_trunc

_trunc :: Time -> Pattern a -> Pattern a
_trunc :: forall a. Time -> Pattern a -> Pattern a
_trunc Time
t = (Time, Time) -> Pattern a -> Pattern a
forall a. (Time, Time) -> Pattern a -> Pattern a
compress (Time
0, Time
t) (Pattern a -> Pattern a)
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arc -> Pattern a -> Pattern a
forall a. Arc -> Pattern a -> Pattern a
zoomArc (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc Time
0 Time
t)

-- | @linger@ is similar to `trunc`, in that it truncates a pattern so that
-- only the first fraction of the pattern is played, but the truncated part of the
-- pattern loops to fill the remainder of the cycle.
--
-- > d1 $ linger 0.25 $ sound "bd sn*2 cp hh*4 arpy bd*2 cp bd*2"
--
-- For example this repeats the first quarter, so you only hear a single repeating note:
--
-- > d1 $ linger 0.25 $ n "0 2 [3 4] 2" # sound "arpy"
--
-- or slightly more interesting, applied only every fourth cycle:
--
-- > d1 $ every 4 (linger 0.25) $ n "0 2 [3 4] 2" # sound "arpy"
--
-- or to a chopped-up sample:
--
-- > d1 $ every 2 (linger 0.25) $ loopAt 2 $ chop 8 $ sound "breaks125"
--
-- You can also pattern the first parameter, for example to cycle through three
-- values, one per cycle:
--
-- > d1 $ linger "<0.75 0.25 1>" $ sound "bd sn:2 [mt rs] hc"
-- > d1 $ linger "<0.25 0.5 1>" $ loopAt 2 $ chop 8 $ sound "breaks125"
--
-- If you give it a negative number, it will linger on the last part of
-- the pattern, instead of the start of it. E.g. to linger on the last
-- quarter:
--
-- > d1 $ linger (-0.25) $ sound "bd sn*2 cp hh*4 arpy bd*2 cp bd*2"
linger :: Pattern Time -> Pattern a -> Pattern a
linger :: forall a. Pattern Time -> Pattern a -> Pattern a
linger = (Time -> Pattern a -> Pattern a)
-> Pattern Time -> Pattern a -> Pattern a
forall b c a.
(b -> Pattern c -> Pattern a)
-> Pattern b -> Pattern c -> Pattern a
patternify' Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
_linger

_linger :: Time -> Pattern a -> Pattern a
_linger :: forall a. Time -> Pattern a -> Pattern a
_linger Time
n Pattern a
p
  | Time
n Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
0 = Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
_fast (Time
1 Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Time
n) (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ Arc -> Pattern a -> Pattern a
forall a. Arc -> Pattern a -> Pattern a
zoomArc (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc (Time
1 Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
n) Time
1) Pattern a
p
  | Bool
otherwise = Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
_fast (Time
1 Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Time
n) (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ Arc -> Pattern a -> Pattern a
forall a. Arc -> Pattern a -> Pattern a
zoomArc (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc Time
0 Time
n) Pattern a
p

-- |
-- Use @within@ to apply a function to only a part of a pattern. It takes two
-- arguments: a start time and an end time, specified as floats between 0 and 1,
-- which are applied to the relevant pattern. Note that the second argument must be
-- greater than the first for the function to have any effect.
--
-- For example, to apply @'fast' 2@ to only the first half of a pattern:
--
-- > d1 $ within (0, 0.5) (fast 2) $ sound "bd*2 sn lt mt hh hh hh hh"
--
-- Or, to apply @(# 'speed' "0.5")@ to only the last quarter of a pattern:
--
-- > d1 $ within (0.75, 1) (# speed "0.5") $ sound "bd*2 sn lt mt hh hh hh hh"
within :: (Time, Time) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
within :: forall a.
(Time, Time) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
within (Time
s, Time
e) Pattern a -> Pattern a
f Pattern a
p =
  [Pattern a] -> Pattern a
forall a. [Pattern a] -> Pattern a
stack
    [ (Time -> Bool) -> Pattern a -> Pattern a
forall a. (Time -> Bool) -> Pattern a -> Pattern a
filterWhen (\Time
t -> Time -> Time
cyclePos Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
s Bool -> Bool -> Bool
&& Time -> Time
cyclePos Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
e) (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ Pattern a -> Pattern a
f Pattern a
p,
      (Time -> Bool) -> Pattern a -> Pattern a
forall a. (Time -> Bool) -> Pattern a -> Pattern a
filterWhen (\Time
t -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Time -> Time
cyclePos Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
s Bool -> Bool -> Bool
&& Time -> Time
cyclePos Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
e) Pattern a
p
    ]

withinArc :: Arc -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
withinArc :: forall a. Arc -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
withinArc (Arc Time
s Time
e) = (Time, Time) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a.
(Time, Time) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
within (Time
s, Time
e)

-- |
-- For many cases, @within'@ will function exactly as within.
-- The difference between the two occurs when applying functions that change the timing of notes such as 'fast' or '<~'.
-- within first applies the function to all notes in the cycle, then keeps the results in the specified interval, and then combines it with the old cycle (an "apply split combine" paradigm).
-- within' first keeps notes in the specified interval, then applies the function to these notes, and then combines it with the old cycle (a "split apply combine" paradigm).
--
-- For example, whereas using the standard version of within
--
-- > d1 $ within (0, 0.25) (fast 2) $ sound "bd hh cp sd"
--
-- sounds like:
--
-- > d1 $ sound "[bd hh] hh cp sd"
--
-- using this alternative version, within'
--
-- > d1 $ within' (0, 0.25) (fast 2) $ sound "bd hh cp sd"
--
-- sounds like:
--
-- > d1 $ sound "[bd bd] hh cp sd"
within' :: (Time, Time) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
within' :: forall a.
(Time, Time) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
within' a :: (Time, Time)
a@(Time
s, Time
e) Pattern a -> Pattern a
f Pattern a
p =
  [Pattern a] -> Pattern a
forall a. [Pattern a] -> Pattern a
stack
    [ (Time -> Bool) -> Pattern a -> Pattern a
forall a. (Time -> Bool) -> Pattern a -> Pattern a
filterWhen (\Time
t -> Time -> Time
cyclePos Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
s Bool -> Bool -> Bool
&& Time -> Time
cyclePos Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
e) (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ (Time, Time) -> Pattern a -> Pattern a
forall a. (Time, Time) -> Pattern a -> Pattern a
compress (Time, Time)
a (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ Pattern a -> Pattern a
f (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ (Time, Time) -> Pattern a -> Pattern a
forall a. (Time, Time) -> Pattern a -> Pattern a
zoom (Time, Time)
a Pattern a
p,
      (Time -> Bool) -> Pattern a -> Pattern a
forall a. (Time -> Bool) -> Pattern a -> Pattern a
filterWhen (\Time
t -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Time -> Time
cyclePos Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
s Bool -> Bool -> Bool
&& Time -> Time
cyclePos Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
e) Pattern a
p
    ]

-- |
-- Reverse the part of the pattern sliced out by the @(start, end)@ pair.
--
-- @revArc a = within a rev@
revArc :: (Time, Time) -> Pattern a -> Pattern a
revArc :: forall a. (Time, Time) -> Pattern a -> Pattern a
revArc (Time, Time)
a = (Time, Time) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a.
(Time, Time) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
within (Time, Time)
a Pattern a -> Pattern a
forall a. Pattern a -> Pattern a
rev

-- | You can use the @euclid@ function to apply a Euclidean algorithm over a
-- complex pattern, although the structure of that pattern will be lost:
--
-- > d1 $ euclid 3 8 $ sound "bd*2 [sn cp]"
--
-- In the above, three sounds are picked from the pattern on the right according
-- to the structure given by the @euclid 3 8@. It ends up picking two @bd@ sounds, a
-- @cp@ and missing the @sn@ entirely.
--
-- A negative first argument provides the inverse of the euclidean pattern.
--
-- These types of sequences use "Bjorklund's algorithm", which wasn't made for
-- music but for an application in nuclear physics, which is exciting. More
-- exciting still is that it is very similar in structure to the one of the first
-- known algorithms written in Euclid's book of elements in 300 BC. You can read
-- more about this in the paper
-- [The Euclidean Algorithm Generates Traditional Musical Rhythms](http://cgm.cs.mcgill.ca/~godfried/publications/banff.pdf)
-- by Toussaint. Some examples from this paper are included below,
-- including rotation as a third parameter in some cases (see 'euclidOff').
--
-- +------------+-----------------------------------------------------------------+
-- | Pattern    | Example                                                         |
-- +============+=================================================================+
-- | (2,5)      | A thirteenth century Persian rhythm called Khafif-e-ramal.      |
-- +------------+-----------------------------------------------------------------+
-- | (3,4)      | The archetypal pattern of the Cumbia from Colombia, as well as  |
-- |            | a Calypso rhythm from Trinidad.                                 |
-- +------------+-----------------------------------------------------------------+
-- | (3,5,2)    | Another thirteenth century Persian rhythm by the name of        |
-- |            | Khafif-e-ramal, as well as a Rumanian folk-dance rhythm.        |
-- +------------+-----------------------------------------------------------------+
-- | (3,7)      | A Ruchenitza rhythm used in a Bulgarian folk-dance.             |
-- +------------+-----------------------------------------------------------------+
-- | (3,8)      | The Cuban tresillo pattern.                                     |
-- +------------+-----------------------------------------------------------------+
-- | (4,7)      | Another Ruchenitza Bulgarian folk-dance rhythm.                 |
-- +------------+-----------------------------------------------------------------+
-- | (4,9)      | The Aksak rhythm of Turkey.                                     |
-- +------------+-----------------------------------------------------------------+
-- | (4,11)     | The metric pattern used by Frank Zappa in his piece titled      |
-- |            | Outside Now.                                                    |
-- +------------+-----------------------------------------------------------------+
-- | (5,6)      | Yields the York-Samai pattern, a popular Arab rhythm.           |
-- +------------+-----------------------------------------------------------------+
-- | (5,7)      | The Nawakhat pattern, another popular Arab rhythm.              |
-- +------------+-----------------------------------------------------------------+
-- | (5,8)      | The Cuban cinquillo pattern.                                    |
-- +------------+-----------------------------------------------------------------+
-- | (5,9)      | A popular Arab rhythm called Agsag-Samai.                       |
-- +------------+-----------------------------------------------------------------+
-- | (5,11)     | The metric pattern used by Moussorgsky in                       |
-- |            | Pictures at an Exhibition.                                      |
-- +------------+-----------------------------------------------------------------+
-- | (5,12)     | The Venda clapping pattern of a South African children’s song.  |
-- +------------+-----------------------------------------------------------------+
-- | (5,16)     | The Bossa-Nova rhythm necklace of Brazil.                       |
-- +------------+-----------------------------------------------------------------+
-- | (7,8)      | A typical rhythm played on the Bendir (frame drum).             |
-- +------------+-----------------------------------------------------------------+
-- | (7,12)     | A common West African bell pattern.                             |
-- +------------+-----------------------------------------------------------------+
-- | (7,16,14)  | A Samba rhythm necklace from Brazil.                            |
-- +------------+-----------------------------------------------------------------+
-- | (9,16)     | A rhythm necklace used in the Central African Republic.         |
-- +------------+-----------------------------------------------------------------+
-- | (11,24,14) | A rhythm necklace of the Aka Pygmies of Central Africa.         |
-- +------------+-----------------------------------------------------------------+
-- | (13,24,5)  | Another rhythm necklace of the Aka Pygmies of the upper Sangha. |
-- +------------+-----------------------------------------------------------------+
--
-- There was once a shorter alias @e@ for this function. It has been removed, but you
-- may see references to it in older Tidal code.
euclid :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a
euclid :: forall a. Pattern Int -> Pattern Int -> Pattern a -> Pattern a
euclid = (Int -> Int -> Pattern a -> Pattern a)
-> Pattern Int -> Pattern Int -> Pattern a -> Pattern a
forall a b c d.
(a -> b -> c -> Pattern d)
-> Pattern a -> Pattern b -> c -> Pattern d
patternify2 Int -> Int -> Pattern a -> Pattern a
forall a. Int -> Int -> Pattern a -> Pattern a
_euclid

_euclid :: Int -> Int -> Pattern a -> Pattern a
_euclid :: forall a. Int -> Int -> Pattern a -> Pattern a
_euclid Int
n Int
k Pattern a
a
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 = [Pattern a] -> Pattern a
forall a. [Pattern a] -> Pattern a
fastcat ([Pattern a] -> Pattern a) -> [Pattern a] -> Pattern a
forall a b. (a -> b) -> a -> b
$ (Bool -> Pattern a) -> [Bool] -> [Pattern a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pattern a -> Pattern a -> Bool -> Pattern a
forall a. a -> a -> Bool -> a
bool Pattern a
forall a. Pattern a
silence Pattern a
a) ([Bool] -> [Pattern a]) -> [Bool] -> [Pattern a]
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> [Bool]
bjorklund (Int
n, Int
k)
  | Bool
otherwise = [Pattern a] -> Pattern a
forall a. [Pattern a] -> Pattern a
fastcat ([Pattern a] -> Pattern a) -> [Pattern a] -> Pattern a
forall a b. (a -> b) -> a -> b
$ (Bool -> Pattern a) -> [Bool] -> [Pattern a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pattern a -> Pattern a -> Bool -> Pattern a
forall a. a -> a -> Bool -> a
bool Pattern a
a Pattern a
forall a. Pattern a
silence) ([Bool] -> [Pattern a]) -> [Bool] -> [Pattern a]
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> [Bool]
bjorklund (-Int
n, Int
k)

-- |
--
-- @euclidFull n k pa pb@ stacks @'euclid' n k pa@ with @'euclidInv' n k pb@. That
-- is, it plays one pattern on the euclidean rhythm and a different pattern on
-- the off-beat.
--
-- For example, to implement the traditional flamenco rhythm, you could use hard
-- claps for the former and soft claps for the latter:
--
-- > d1 $ euclidFull 3 7 "realclaps" ("realclaps" # gain 0.8)
euclidFull :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a -> Pattern a
euclidFull :: forall a.
Pattern Int -> Pattern Int -> Pattern a -> Pattern a -> Pattern a
euclidFull Pattern Int
n Pattern Int
k Pattern a
pa Pattern a
pb = [Pattern a] -> Pattern a
forall a. [Pattern a] -> Pattern a
stack [Pattern Int -> Pattern Int -> Pattern a -> Pattern a
forall a. Pattern Int -> Pattern Int -> Pattern a -> Pattern a
euclid Pattern Int
n Pattern Int
k Pattern a
pa, Pattern Int -> Pattern Int -> Pattern a -> Pattern a
forall a. Pattern Int -> Pattern Int -> Pattern a -> Pattern a
euclidInv Pattern Int
n Pattern Int
k Pattern a
pb]

-- | Less expressive than 'euclid' due to its constrained types, but may be more efficient.
_euclidBool :: Int -> Int -> Pattern Bool -- TODO: add 'euclidBool'?
_euclidBool :: Int -> Int -> Pattern Bool
_euclidBool Int
n Int
k
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 = [Bool] -> Pattern Bool
forall a. [a] -> Pattern a
fastFromList ([Bool] -> Pattern Bool) -> [Bool] -> Pattern Bool
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> [Bool]
bjorklund (Int
n, Int
k)
  | Bool
otherwise = [Bool] -> Pattern Bool
forall a. [a] -> Pattern a
fastFromList ([Bool] -> Pattern Bool) -> [Bool] -> Pattern Bool
forall a b. (a -> b) -> a -> b
$ (Bool -> Bool) -> [Bool] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Bool
not) ([Bool] -> [Bool]) -> [Bool] -> [Bool]
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> [Bool]
bjorklund (-Int
n, Int
k)

_euclid' :: Int -> Int -> Pattern a -> Pattern a
_euclid' :: forall a. Int -> Int -> Pattern a -> Pattern a
_euclid' Int
n Int
k Pattern a
p = [Pattern a] -> Pattern a
forall a. [Pattern a] -> Pattern a
fastcat ([Pattern a] -> Pattern a) -> [Pattern a] -> Pattern a
forall a b. (a -> b) -> a -> b
$ (Bool -> Pattern a) -> [Bool] -> [Pattern a]
forall a b. (a -> b) -> [a] -> [b]
map (\Bool
x -> if Bool
x then Pattern a
p else Pattern a
forall a. Pattern a
silence) ((Int, Int) -> [Bool]
bjorklund (Int
n, Int
k))

-- |
-- As 'euclid', but taking a third rotational parameter corresponding to the onset
-- at which to start the rhythm.
euclidOff :: Pattern Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a
euclidOff :: forall a.
Pattern Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a
euclidOff = (Int -> Int -> Int -> Pattern a -> Pattern a)
-> Pattern Int
-> Pattern Int
-> Pattern Int
-> Pattern a
-> Pattern a
forall a b c d e.
(a -> b -> c -> Pattern d -> Pattern e)
-> Pattern a -> Pattern b -> Pattern c -> Pattern d -> Pattern e
patternify3 Int -> Int -> Int -> Pattern a -> Pattern a
forall a. Int -> Int -> Int -> Pattern a -> Pattern a
_euclidOff

-- | A shorter alias for 'euclidOff'.
eoff :: Pattern Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a
eoff :: forall a.
Pattern Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a
eoff = Pattern Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a
forall a.
Pattern Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a
euclidOff

_euclidOff :: Int -> Int -> Int -> Pattern a -> Pattern a
_euclidOff :: forall a. Int -> Int -> Int -> Pattern a -> Pattern a
_euclidOff Int
_ Int
0 Int
_ Pattern a
_ = Pattern a
forall a. Pattern a
silence
_euclidOff Int
n Int
k Int
s Pattern a
p = (Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
rotL (Time -> Pattern a -> Pattern a) -> Time -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s Integer -> Integer -> Time
forall a. Integral a => a -> a -> Ratio a
% Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
k) (Int -> Int -> Pattern a -> Pattern a
forall a. Int -> Int -> Pattern a -> Pattern a
_euclid Int
n Int
k Pattern a
p)

-- | As 'euclidOff', but specialized to 'Bool'. May be more efficient than 'euclidOff'.
euclidOffBool :: Pattern Int -> Pattern Int -> Pattern Int -> Pattern Bool -> Pattern Bool
euclidOffBool :: Pattern Int
-> Pattern Int -> Pattern Int -> Pattern Bool -> Pattern Bool
euclidOffBool = (Int -> Int -> Int -> Pattern Bool -> Pattern Bool)
-> Pattern Int
-> Pattern Int
-> Pattern Int
-> Pattern Bool
-> Pattern Bool
forall a b c d e.
(a -> b -> c -> Pattern d -> Pattern e)
-> Pattern a -> Pattern b -> Pattern c -> Pattern d -> Pattern e
patternify3 Int -> Int -> Int -> Pattern Bool -> Pattern Bool
_euclidOffBool

_euclidOffBool :: Int -> Int -> Int -> Pattern Bool -> Pattern Bool
_euclidOffBool :: Int -> Int -> Int -> Pattern Bool -> Pattern Bool
_euclidOffBool Int
_ Int
0 Int
_ Pattern Bool
_ = Pattern Bool
forall a. Pattern a
silence
_euclidOffBool Int
n Int
k Int
s Pattern Bool
p = ((Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s Integer -> Integer -> Time
forall a. Integral a => a -> a -> Ratio a
% Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
k) Time -> Pattern Bool -> Pattern Bool
forall a. Time -> Pattern a -> Pattern a
`rotL`) ((\Bool
a Bool
b -> if Bool
b then Bool
a else Bool -> Bool
not Bool
a) (Bool -> Bool -> Bool) -> Pattern Bool -> Pattern (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> Pattern Bool
_euclidBool Int
n Int
k Pattern (Bool -> Bool) -> Pattern Bool -> Pattern Bool
forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern Bool
p)

distrib :: [Pattern Int] -> Pattern a -> Pattern a
distrib :: forall a. [Pattern Int] -> Pattern a -> Pattern a
distrib [Pattern Int]
ps Pattern a
p = do
  [Int]
p' <- [Pattern Int] -> Pattern [Int]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Pattern Int]
ps
  [Int] -> Pattern a -> Pattern a
forall a. [Int] -> Pattern a -> Pattern a
_distrib [Int]
p' Pattern a
p

_distrib :: [Int] -> Pattern a -> Pattern a
_distrib :: forall a. [Int] -> Pattern a -> Pattern a
_distrib [Int]
xs Pattern a
p = [Bool] -> Pattern a -> Pattern a
forall {b}. [Bool] -> Pattern b -> Pattern b
boolsToPat (([Bool] -> [Bool] -> [Bool]) -> [Bool] -> [[Bool]] -> [Bool]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [Bool] -> [Bool] -> [Bool]
distrib' (Int -> Bool -> [Bool]
forall a. Int -> a -> [a]
replicate ([Int] -> Int
forall a. HasCallStack => [a] -> a
last [Int]
xs) Bool
True) ([[Bool]] -> [[Bool]]
forall a. [a] -> [a]
reverse ([[Bool]] -> [[Bool]]) -> [[Bool]] -> [[Bool]]
forall a b. (a -> b) -> a -> b
$ [Int] -> [[Bool]]
layers [Int]
xs)) Pattern a
p
  where
    distrib' :: [Bool] -> [Bool] -> [Bool]
    distrib' :: [Bool] -> [Bool] -> [Bool]
distrib' [] [Bool]
_ = []
    distrib' (Bool
_ : [Bool]
a) [] = Bool
False Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: [Bool] -> [Bool] -> [Bool]
distrib' [Bool]
a []
    distrib' (Bool
True : [Bool]
a) (Bool
x : [Bool]
b) = Bool
x Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: [Bool] -> [Bool] -> [Bool]
distrib' [Bool]
a [Bool]
b
    distrib' (Bool
False : [Bool]
a) [Bool]
b = Bool
False Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: [Bool] -> [Bool] -> [Bool]
distrib' [Bool]
a [Bool]
b
    layers :: [Int] -> [[Bool]]
layers = ((Int, Int) -> [Bool]) -> [(Int, Int)] -> [[Bool]]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> [Bool]
bjorklund ([(Int, Int)] -> [[Bool]])
-> ([Int] -> [(Int, Int)]) -> [Int] -> [[Bool]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Int] -> [Int] -> [(Int, Int)])
-> ([Int] -> [Int]) -> [Int] -> [(Int, Int)]
forall a b. ([Int] -> a -> b) -> ([Int] -> a) -> [Int] -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
1)
    boolsToPat :: [Bool] -> Pattern b -> Pattern b
boolsToPat [Bool]
a Pattern b
b' = (b -> Bool -> b) -> Bool -> b -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip b -> Bool -> b
forall a b. a -> b -> a
const (Bool -> b -> b) -> Pattern Bool -> Pattern (b -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Bool) -> Pattern Bool -> Pattern Bool
forall a. (a -> Bool) -> Pattern a -> Pattern a
filterValues (Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
True) ([Bool] -> Pattern Bool
forall a. [a] -> Pattern a
fastFromList [Bool]
a) Pattern (b -> b) -> Pattern b -> Pattern b
forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
<* Pattern b
b'

-- | @euclidInv@ fills in the blanks left by `euclid`, i.e., it inverts the
-- pattern.
--
-- For example, whereas @euclid 3 8 "x"@ produces
--
-- > "x ~ ~ x ~ ~ x ~"
--
-- @euclidInv 3 8 "x"@ produces
--
-- > "~ x x ~ x x ~ x"
--
-- As another example, in
--
-- > d1 $ stack [ euclid 5 8 $ s "bd"
-- >            , euclidInv 5 8 $ s "hh27"
-- >            ]
--
-- the hi-hat event fires on every one of the eight even beats that the bass drum
-- does not.
euclidInv :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a
euclidInv :: forall a. Pattern Int -> Pattern Int -> Pattern a -> Pattern a
euclidInv = (Int -> Int -> Pattern a -> Pattern a)
-> Pattern Int -> Pattern Int -> Pattern a -> Pattern a
forall a b c d.
(a -> b -> c -> Pattern d)
-> Pattern a -> Pattern b -> c -> Pattern d
patternify2 Int -> Int -> Pattern a -> Pattern a
forall a. Int -> Int -> Pattern a -> Pattern a
_euclidInv

_euclidInv :: Int -> Int -> Pattern a -> Pattern a
_euclidInv :: forall a. Int -> Int -> Pattern a -> Pattern a
_euclidInv Int
n Int
k Pattern a
a = Int -> Int -> Pattern a -> Pattern a
forall a. Int -> Int -> Pattern a -> Pattern a
_euclid (-Int
n) Int
k Pattern a
a

index :: (Real b) => b -> Pattern b -> Pattern c -> Pattern c
index :: forall b c. Real b => b -> Pattern b -> Pattern c -> Pattern c
index b
sz Pattern b
indexpat Pattern c
pat =
  (Time -> Pattern c -> Pattern c)
-> Pattern Time -> Pattern c -> Pattern c
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> m c) -> m a -> b -> m c
spread' (Time -> Time -> Pattern c -> Pattern c
forall a. Time -> Time -> Pattern a -> Pattern a
zoom' (Time -> Time -> Pattern c -> Pattern c)
-> Time -> Time -> Pattern c -> Pattern c
forall a b. (a -> b) -> a -> b
$ b -> Time
forall a. Real a => a -> Time
toRational b
sz) (b -> Time
forall a. Real a => a -> Time
toRational (b -> Time) -> (b -> b) -> b -> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> b -> b
forall a. Num a => a -> a -> a
* (b
1 b -> b -> b
forall a. Num a => a -> a -> a
- b
sz)) (b -> Time) -> Pattern b -> Pattern Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern b
indexpat) Pattern c
pat
  where
    zoom' :: Time -> Time -> Pattern a -> Pattern a
zoom' Time
tSz Time
s = Arc -> Pattern a -> Pattern a
forall a. Arc -> Pattern a -> Pattern a
zoomArc (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc Time
s (Time
s Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
tSz))

{-
-- | @prrw f rot (blen, vlen) beatPattern valuePattern@: pattern rotate/replace.
prrw :: (a -> b -> c) -> Int -> (Time, Time) -> Pattern a -> Pattern b -> Pattern c
prrw f rot (blen, vlen) beatPattern valuePattern =
  let
    ecompare (_,e1,_) (_,e2,_) = compare (fst e1) (fst e2)
    beats  = sortBy ecompare $ arc beatPattern (0, blen)
    values = fmap thd' . sortBy ecompare $ arc valuePattern (0, vlen)
    cycles = blen * (fromIntegral $ lcm (length beats) (length values) `div` (length beats))
  in
    _slow cycles $ stack $ zipWith
    (\( _, (start, end), v') v -> (start `rotR`) $ densityGap (1 / (end - start)) $ pure (f v' v))
    (sortBy ecompare $ arc (_fast cycles $ beatPattern) (0, blen))
    (drop (rot `mod` length values) $ cycle values)

-- | @prr rot (blen, vlen) beatPattern valuePattern@: pattern rotate/replace.
prr :: Int -> (Time, Time) -> Pattern String -> Pattern b -> Pattern b
prr = prrw $ flip const

{-|
@preplace (blen, plen) beats values@ combines the timing of @beats@ with the values
of @values@. Other ways of saying this are:
\* sequential convolution
\* @values@ quantized to @beats@.

Examples:

@
d1 $ sound $ preplace (1,1) "x [~ x] x x" "bd sn"
d1 $ sound $ preplace (1,1) "x(3,8)" "bd sn"
d1 $ sound $ "x(3,8)" <~> "bd sn"
d1 $ sound "[jvbass jvbass:5]*3" |+| (shape $ "1 1 1 1 1" <~> "0.2 0.9")
@

It is assumed the pattern fits into a single cycle. This works well with
pattern literals, but not always with patterns defined elsewhere. In those cases
use @preplace@ and provide desired pattern lengths:
@
let p = slow 2 $ "x x x"

d1 $ sound $ preplace (2,1) p "bd sn"
@
-}
preplace :: (Time, Time) -> Pattern String -> Pattern b -> Pattern b
preplace = preplaceWith $ flip const

-- | @prep@ is an alias for preplace.
prep :: (Time, Time) -> Pattern String -> Pattern b -> Pattern b
prep = preplace

preplace1 :: Pattern String -> Pattern b -> Pattern b
preplace1 = preplace (1, 1)

preplaceWith :: (a -> b -> c) -> (Time, Time) -> Pattern a -> Pattern b -> Pattern c
preplaceWith f (blen, plen) = prrw f 0 (blen, plen)

prw :: (a -> b -> c) -> (Time, Time) -> Pattern a -> Pattern b -> Pattern c
prw = preplaceWith

preplaceWith1 :: (a -> b -> c) -> Pattern a -> Pattern b -> Pattern c
preplaceWith1 f = prrw f 0 (1, 1)

prw1 :: (a -> b -> c) -> Pattern a -> Pattern b -> Pattern c
prw1 = preplaceWith1

(<~>) :: Pattern String -> Pattern b -> Pattern b
(<~>) = preplace (1, 1)

-- | @protate len rot p@ rotates pattern @p@ by @rot@ beats to the left.
-- @len@: length of the pattern, in cycles.
-- Example: @d1 $ every 4 (protate 2 (-1)) $ slow 2 $ sound "bd hh hh hh"@
protate :: Time -> Int -> Pattern a -> Pattern a
protate len rot p = prrw (flip const) rot (len, len) p p

prot :: Time -> Int -> Pattern a -> Pattern a
prot = protate

prot1 :: Int -> Pattern a -> Pattern a
prot1 = protate 1

{-| The @<<~@ operator rotates a unit pattern to the left, similar to @<~@,
but by events rather than linear time. The timing of the pattern remains constant:

@
d1 $ (1 <<~) $ sound "bd ~ sn hh"
-- will become
d1 $ sound "sn ~ hh bd"
@ -}

(<<~) :: Int -> Pattern a -> Pattern a
(<<~) = protate 1

-- | @~>>@ is like @<<~@ but for shifting to the right.
(~>>) :: Int -> Pattern a -> Pattern a
(~>>) = (<<~) . (0-)

-- | @pequal cycles p1 p2@: quickly test if @p1@ and @p2@ are the same.
pequal :: Ord a => Time -> Pattern a -> Pattern a -> Bool
pequal cycles p1 p2 = (sort $ arc p1 (0, cycles)) == (sort $ arc p2 (0, cycles))
-}

-- | @rot n p@ "rotates" the values in a pattern @p@ by @n@ beats to the left,
-- preserving its structure. For example, in the following, each value will shift
-- to its neighbour's position one step to the left, so that @b@ takes the place of
-- @a@, @a@ of @c@, and @c@ of @b@:
--
-- > rot 1 "a ~ b c"
--
-- The result is equivalent of:
--
-- > "b ~ c a"
--
-- The first parameter is the number of steps, and may be given as a pattern. For example, in
--
-- > d1 $ rot "<0 0 1 3>" $ n "0 ~ 1 2 0 2 ~ 3*2" # sound "drum"
--
-- the pattern will not be rotated for the first two cycles, but will rotate it
-- by one the third cycle, and by three the fourth cycle.
--
-- Additional example:
--
-- > d1 $ every 4 (rot 2) $ slow 2 $ sound "bd hh hh hh"
rot :: (Ord a) => Pattern Int -> Pattern a -> Pattern a
rot :: forall a. Ord a => Pattern Int -> Pattern a -> Pattern a
rot = (Int -> Pattern a -> Pattern a)
-> Pattern Int -> Pattern a -> Pattern a
forall b c a.
(b -> Pattern c -> Pattern a)
-> Pattern b -> Pattern c -> Pattern a
patternify' Int -> Pattern a -> Pattern a
forall a. Ord a => Int -> Pattern a -> Pattern a
_rot

-- | Calculates a whole cycle, rotates it, then constrains events to the original query arc.
_rot :: (Ord a) => Int -> Pattern a -> Pattern a
_rot :: forall a. Ord a => Int -> Pattern a -> Pattern a
_rot Int
i Pattern a
pat = Pattern a -> Pattern a
forall a. Pattern a -> Pattern a
splitQueries (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ Pattern a
pat {query = \State
st -> State -> [Event a] -> [Event a]
forall {a}. Ord a => State -> [Event a] -> [Event a]
f State
st (Pattern a -> State -> [Event a]
forall a. Pattern a -> State -> [Event a]
query Pattern a
pat (State
st {arc = wholeCycle (arc st)}))}
  where
    -- TODO maybe events with the same arc (part+whole) should be
    -- grouped together in the rotation?
    f :: State -> [Event a] -> [Event a]
f State
st [Event a]
es = Arc -> [Event a] -> [Event a]
forall a. Arc -> [Event a] -> [Event a]
constrainEvents (State -> Arc
arc State
st) ([Event a] -> [Event a]) -> [Event a] -> [Event a]
forall a b. (a -> b) -> a -> b
$ [Event a] -> [Event a]
forall {a} {b}. [EventF a b] -> [EventF a b]
shiftValues ([Event a] -> [Event a]) -> [Event a] -> [Event a]
forall a b. (a -> b) -> a -> b
$ [Event a] -> [Event a]
forall a. Ord a => [a] -> [a]
sort ([Event a] -> [Event a]) -> [Event a] -> [Event a]
forall a b. (a -> b) -> a -> b
$ [Event a] -> [Event a]
forall a. Eq a => [Event a] -> [Event a]
defragParts [Event a]
es
    shiftValues :: [EventF a b] -> [EventF a b]
shiftValues [EventF a b]
es
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 =
          (EventF a b -> b -> EventF a b)
-> [EventF a b] -> [b] -> [EventF a b]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
            (\EventF a b
e b
s -> EventF a b
e {value = s})
            [EventF a b]
es
            (Int -> [b] -> [b]
forall a. Int -> [a] -> [a]
drop Int
i ([b] -> [b]) -> [b] -> [b]
forall a b. (a -> b) -> a -> b
$ [b] -> [b]
forall a. HasCallStack => [a] -> [a]
cycle ([b] -> [b]) -> [b] -> [b]
forall a b. (a -> b) -> a -> b
$ (EventF a b -> b) -> [EventF a b] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map EventF a b -> b
forall a b. EventF a b -> b
value [EventF a b]
es)
      | Bool
otherwise =
          (EventF a b -> b -> EventF a b)
-> [EventF a b] -> [b] -> [EventF a b]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
            (\EventF a b
e b
s -> EventF a b
e {value = s})
            [EventF a b]
es
            (Int -> [b] -> [b]
forall a. Int -> [a] -> [a]
drop ([EventF a b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EventF a b]
es Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int
forall a. Num a => a -> a
abs Int
i) ([b] -> [b]) -> [b] -> [b]
forall a b. (a -> b) -> a -> b
$ [b] -> [b]
forall a. HasCallStack => [a] -> [a]
cycle ([b] -> [b]) -> [b] -> [b]
forall a b. (a -> b) -> a -> b
$ (EventF a b -> b) -> [EventF a b] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map EventF a b -> b
forall a b. EventF a b -> b
value [EventF a b]
es)
    wholeCycle :: Arc -> Arc
wholeCycle (Arc Time
s Time
_) = Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc (Time -> Time
sam Time
s) (Time -> Time
nextSam Time
s)
    constrainEvents :: Arc -> [Event a] -> [Event a]
    constrainEvents :: forall a. Arc -> [Event a] -> [Event a]
constrainEvents Arc
a [Event a]
es = (Event a -> Maybe (Event a)) -> [Event a] -> [Event a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Arc -> Event a -> Maybe (Event a)
forall a. Arc -> Event a -> Maybe (Event a)
constrainEvent Arc
a) [Event a]
es
    constrainEvent :: Arc -> Event a -> Maybe (Event a)
    constrainEvent :: forall a. Arc -> Event a -> Maybe (Event a)
constrainEvent Arc
a Event a
e =
      do
        Arc
p' <- Arc -> Arc -> Maybe Arc
subArc (Event a -> Arc
forall a b. EventF a b -> a
part Event a
e) Arc
a
        Event a -> Maybe (Event a)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Event a
e {part = p'}

-- | @segment n p@ ’samples’ the pattern @p@ at a rate of @n@ events per cycle.
-- Useful for turning a continuous pattern into a discrete one.
--
-- In the following example, the pattern originates from the shape of a sine
-- wave, a continuous pattern. Without @segment@, the samples will get triggered
-- at an undefined frequency which may be very high.
--
-- > d1 $ n (slow 2 $ segment 16 $ range 0 32 $ sine) # sound "amencutup"
segment :: Pattern Time -> Pattern a -> Pattern a
segment :: forall a. Pattern Time -> Pattern a -> Pattern a
segment = (Time -> Pattern a -> Pattern a)
-> Pattern Time -> Pattern a -> Pattern a
forall t1 t2 a.
(t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a
patternify Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
_segment

_segment :: Time -> Pattern a -> Pattern a
_segment :: forall a. Time -> Pattern a -> Pattern a
_segment Time
n Pattern a
p = Maybe (Pattern Time) -> Pattern a -> Pattern a
forall a. Maybe (Pattern Time) -> Pattern a -> Pattern a
setTactus (Pattern Time -> Maybe (Pattern Time)
forall a. a -> Maybe a
Just (Pattern Time -> Maybe (Pattern Time))
-> Pattern Time -> Maybe (Pattern Time)
forall a b. (a -> b) -> a -> b
$ Time -> Pattern Time
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Time
n) (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ Time -> Pattern (a -> a) -> Pattern (a -> a)
forall a. Time -> Pattern a -> Pattern a
_fast Time
n ((a -> a) -> Pattern (a -> a)
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> a
forall a. a -> a
id) Pattern (a -> a) -> Pattern a -> Pattern a
forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
<* Pattern a
p

-- | @discretise@: the old (deprecated) name for 'segment'
discretise :: Pattern Time -> Pattern a -> Pattern a
discretise :: forall a. Pattern Time -> Pattern a -> Pattern a
discretise = Pattern Time -> Pattern a -> Pattern a
forall a. Pattern Time -> Pattern a -> Pattern a
segment

-- @fromNote p@: converts a pattern of human-readable pitch names
-- into pitch numbers. For example, @"cs2"@ will be parsed as C Sharp
-- in the 2nd octave with the result of @11@, and @"b-3"@ as
-- @-25@. Pitches can be decorated using:
--
--    * s = Sharp, a half-step above (@"gs-1"@)
--    * f = Flat, a half-step below (@"gf-1"@)
--    * n = Natural, no decoration (@"g-1" and "gn-1"@ are equivalent)
--    * ss = Double sharp, a whole step above (@"gss-1"@)
--    * ff = Double flat, a whole step below (@"gff-1"@)
--
-- Note that TidalCycles now assumes that middle C is represented by
-- the value 0, rather than the previous value of 60. This function
-- is similar to previously available functions @tom@ and @toMIDI@,
-- but the default octave is now 0 rather than 5.
{-

definition moved to Parse.hs ..

toMIDI :: Pattern String -> Pattern Int
toMIDI p = fromJust <$> (filterValues (isJust) (noteLookup <$> p))
  where
    noteLookup :: String -> Maybe Int
    noteLookup [] = Nothing
    noteLookup s | not (last s `elem` ['0' .. '9']) = noteLookup (s ++ "0")
                 | not (isLetter (s !! 1)) = noteLookup((head s):'n':(tail s))
                 | otherwise = parse s
    parse x = (\a b c -> a+b+c) <$> pc x <*> sym x <*> Just(12*digitToInt (last x))
    pc x = lookup (head x) [('c',0),('d',2),('e',4),('f',5),('g',7),('a',9),('b',11)]
    sym x = lookup (init (tail x)) [("s",1),("f",-1),("n",0),("ss",2),("ff",-2)]
-}

-- @tom p@: Alias for @toMIDI@.
-- tom = toMIDI

-- | The `fit` function takes a pattern of integer numbers, which are used to select values from the given list. What makes this a bit strange is that only a given number of values are selected each cycle. For example:
--
-- > d1 $ sound (fit 3 ["bd", "sn", "arpy", "arpy:1", "casio"] "0 [~ 1] 2 1")
--
-- The above fits three samples into the pattern, i.e. for the first cycle this
-- will be @"bd"@, @"sn"@ and @"arpy"@, giving the result @"bd [~ sn] arpy sn"@
-- (note that we start counting at zero, so that 0 picks the first value). The
-- following cycle the /next/ three values in the list will be picked, i.e.
-- @"arpy:1"@, @"casio"@ and @"bd"@, giving the pattern
-- @"arpy:1 [~ casio] bd casio"@ (note that the list wraps round here).
fit :: Pattern Int -> [a] -> Pattern Int -> Pattern a
fit :: forall a. Pattern Int -> [a] -> Pattern Int -> Pattern a
fit Pattern Int
pint [a]
xs Pattern Int
p = ((Int -> ([a], Pattern Int) -> Pattern a)
-> Pattern Int -> ([a], Pattern Int) -> Pattern a
forall t1 t2 a.
(t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a
patternify Int -> ([a], Pattern Int) -> Pattern a
forall {a}. Int -> ([a], Pattern Int) -> Pattern a
func) Pattern Int
pint ([a]
xs, Pattern Int
p)
  where
    func :: Int -> ([a], Pattern Int) -> Pattern a
func Int
i ([a]
xs', Pattern Int
p') = Int -> [a] -> Pattern Int -> Pattern a
forall a. Int -> [a] -> Pattern Int -> Pattern a
_fit Int
i [a]
xs' Pattern Int
p'

_fit :: Int -> [a] -> Pattern Int -> Pattern a
_fit :: forall a. Int -> [a] -> Pattern Int -> Pattern a
_fit Int
perCycle [a]
xs Pattern Int
p = ([a]
xs [a] -> Int -> a
forall a. [a] -> Int -> a
!!!) (Int -> a) -> Pattern Int -> Pattern a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern Int
p {query = map (\EventF Arc Int
e -> (Int -> Int) -> EventF Arc Int -> EventF Arc Int
forall a b. (a -> b) -> EventF Arc a -> EventF Arc b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ EventF Arc Int -> Int
forall {a} {b}. RealFrac a => EventF (ArcF a) b -> Int
pos EventF Arc Int
e) EventF Arc Int
e) . query p})
  where
    pos :: EventF (ArcF a) b -> Int
pos EventF (ArcF a) b
e = Int
perCycle Int -> Int -> Int
forall a. Num a => a -> a -> a
* a -> Int
forall b. Integral b => a -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (ArcF a -> a
forall a. ArcF a -> a
start (ArcF a -> a) -> ArcF a -> a
forall a b. (a -> b) -> a -> b
$ EventF (ArcF a) b -> ArcF a
forall a b. EventF a b -> a
part EventF (ArcF a) b
e)

permstep :: (RealFrac b) => Int -> [a] -> Pattern b -> Pattern a
permstep :: forall b a. RealFrac b => Int -> [a] -> Pattern b -> Pattern a
permstep Int
nSteps [a]
things Pattern b
p = Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
unwrap (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ (\b
n -> [a] -> Pattern a
forall a. [a] -> Pattern a
fastFromList ([a] -> Pattern a) -> [a] -> Pattern a
forall a b. (a -> b) -> a -> b
$ ((Int, a) -> [a]) -> [(Int, a)] -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Int, a)
x -> Int -> a -> [a]
forall a. Int -> a -> [a]
replicate ((Int, a) -> Int
forall a b. (a, b) -> a
fst (Int, a)
x) ((Int, a) -> a
forall a b. (a, b) -> b
snd (Int, a)
x)) ([(Int, a)] -> [a]) -> [(Int, a)] -> [a]
forall a b. (a -> b) -> a -> b
$ [Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([[Int]]
ps [[Int]] -> Int -> [Int]
forall a. HasCallStack => [a] -> Int -> a
!! b -> Int
forall b. Integral b => b -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (b
n b -> b -> b
forall a. Num a => a -> a -> a
* Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([[Int]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
ps Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))) [a]
things) (b -> Pattern a) -> Pattern b -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Time -> Pattern b -> Pattern b
forall a. Time -> Pattern a -> Pattern a
_segment Time
1 Pattern b
p
  where
    ps :: [[Int]]
ps = Int -> Int -> [[Int]]
forall {a}. Integral a => a -> a -> [[a]]
permsort ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
things) Int
nSteps
    deviance :: a -> [a] -> a
deviance a
avg [a]
xs = [a] -> a
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([a] -> a) -> [a] -> a
forall a b. (a -> b) -> a -> b
$ (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a -> a
forall a. Num a => a -> a
abs (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
avg a -> a -> a
forall a. Num a => a -> a -> a
-) (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral) [a]
xs
    permsort :: a -> a -> [[a]]
permsort a
n a
total = (([a], Double) -> [a]) -> [([a], Double)] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map ([a], Double) -> [a]
forall a b. (a, b) -> a
fst ([([a], Double)] -> [[a]]) -> [([a], Double)] -> [[a]]
forall a b. (a -> b) -> a -> b
$ (([a], Double) -> Double) -> [([a], Double)] -> [([a], Double)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn ([a], Double) -> Double
forall a b. (a, b) -> b
snd ([([a], Double)] -> [([a], Double)])
-> [([a], Double)] -> [([a], Double)]
forall a b. (a -> b) -> a -> b
$ ([a] -> ([a], Double)) -> [[a]] -> [([a], Double)]
forall a b. (a -> b) -> [a] -> [b]
map (\[a]
x -> ([a]
x, Double -> [a] -> Double
forall {a} {a}. (Integral a, Num a) => a -> [a] -> a
deviance (a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
total Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n :: Double)) [a]
x)) ([[a]] -> [([a], Double)]) -> [[a]] -> [([a], Double)]
forall a b. (a -> b) -> a -> b
$ a -> a -> [[a]]
forall {t}. (Eq t, Num t, Enum t) => t -> t -> [[t]]
perms a
n a
total
    perms :: t -> t -> [[t]]
perms t
0 t
_ = []
    perms t
1 t
n = [[t
n]]
    perms t
n t
total = (t -> [[t]]) -> [t] -> [[t]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\t
x -> ([t] -> [t]) -> [[t]] -> [[t]]
forall a b. (a -> b) -> [a] -> [b]
map (t
x t -> [t] -> [t]
forall a. a -> [a] -> [a]
:) ([[t]] -> [[t]]) -> [[t]] -> [[t]]
forall a b. (a -> b) -> a -> b
$ t -> t -> [[t]]
perms (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1) (t
total t -> t -> t
forall a. Num a => a -> a -> a
- t
x)) [t
1 .. (t
total t -> t -> t
forall a. Num a => a -> a -> a
- (t
n t -> t -> t
forall a. Num a => a -> a -> a
- t
1))]

-- |
--  @struct a b@ structures pattern @b@ in terms of the pattern of boolean
--  values @a@. Only @True@ values in the boolean pattern are used.
--
--  The following are equivalent:
--
--  > d1 $ struct ("t ~ t*2 ~") $ sound "cp"
--  > d1 $ sound "cp ~ cp*2 ~"
--
--  The structure comes from a boolean pattern, i.e. a binary pattern containing
--  true or false values. Above we only used true values, denoted by @t@. It’s also
--  possible to include false values with @f@, which @struct@ will simply treat as
--  silence. For example, this would have the same outcome as the above:
--
--  > d1 $ struct ("t f t*2 f") $ sound "cp"
--
--  These true / false binary patterns become useful when you conditionally
--  manipulate them, for example, ‘inverting’ the values using 'every' and 'inv':
--
--  > d1 $ struct (every 3 inv "t f t*2 f") $ sound "cp"
--
--  In the above, the boolean values will be ‘inverted’ every third cycle, so that
--  the structure comes from the @f@s rather than @t@. Note that euclidean patterns
--  also create true/false values, for example:
--
--  > d1 $ struct (every 3 inv "t(3,8)") $ sound "cp"
--
--  In the above, the euclidean pattern creates @"t f t f t f f t"@ which gets
--  inverted to @"f t f t f t t f"@ every third cycle. Note that if you prefer you
--  can use 1 and 0 instead of @t@ and @f@.
struct :: Pattern Bool -> Pattern a -> Pattern a
struct :: forall a. Pattern Bool -> Pattern a -> Pattern a
struct Pattern Bool
ps Pattern a
pv = Pattern (Maybe a) -> Pattern a
forall a. Pattern (Maybe a) -> Pattern a
filterJust (Pattern (Maybe a) -> Pattern a) -> Pattern (Maybe a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ (\Bool
a a
b -> if Bool
a then a -> Maybe a
forall a. a -> Maybe a
Just a
b else Maybe a
forall a. Maybe a
Nothing) (Bool -> a -> Maybe a) -> Pattern Bool -> Pattern (a -> Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Bool
ps Pattern (a -> Maybe a) -> Pattern a -> Pattern (Maybe a)
forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
<* Pattern a
pv

-- | @substruct a b@: similar to @struct@, but each event in pattern @a@ gets replaced with pattern @b@, compressed to fit the timespan of the event.
substruct :: Pattern Bool -> Pattern b -> Pattern b
substruct :: forall a. Pattern Bool -> Pattern a -> Pattern a
substruct Pattern Bool
s Pattern b
p = Pattern b
p {query = f}
  where
    f :: State -> [Event b]
f State
st =
      (Event Bool -> [Event b]) -> [Event Bool] -> [Event b]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((\Arc
a' -> Pattern b -> Arc -> [Event b]
forall a. Pattern a -> Arc -> [Event a]
queryArc (Arc -> Pattern b -> Pattern b
forall a. Arc -> Pattern a -> Pattern a
compressArcTo Arc
a' Pattern b
p) Arc
a') (Arc -> [Event b])
-> (Event Bool -> Arc) -> Event Bool -> [Event b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event Bool -> Arc
forall a. Event a -> Arc
wholeOrPart) ([Event Bool] -> [Event b]) -> [Event Bool] -> [Event b]
forall a b. (a -> b) -> a -> b
$ (Event Bool -> Bool) -> [Event Bool] -> [Event Bool]
forall a. (a -> Bool) -> [a] -> [a]
filter Event Bool -> Bool
forall a b. EventF a b -> b
value ([Event Bool] -> [Event Bool]) -> [Event Bool] -> [Event Bool]
forall a b. (a -> b) -> a -> b
$ Pattern Bool -> State -> [Event Bool]
forall a. Pattern a -> State -> [Event a]
query Pattern Bool
s State
st

randArcs :: Int -> Pattern [Arc]
randArcs :: Int -> Pattern [Arc]
randArcs Int
n =
  do
    [Int]
rs <- (Int -> Pattern Int) -> [Int] -> Pattern [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\Int
x -> Time -> Pattern Time
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Time
forall a. Real a => a -> Time
toRational Int
x Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Int -> Time
forall a. Real a => a -> Time
toRational Int
n) Pattern Time -> Pattern Int -> Pattern Int
forall a. Pattern Time -> Pattern a -> Pattern a
<~ [Int] -> Pattern Int
forall a. [a] -> Pattern a
choose [Int
1 :: Int, Int
2, Int
3]) [Int
0 .. (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)]
    let rats :: [Time]
rats = (Int -> Time) -> [Int] -> [Time]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Time
forall a. Real a => a -> Time
toRational [Int]
rs
        total :: Time
total = [Time] -> Time
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Time]
rats
        pairs :: [Arc]
pairs = [Time] -> [Arc]
forall {a}. Num a => [a] -> [ArcF a]
pairUp ([Time] -> [Arc]) -> [Time] -> [Arc]
forall a b. (a -> b) -> a -> b
$ [Time] -> [Time]
forall t. Num t => [t] -> [t]
accumulate ([Time] -> [Time]) -> [Time] -> [Time]
forall a b. (a -> b) -> a -> b
$ (Time -> Time) -> [Time] -> [Time]
forall a b. (a -> b) -> [a] -> [b]
map (Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Time
total) [Time]
rats
    [Arc] -> Pattern [Arc]
forall a. a -> Pattern a
forall (m :: * -> *) a. Monad m => a -> m a
return [Arc]
pairs
  where
    pairUp :: [a] -> [ArcF a]
pairUp [] = []
    pairUp [a]
xs = a -> a -> ArcF a
forall a. a -> a -> ArcF a
Arc a
0 ([a] -> a
forall a. HasCallStack => [a] -> a
head [a]
xs) ArcF a -> [ArcF a] -> [ArcF a]
forall a. a -> [a] -> [a]
: [a] -> [ArcF a]
forall {a}. Num a => [a] -> [ArcF a]
pairUp' [a]
xs
    pairUp' :: [a] -> [ArcF a]
pairUp' [] = []
    pairUp' [a
_] = []
    pairUp' [a
a, a
_] = [a -> a -> ArcF a
forall a. a -> a -> ArcF a
Arc a
a a
1]
    pairUp' (a
a : a
b : [a]
xs) = a -> a -> ArcF a
forall a. a -> a -> ArcF a
Arc a
a a
b ArcF a -> [ArcF a] -> [ArcF a]
forall a. a -> [a] -> [a]
: [a] -> [ArcF a]
pairUp' (a
b a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs)

-- TODO - what does this do? Something for @stripe@ ..
randStruct :: Int -> Pattern Int
randStruct :: Int -> Pattern Int
randStruct Int
n = Pattern Int -> Pattern Int
forall a. Pattern a -> Pattern a
splitQueries (Pattern Int -> Pattern Int) -> Pattern Int -> Pattern Int
forall a b. (a -> b) -> a -> b
$ (State -> [EventF Arc Int])
-> Maybe (Pattern Time) -> Maybe Int -> Pattern Int
forall a.
(State -> [Event a])
-> Maybe (Pattern Time) -> Maybe a -> Pattern a
Pattern State -> [EventF Arc Int]
f Maybe (Pattern Time)
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing
  where
    f :: State -> [EventF Arc Int]
f State
st = ((Arc, Maybe Arc, Int) -> EventF Arc Int)
-> [(Arc, Maybe Arc, Int)] -> [EventF Arc Int]
forall a b. (a -> b) -> [a] -> [b]
map (\(Arc
a, Maybe Arc
b, Int
c) -> Context -> Maybe Arc -> Arc -> Int -> EventF Arc Int
forall a b. Context -> Maybe a -> a -> b -> EventF a b
Event ([((Int, Int), (Int, Int))] -> Context
Context []) (Arc -> Maybe Arc
forall a. a -> Maybe a
Just Arc
a) (Maybe Arc -> Arc
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Arc
b) Int
c) ([(Arc, Maybe Arc, Int)] -> [EventF Arc Int])
-> [(Arc, Maybe Arc, Int)] -> [EventF Arc Int]
forall a b. (a -> b) -> a -> b
$ ((Arc, Maybe Arc, Int) -> Bool)
-> [(Arc, Maybe Arc, Int)] -> [(Arc, Maybe Arc, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Arc
_, Maybe Arc
x, Int
_) -> Maybe Arc -> Bool
forall a. Maybe a -> Bool
isJust Maybe Arc
x) [(Arc, Maybe Arc, Int)]
as
      where
        as :: [(Arc, Maybe Arc, Int)]
as =
          ((Int, Arc) -> (Arc, Maybe Arc, Int))
-> [(Int, Arc)] -> [(Arc, Maybe Arc, Int)]
forall a b. (a -> b) -> [a] -> [b]
map
            ( \(Int
i, Arc Time
s' Time
e') ->
                ( Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc (Time
s' Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time -> Time
sam Time
s) (Time
e' Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time -> Time
sam Time
s),
                  Arc -> Arc -> Maybe Arc
subArc (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc Time
s Time
e) (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc (Time
s' Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time -> Time
sam Time
s) (Time
e' Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time -> Time
sam Time
s)),
                  Int
i
                )
            )
            ([(Int, Arc)] -> [(Arc, Maybe Arc, Int)])
-> [(Int, Arc)] -> [(Arc, Maybe Arc, Int)]
forall a b. (a -> b) -> a -> b
$ [Arc] -> [(Int, Arc)]
forall a. [a] -> [(Int, a)]
enumerate
            ([Arc] -> [(Int, Arc)]) -> [Arc] -> [(Int, Arc)]
forall a b. (a -> b) -> a -> b
$ EventF Arc [Arc] -> [Arc]
forall a b. EventF a b -> b
value
            (EventF Arc [Arc] -> [Arc]) -> EventF Arc [Arc] -> [Arc]
forall a b. (a -> b) -> a -> b
$ [EventF Arc [Arc]] -> EventF Arc [Arc]
forall a. HasCallStack => [a] -> a
head
            ([EventF Arc [Arc]] -> EventF Arc [Arc])
-> [EventF Arc [Arc]] -> EventF Arc [Arc]
forall a b. (a -> b) -> a -> b
$ Pattern [Arc] -> Arc -> [EventF Arc [Arc]]
forall a. Pattern a -> Arc -> [Event a]
queryArc (Int -> Pattern [Arc]
randArcs Int
n) (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc (Time -> Time
sam Time
s) (Time -> Time
nextSam Time
s))
        (Arc Time
s Time
e) = State -> Arc
arc State
st

-- TODO - what does this do?
substruct' :: Pattern Int -> Pattern a -> Pattern a
substruct' :: forall c. Pattern Int -> Pattern c -> Pattern c
substruct' Pattern Int
s Pattern a
p = Pattern a
p {query = \State
st -> (EventF Arc Int -> [Event a]) -> [EventF Arc Int] -> [Event a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (State -> EventF Arc Int -> [Event a]
forall {a}. Real a => State -> EventF Arc a -> [Event a]
f State
st) (Pattern Int -> State -> [EventF Arc Int]
forall a. Pattern a -> State -> [Event a]
query Pattern Int
s State
st)}
  where
    f :: State -> EventF Arc a -> [Event a]
f State
st (Event Context
c (Just Arc
a') Arc
_ a
i) = (Event a -> Event a) -> [Event a] -> [Event a]
forall a b. (a -> b) -> [a] -> [b]
map (\Event a
e -> Event a
e {context = combineContexts [c, context e]}) ([Event a] -> [Event a]) -> [Event a] -> [Event a]
forall a b. (a -> b) -> a -> b
$ Pattern a -> Arc -> [Event a]
forall a. Pattern a -> Arc -> [Event a]
queryArc (Arc -> Pattern a -> Pattern a
forall a. Arc -> Pattern a -> Pattern a
compressArcTo Arc
a' (Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a1 a.
Pattern Time
-> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a
inside (Time -> Pattern Time
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Time -> Pattern Time) -> Time -> Pattern Time
forall a b. (a -> b) -> a -> b
$ Time
1 Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Int -> Time
forall a. Real a => a -> Time
toRational ([EventF Arc Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Pattern Int -> Arc -> [EventF Arc Int]
forall a. Pattern a -> Arc -> [Event a]
queryArc Pattern Int
s (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc (Time -> Time
sam (Arc -> Time
forall a. ArcF a -> a
start (Arc -> Time) -> Arc -> Time
forall a b. (a -> b) -> a -> b
$ State -> Arc
arc State
st)) (Time -> Time
nextSam (Arc -> Time
forall a. ArcF a -> a
start (Arc -> Time) -> Arc -> Time
forall a b. (a -> b) -> a -> b
$ State -> Arc
arc State
st)))))) (Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
rotR (a -> Time
forall a. Real a => a -> Time
toRational a
i)) Pattern a
p)) Arc
a'
    -- Ignore analog events (ones without wholes)
    f State
_ EventF Arc a
_ = []

-- | @stripe n p@: repeats pattern @p@ @n@ times per cycle, i.e., the first
-- parameter gives the number of cycles to operate over. So, it is similar to
-- @fast@, but with random durations. For example @stripe 2@ will repeat a pattern
-- twice, over two cycles
--
-- In the following example, the start of every third repetition of the @d1@
-- pattern will match with the clap on the @d2@ pattern.
--
-- > d1 $ stripe 3 $ sound "bd sd ~ [mt ht]"
-- > d2 $ sound "cp"
--
-- The repetitions will be contiguous (touching, but not overlapping) and the
-- durations will add up to a single cycle. @n@ can be supplied as a pattern of
-- integers.
stripe :: Pattern Int -> Pattern a -> Pattern a
stripe :: forall c. Pattern Int -> Pattern c -> Pattern c
stripe = (Int -> Pattern a -> Pattern a)
-> Pattern Int -> Pattern a -> Pattern a
forall t1 t2 a.
(t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a
patternify Int -> Pattern a -> Pattern a
forall a. Int -> Pattern a -> Pattern a
_stripe

_stripe :: Int -> Pattern a -> Pattern a
_stripe :: forall a. Int -> Pattern a -> Pattern a
_stripe = Pattern Int -> Pattern a -> Pattern a
forall c. Pattern Int -> Pattern c -> Pattern c
substruct' (Pattern Int -> Pattern a -> Pattern a)
-> (Int -> Pattern Int) -> Int -> Pattern a -> Pattern a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Pattern Int
randStruct

-- | @slowstripe n p@ is the same as @stripe@, but the result is also
-- @n@ times slower, so that the mean average duration of the stripes
-- is exactly one cycle, and every @n@th stripe starts on a cycle
-- boundary (in Indian classical terms, the /sam/).
slowstripe :: Pattern Int -> Pattern a -> Pattern a
slowstripe :: forall c. Pattern Int -> Pattern c -> Pattern c
slowstripe Pattern Int
n = Pattern Time -> Pattern a -> Pattern a
forall a. Pattern Time -> Pattern a -> Pattern a
slow (Int -> Time
forall a. Real a => a -> Time
toRational (Int -> Time) -> Pattern Int -> Pattern Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Int
n) (Pattern a -> Pattern a)
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern Int -> Pattern a -> Pattern a
forall c. Pattern Int -> Pattern c -> Pattern c
stripe Pattern Int
n

-- Lindenmayer patterns, these go well with the step sequencer
-- general rule parser (strings map to strings)
parseLMRule :: String -> [(String, String)]
parseLMRule :: [Char] -> [([Char], [Char])]
parseLMRule [Char]
s = ([Char] -> ([Char], [Char])) -> [[Char]] -> [([Char], [Char])]
forall a b. (a -> b) -> [a] -> [b]
map (Char -> [Char] -> ([Char], [Char])
forall {a}. Eq a => a -> [a] -> ([a], [a])
splitOn Char
':') [[Char]]
commaSplit
  where
    splitOn :: a -> [a] -> ([a], [a])
splitOn a
sep [a]
str =
      Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt (Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ a -> [a] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex a
sep [a]
str) ([a] -> ([a], [a])) -> [a] -> ([a], [a])
forall a b. (a -> b) -> a -> b
$
        (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
sep) [a]
str
    commaSplit :: [[Char]]
commaSplit = (Text -> [Char]) -> [Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Text -> [Char]
T.unpack ([Text] -> [[Char]]) -> [Text] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn ([Char] -> Text
T.pack [Char]
",") (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
s

-- specific parser for step sequencer (chars map to string)
-- ruleset in form "a:b,b:ab"
parseLMRule' :: String -> [(Char, String)]
parseLMRule' :: [Char] -> [(Char, [Char])]
parseLMRule' [Char]
str = (([Char], [Char]) -> (Char, [Char]))
-> [([Char], [Char])] -> [(Char, [Char])]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], [Char]) -> (Char, [Char])
forall {a} {b}. ([a], b) -> (a, b)
fixer ([([Char], [Char])] -> [(Char, [Char])])
-> [([Char], [Char])] -> [(Char, [Char])]
forall a b. (a -> b) -> a -> b
$ [Char] -> [([Char], [Char])]
parseLMRule [Char]
str
  where
    fixer :: ([a], b) -> (a, b)
fixer ([a]
c, b
r) = ([a] -> a
forall a. HasCallStack => [a] -> a
head [a]
c, b
r)

-- | Returns the @n@th iteration of a
--  [Lindenmayer System](https://en.wikipedia.org/wiki/L-system)
--  with given start sequence.
--
--  It takes an integer @b@, a Lindenmayer system rule set, and an initiating
--  string as input in order to generate an L-system tree string of @b@ iterations.
--  It can be used in conjunction with a step function to convert the generated
--  string into a playable pattern. For example,
--
--  > d1 $ slow 16
--  >    $ sound
--  >    $ step' ["feel:0", "sn:1", "bd:0"]
--  >        ( take 512
--  >        $ lindenmayer 5 "0:1~~~,1:0~~~2~~~~~0~~~2~,2:2~1~,~:~~1~" "0"
--  >        )
--
--  generates an L-system with initiating string @"0"@ and maps it onto a list
--  of samples.
--
--  Complex L-system trees with many rules and iterations can sometimes result in unwieldy strings. Using @take n@ to only use the first @n@ elements of the string, along with a 'slow' function, can make the generated values more manageable.
lindenmayer :: Int -> String -> String -> String
lindenmayer :: Int -> [Char] -> [Char] -> [Char]
lindenmayer Int
_ [Char]
_ [] = []
lindenmayer Int
1 [Char]
r (Char
c : [Char]
cs) =
  [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char
c] (Char -> [(Char, [Char])] -> Maybe [Char]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Char
c ([(Char, [Char])] -> Maybe [Char])
-> [(Char, [Char])] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [(Char, [Char])]
parseLMRule' [Char]
r)
    [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char] -> [Char] -> [Char]
lindenmayer Int
1 [Char]
r [Char]
cs
lindenmayer Int
n [Char]
r [Char]
s = ([Char] -> [Char]) -> [Char] -> [[Char]]
forall a. (a -> a) -> a -> [a]
iterate (Int -> [Char] -> [Char] -> [Char]
lindenmayer Int
1 [Char]
r) [Char]
s [[Char]] -> Int -> [Char]
forall a. HasCallStack => [a] -> Int -> a
!! Int
n

-- | @lindenmayerI@ converts the resulting string into a a list of integers
-- with @fromIntegral@ applied (so they can be used seamlessly where floats or
-- rationals are required)
lindenmayerI :: (Num b) => Int -> String -> String -> [b]
lindenmayerI :: forall b. Num b => Int -> [Char] -> [Char] -> [b]
lindenmayerI Int
n [Char]
r [Char]
s = (Char -> b) -> [Char] -> [b]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> b) -> (Char -> Int) -> Char -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
digitToInt) ([Char] -> [b]) -> [Char] -> [b]
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> [Char] -> [Char]
lindenmayer Int
n [Char]
r [Char]
s

-- | @runMarkov n tmat xi seed@ generates a Markov chain (as a list) of length @n@
-- using the transition matrix @tmat@ starting from initial state @xi@, starting
-- with random numbers generated from @seed@
-- Each entry in the chain is the index of state (starting from zero).
-- Each row of the matrix will be automatically normalized. For example:
-- @
-- runMarkov 8 [[2,3], [1,3]] 0 0
-- @
-- will produce a two-state chain 8 steps long, from initial state @0@, where the
-- transition probability from state 0->0 is 2/5, 0->1 is 3/5, 1->0 is 1/4, and
-- 1->1 is 3/4.
runMarkov :: Int -> [[Double]] -> Int -> Time -> [Int]
runMarkov :: Int -> [[Double]] -> Int -> Time -> [Int]
runMarkov Int
n [[Double]]
tp Int
xi Time
seed = [Int] -> [Int]
forall a. [a] -> [a]
reverse ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ (([Int] -> [Int]) -> [Int] -> [[Int]]
forall a. (a -> a) -> a -> [a]
iterate ([[Double]] -> [Int] -> [Int]
forall {a}. (Ord a, Fractional a) => [[a]] -> [Int] -> [Int]
markovStep ([[Double]] -> [Int] -> [Int]) -> [[Double]] -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ [[Double]]
renorm) [Int
xi]) [[Int]] -> Int -> [Int]
forall a. HasCallStack => [a] -> Int -> a
!! (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
  where
    markovStep :: [[a]] -> [Int] -> [Int]
markovStep [[a]]
tp' [Int]
xs = (Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> [a] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (a
r a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<=) ([a] -> Maybe Int) -> [a] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ (a -> a -> a) -> [a] -> [a]
forall a. (a -> a -> a) -> [a] -> [a]
scanl1 a -> a -> a
forall a. Num a => a -> a -> a
(+) ([[a]]
tp' [[a]] -> Int -> [a]
forall a. HasCallStack => [a] -> Int -> a
!! ([Int] -> Int
forall a. HasCallStack => [a] -> a
head [Int]
xs))) Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
xs
      where
        r :: a
r = Time -> a
forall a b. (RealFrac a, Fractional b) => a -> b
timeToRand (Time -> a) -> Time -> a
forall a b. (a -> b) -> a -> b
$ Time
seed Time -> Time -> Time
forall a. Num a => a -> a -> a
+ (Int -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Time) -> ([Int] -> Int) -> [Int] -> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) [Int]
xs Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Int -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
    renorm :: [[Double]]
renorm = [(Double -> Double) -> [Double] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Double]
x) [Double]
x | [Double]
x <- [[Double]]
tp]

-- | @markovPat n xi tp@ generates a one-cycle pattern of @n@ steps in a Markov
-- chain starting from state @xi@ with transition matrix @tp@. Each row of the
-- transition matrix is automatically normalized.  For example:
--
-- >>> markovPat 8 1 [[3,5,2], [4,4,2], [0,1,0]]
-- (0>⅛)|1
-- (⅛>¼)|2
-- (¼>⅜)|1
-- (⅜>½)|1
-- (½>⅝)|2
-- (⅝>¾)|1
-- (¾>⅞)|1
-- (⅞>1)|0
markovPat :: Pattern Int -> Pattern Int -> [[Double]] -> Pattern Int
markovPat :: Pattern Int -> Pattern Int -> [[Double]] -> Pattern Int
markovPat = (Int -> Int -> [[Double]] -> Pattern Int)
-> Pattern Int -> Pattern Int -> [[Double]] -> Pattern Int
forall a b c d.
(a -> b -> c -> Pattern d)
-> Pattern a -> Pattern b -> c -> Pattern d
patternify2 Int -> Int -> [[Double]] -> Pattern Int
_markovPat

_markovPat :: Int -> Int -> [[Double]] -> Pattern Int
_markovPat :: Int -> Int -> [[Double]] -> Pattern Int
_markovPat Int
n Int
xi [[Double]]
tp =
  Maybe (Pattern Time) -> Pattern Int -> Pattern Int
forall a. Maybe (Pattern Time) -> Pattern a -> Pattern a
setTactus (Pattern Time -> Maybe (Pattern Time)
forall a. a -> Maybe a
Just (Pattern Time -> Maybe (Pattern Time))
-> Pattern Time -> Maybe (Pattern Time)
forall a b. (a -> b) -> a -> b
$ Time -> Pattern Time
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Time -> Pattern Time) -> Time -> Pattern Time
forall a b. (a -> b) -> a -> b
$ Int -> Time
forall a. Real a => a -> Time
toRational Int
n) (Pattern Int -> Pattern Int) -> Pattern Int -> Pattern Int
forall a b. (a -> b) -> a -> b
$
    Pattern Int -> Pattern Int
forall a. Pattern a -> Pattern a
splitQueries (Pattern Int -> Pattern Int) -> Pattern Int -> Pattern Int
forall a b. (a -> b) -> a -> b
$
      (State -> [EventF Arc Int]) -> Pattern Int
forall a. (State -> [Event a]) -> Pattern a
pattern
        ( \(State a :: Arc
a@(Arc Time
s Time
_) ValueMap
_) ->
            Pattern Int -> Arc -> [EventF Arc Int]
forall a. Pattern a -> Arc -> [Event a]
queryArc ([Int] -> Pattern Int
forall a. [a] -> Pattern a
listToPat ([Int] -> Pattern Int) -> [Int] -> Pattern Int
forall a b. (a -> b) -> a -> b
$ Int -> [[Double]] -> Int -> Time -> [Int]
runMarkov Int
n [[Double]]
tp Int
xi (Time -> Time
sam Time
s)) Arc
a
        )

-- |
-- @beat@ structures a pattern by picking subdivisions of a cycle.
-- Takes in a pattern that tells it which parts to play (polyphony is recommeded here),
-- and the number of parts by which to subdivide the cycle (also pattern-able).
-- For example:
-- > d1 $ beat "[3,4.2,9,11,14]" 16 $ s "sd"
beat :: Pattern Time -> Pattern Time -> Pattern a -> Pattern a
beat :: forall a. Pattern Time -> Pattern Time -> Pattern a -> Pattern a
beat = (Time -> Time -> Pattern a -> Pattern a)
-> Pattern Time -> Pattern Time -> Pattern a -> Pattern a
forall a b c d.
(a -> b -> c -> Pattern d)
-> Pattern a -> Pattern b -> c -> Pattern d
patternify2 ((Time -> Time -> Pattern a -> Pattern a)
 -> Pattern Time -> Pattern Time -> Pattern a -> Pattern a)
-> (Time -> Time -> Pattern a -> Pattern a)
-> Pattern Time
-> Pattern Time
-> Pattern a
-> Pattern a
forall a b. (a -> b) -> a -> b
$ (Pattern (Pattern a) -> Pattern a)
-> Time -> Time -> Pattern a -> Pattern a
forall a.
(Pattern (Pattern a) -> Pattern a)
-> Time -> Time -> Pattern a -> Pattern a
__beat Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
innerJoin

-- TODO it would probably be better to pass a bind here instead..
__beat :: (Pattern (Pattern a) -> Pattern a) -> Time -> Time -> Pattern a -> Pattern a
__beat :: forall a.
(Pattern (Pattern a) -> Pattern a)
-> Time -> Time -> Pattern a -> Pattern a
__beat Pattern (Pattern a) -> Pattern a
usejoin Time
t Time
d Pattern a
p = Pattern (Pattern a) -> Pattern a
usejoin (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ (Time, Time) -> Pattern a -> Pattern a
forall a. (Time, Time) -> Pattern a -> Pattern a
compress (Time
s, Time
e) (Pattern a -> Pattern a) -> (a -> Pattern a) -> a -> Pattern a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Pattern a
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Pattern a) -> Pattern a -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a
p
  where
    s :: Time
s = Time
t' Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Time
d
    e :: Time
e = Time -> Time -> Time
forall a. Ord a => a -> a -> a
min Time
1 (Time -> Time) -> Time -> Time
forall a b. (a -> b) -> a -> b
$ (Time
t' Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
1) Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Time
d
    t' :: Time
t' = Time
t Time -> Time -> Time
forall a. Real a => a -> a -> a
`mod'` Time
d

-- |
-- @mask@ takes a boolean pattern and ‘masks’ another pattern with it. That is,
-- events are only carried over if they match within a ‘true’ event in the binary
-- pattern, i.e., it removes events from the second pattern that don't start during
-- an event from the first.
--
-- For example, consider this kind of messy rhythm without any rests.
--
-- > d1 $ sound (slowcat ["sn*8", "[cp*4 bd*4, hc*5]"]) # n (run 8)
--
-- If we apply a mask to it
--
-- @
-- d1 $ s ( mask ("1 1 1 ~ 1 1 ~ 1" :: Pattern Bool)
--          ( slowcat ["sn*8", "[cp*4 bd*4, bass*5]"] )
--        )
--   # n (run 8)
-- @
--
-- Due to the use of `slowcat` here, the same mask is first applied to @"sn*8"@ and
-- in the next cycle to @"[cp*4 bd*4, hc*5]"@.
--
-- You could achieve the same effect by adding rests within the `slowcat` patterns,
-- but mask allows you to do this more easily. It kind of keeps the rhythmic
-- structure and you can change the used samples independently, e.g.,
--
-- @
-- d1 $ s ( mask ("1 ~ 1 ~ 1 1 ~ 1")
--          ( slowcat ["can*8", "[cp*4 sn*4, jvbass*16]"] )
--        )
--   # n (run 8)
-- @
mask :: Pattern Bool -> Pattern a -> Pattern a
mask :: forall a. Pattern Bool -> Pattern a -> Pattern a
mask Pattern Bool
b Pattern a
p = a -> Bool -> a
forall a b. a -> b -> a
const (a -> Bool -> a) -> Pattern a -> Pattern (Bool -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a
p Pattern (Bool -> a) -> Pattern Bool -> Pattern a
forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
<* (Bool -> Bool) -> Pattern Bool -> Pattern Bool
forall a. (a -> Bool) -> Pattern a -> Pattern a
filterValues Bool -> Bool
forall a. a -> a
id Pattern Bool
b

-- TODO: refactor towards union
enclosingArc :: [Arc] -> Arc
enclosingArc :: [Arc] -> Arc
enclosingArc [] = Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc Time
0 Time
1
enclosingArc [Arc]
as = Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc ([Time] -> Time
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ((Arc -> Time) -> [Arc] -> [Time]
forall a b. (a -> b) -> [a] -> [b]
map Arc -> Time
forall a. ArcF a -> a
start [Arc]
as)) ([Time] -> Time
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((Arc -> Time) -> [Arc] -> [Time]
forall a b. (a -> b) -> [a] -> [b]
map Arc -> Time
forall a. ArcF a -> a
stop [Arc]
as))

-- |
--  @stretch@ takes a pattern, and if there’s silences at the start or end of the
--  current cycle, it will zoom in to avoid them. The following are equivalent:
--
--  > d1 $ note (stretch "~ 0 1 5 8*4 ~") # s "superpiano"
--  > d1 $ note "0 1 5 8*4" # s "superpiano"
--
--  You can pattern silences on the extremes of a cycle to make changes to the rhythm:
--
--  > d1 $ note (stretch "~ <0 ~> 1 5 8*4 ~") # s "superpiano"
stretch :: Pattern a -> Pattern a
-- TODO - should that be whole or part?
stretch :: forall a. Pattern a -> Pattern a
stretch Pattern a
p = Pattern a -> Pattern a
forall a. Pattern a -> Pattern a
splitQueries (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ Pattern a
p {query = q, pureValue = Nothing}
  where
    q :: State -> [Event a]
q State
st = Pattern a -> State -> [Event a]
forall a. Pattern a -> State -> [Event a]
query (Arc -> Pattern a -> Pattern a
forall a. Arc -> Pattern a -> Pattern a
zoomArc (Arc -> Arc
cycleArc (Arc -> Arc) -> Arc -> Arc
forall a b. (a -> b) -> a -> b
$ [Arc] -> Arc
enclosingArc ([Arc] -> Arc) -> [Arc] -> Arc
forall a b. (a -> b) -> a -> b
$ (Event a -> Arc) -> [Event a] -> [Arc]
forall a b. (a -> b) -> [a] -> [b]
map Event a -> Arc
forall a. Event a -> Arc
wholeOrPart ([Event a] -> [Arc]) -> [Event a] -> [Arc]
forall a b. (a -> b) -> a -> b
$ Pattern a -> State -> [Event a]
forall a. Pattern a -> State -> [Event a]
query Pattern a
p (State
st {arc = Arc (sam s) (nextSam s)})) Pattern a
p) State
st
      where
        s :: Time
s = Arc -> Time
forall a. ArcF a -> a
start (Arc -> Time) -> Arc -> Time
forall a b. (a -> b) -> a -> b
$ State -> Arc
arc State
st

-- | @fit'@ is a generalization of `fit`, where the list is instead constructed
-- by using another integer pattern to slice up a given pattern. The first argument
-- is the number of cycles of that latter pattern to use when slicing. It's easier
-- to understand this with a few examples:
--
-- > d1 $ sound (fit' 1 2 "0 1" "1 0" "bd sn")
--
-- So what does this do? The first @1@ just tells it to slice up a single cycle of
-- @"bd sn"@. The @2@ tells it to select two values each cycle, just like the first
-- argument to @fit@. The next pattern @"0 1"@ is the "from" pattern which tells
-- it how to slice, which in this case means @"0"@ maps to @"bd"@, and @"1"@ maps
-- to @"sn"@. The next pattern @"1 0"@ is the "to" pattern, which tells it how to
-- rearrange those slices. So the final result is the pattern @"sn bd"@.
--
-- A more useful example might be something like
--
-- > d1 $ fit' 1 4 (run 4) "[0 3*2 2 1 0 3*2 2 [1*8 ~]]/2"
-- >    $ chop 4
-- >    $ (sound "breaks152" # unit "c")
--
-- which uses @chop@ to break a single sample into individual pieces, which @fit'@ then puts into a list (using the @run 4@ pattern) and reassembles according to the complicated integer pattern.
fit' :: Pattern Time -> Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a
fit' :: forall a.
Pattern Time
-> Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a
fit' Pattern Time
cyc Int
n Pattern Int
from Pattern Int
to Pattern a
p = Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
squeezeJoin (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ Int -> [Pattern a] -> Pattern Int -> Pattern (Pattern a)
forall a. Int -> [a] -> Pattern Int -> Pattern a
_fit Int
n [Pattern a]
mapMasks Pattern Int
to
  where
    mapMasks :: [Pattern a]
mapMasks =
      [ Pattern a -> Pattern a
forall a. Pattern a -> Pattern a
stretch (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ Pattern Bool -> Pattern a -> Pattern a
forall a. Pattern Bool -> Pattern a -> Pattern a
mask (Bool -> Int -> Bool
forall a b. a -> b -> a
const Bool
True (Int -> Bool) -> Pattern Int -> Pattern Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Bool) -> Pattern Int -> Pattern Int
forall a. (a -> Bool) -> Pattern a -> Pattern a
filterValues (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i) Pattern Int
from') Pattern a
p'
      | Int
i <- [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
      ]
    p' :: Pattern a
p' = Pattern Time -> Pattern a -> Pattern a
forall a. Pattern Time -> Pattern a -> Pattern a
density Pattern Time
cyc Pattern a
p
    from' :: Pattern Int
from' = Pattern Time -> Pattern Int -> Pattern Int
forall a. Pattern Time -> Pattern a -> Pattern a
density Pattern Time
cyc Pattern Int
from

-- |
--  Treats the given pattern @p@ as having @n@ chunks, and applies the function @f@ to one of those sections per cycle.
--  Running:
--   - from left to right if chunk number is positive
--   - from right to left if chunk number is negative
--
--  > d1 $ chunk 4 (fast 4) $ sound "cp sn arpy [mt lt]"
--
--  The following:
--
--  > d1 $ chunk 4 (# speed 2) $ sound "bd hh sn cp"
--
--  applies @(# speed 2)@ to the uppercased part of the cycle below:
--
--  > BD hh sn cp
--  > bd HH sn cp
--  > bd hh SN cp
--  > bd hh sn CP
chunk :: Pattern Int -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b
chunk :: forall b.
Pattern Int -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b
chunk Pattern Int
npat Pattern b -> Pattern b
f Pattern b
p = Pattern (Pattern b) -> Pattern b
forall a. Pattern (Pattern a) -> Pattern a
innerJoin (Pattern (Pattern b) -> Pattern b)
-> Pattern (Pattern b) -> Pattern b
forall a b. (a -> b) -> a -> b
$ (\Int
n -> Int -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b
forall a b.
Integral a =>
a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b
_chunk Int
n Pattern b -> Pattern b
f Pattern b
p) (Int -> Pattern b) -> Pattern Int -> Pattern (Pattern b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Int
npat

_chunk :: (Integral a) => a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b
_chunk :: forall a b.
Integral a =>
a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b
_chunk a
n Pattern b -> Pattern b
f Pattern b
p
  | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0 = [Pattern b] -> Pattern b
forall a. [Pattern a] -> Pattern a
cat [Arc -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b
forall a. Arc -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
withinArc (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc (Integer
i Integer -> Integer -> Time
forall a. Integral a => a -> a -> Ratio a
% a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n) ((Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) Integer -> Integer -> Time
forall a. Integral a => a -> a -> Ratio a
% a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n)) Pattern b -> Pattern b
f Pattern b
p | Integer
i <- [Integer
0 .. a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1]]
  | Bool
otherwise = do
      Integer
i <- Time -> Pattern Integer -> Pattern Integer
forall a. Time -> Pattern a -> Pattern a
_slow (a -> Time
forall a. Real a => a -> Time
toRational (-a
n)) (Pattern Integer -> Pattern Integer)
-> Pattern Integer -> Pattern Integer
forall a b. (a -> b) -> a -> b
$ Pattern Integer -> Pattern Integer
forall a. Pattern a -> Pattern a
rev (Pattern Integer -> Pattern Integer)
-> Pattern Integer -> Pattern Integer
forall a b. (a -> b) -> a -> b
$ Pattern Integer -> Pattern Integer
forall a. (Enum a, Num a) => Pattern a -> Pattern a
run (a -> Pattern Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (-a
n))
      Arc -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b
forall a. Arc -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
withinArc (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc (Integer
i Integer -> Integer -> Time
forall a. Integral a => a -> a -> Ratio a
% a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (-a
n)) ((Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) Integer -> Integer -> Time
forall a. Integral a => a -> a -> Ratio a
% a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (-a
n))) Pattern b -> Pattern b
f Pattern b
p

-- | DEPRECATED, use 'chunk' with negative numbers instead
chunk' :: (Integral a1) => Pattern a1 -> (Pattern a2 -> Pattern a2) -> Pattern a2 -> Pattern a2
chunk' :: forall a1 a2.
Integral a1 =>
Pattern a1
-> (Pattern a2 -> Pattern a2) -> Pattern a2 -> Pattern a2
chunk' Pattern a1
npat Pattern a2 -> Pattern a2
f Pattern a2
p = Pattern (Pattern a2) -> Pattern a2
forall a. Pattern (Pattern a) -> Pattern a
innerJoin (Pattern (Pattern a2) -> Pattern a2)
-> Pattern (Pattern a2) -> Pattern a2
forall a b. (a -> b) -> a -> b
$ (\a1
n -> a1 -> (Pattern a2 -> Pattern a2) -> Pattern a2 -> Pattern a2
forall a b.
Integral a =>
a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b
_chunk' a1
n Pattern a2 -> Pattern a2
f Pattern a2
p) (a1 -> Pattern a2) -> Pattern a1 -> Pattern (Pattern a2)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a1
npat

-- | DEPRECATED, use '_chunk' with negative numbers instead
_chunk' :: (Integral a) => a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b
_chunk' :: forall a b.
Integral a =>
a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b
_chunk' a
n Pattern b -> Pattern b
f Pattern b
p = a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b
forall a b.
Integral a =>
a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b
_chunk (-a
n) Pattern b -> Pattern b
f Pattern b
p

-- |
-- @inside@ carries out an operation /inside/ a cycle.
-- For example, while @rev "0 1 2 3 4 5 6 7"@ is the same as @"7 6 5 4 3 2 1 0"@,
-- @inside 2 rev "0 1 2 3 4 5 6 7"@ gives @"3 2 1 0 7 6 5 4"@.
--
-- What this function is really doing is ‘slowing down’ the pattern by a given
-- factor, applying the given function to it, and then ‘speeding it up’ by the same
-- factor. In other words, this:
--
-- > inside 2 rev "0 1 2 3 4 5 6 7"
--
-- Is doing this:
--
-- > fast 2 $ rev $ slow 2 "0 1 2 3 4 5 6 7"
--
-- so rather than whole cycles, each half of a cycle is reversed.
inside :: Pattern Time -> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a
inside :: forall a1 a.
Pattern Time
-> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a
inside Pattern Time
np Pattern a1 -> Pattern a
f Pattern a1
p = Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
innerJoin (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ (\Time
n -> Time -> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a
forall a1 a.
Time -> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a
_inside Time
n Pattern a1 -> Pattern a
f Pattern a1
p) (Time -> Pattern a) -> Pattern Time -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Time
np

_inside :: Time -> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a
_inside :: forall a1 a.
Time -> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a
_inside Time
n Pattern a1 -> Pattern a
f Pattern a1
p = Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
_fast Time
n (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ Pattern a1 -> Pattern a
f (Time -> Pattern a1 -> Pattern a1
forall a. Time -> Pattern a -> Pattern a
_slow Time
n Pattern a1
p)

-- |
-- @outside@ is the inverse of the 'inside' function. @outside@ applies its function /outside/ the cycle.
-- Say you have a pattern that takes 4 cycles to repeat and apply the rev function:
--
-- > d1 $ rev $ cat [s "bd bd sn",s "sn sn bd", s"lt lt sd", s "sd sd bd"]
--
-- The above generates:
--
-- > d1 $ rev $ cat [s "sn bd bd",s "bd sn sn", s "sd lt lt", s "bd sd sd"]
--
-- However if you apply @outside@:
--
-- > d1 $ outside 4 (rev) $ cat [s "bd bd sn",s "sn sn bd", s"lt lt sd", s "sd sd bd"]
--
-- The result is:
--
-- > d1 $ rev $ cat [s "bd sd sd", s "sd lt lt", s "sn sn bd", s "bd bd sn"]
--
-- Notice that the whole idea has been reversed. What this function is really doing
-- is ‘speeding up’ the pattern by a given factor, applying the given function to
-- it, and then ‘slowing it down’ by the same factor. In other words, this:
--
-- > d1 $ slow 4 $ rev $ fast 4
-- >    $ cat [s "bd bd sn",s "sn sn bd", s"lt lt sd", s "sd sd bd"]
--
-- This compresses the idea into a single cycle before rev operates and then slows it back to the original speed.
outside :: Pattern Time -> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a
outside :: forall a1 a.
Pattern Time
-> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a
outside Pattern Time
np Pattern a1 -> Pattern a
f Pattern a1
p = Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
innerJoin (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ (\Time
n -> Time -> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a
forall a1 a.
Time -> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a
_outside Time
n Pattern a1 -> Pattern a
f Pattern a1
p) (Time -> Pattern a) -> Pattern Time -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Time
np

_outside :: Time -> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a
_outside :: forall a1 a.
Time -> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a
_outside Time
n = Time -> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a
forall a1 a.
Time -> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a
_inside (Time
1 Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Time
n)

-- |
--  Takes a pattern and loops only the first cycle of the pattern. For example, the following code will only play the bass drum sample:
--
--  > d1 $ loopFirst $ s "<<bd*4 ht*8> cp*4>"
--
--  This function combines with 'sometimes' to insert events from the first cycle randomly into subsequent cycles of the pattern:
--
--  > d1 $ sometimes loopFirst $ s "<<bd*4 ht*8> cp*4>"
loopFirst :: Pattern a -> Pattern a
loopFirst :: forall a. Pattern a -> Pattern a
loopFirst Pattern a
p = Pattern a -> Pattern a
forall a. Pattern a -> Pattern a
splitQueries (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ Pattern a
p {query = f}
  where
    f :: State -> [EventF Arc a]
f State
st =
      (EventF Arc a -> EventF Arc a) -> [EventF Arc a] -> [EventF Arc a]
forall a b. (a -> b) -> [a] -> [b]
map
        ( \(Event Context
c Maybe Arc
w Arc
p' a
v) ->
            Context -> Maybe Arc -> Arc -> a -> EventF Arc a
forall a b. Context -> Maybe a -> a -> b -> EventF a b
Event Context
c (Arc -> Arc
plus (Arc -> Arc) -> Maybe Arc -> Maybe Arc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Arc
w) (Arc -> Arc
plus Arc
p') a
v
        )
        ([EventF Arc a] -> [EventF Arc a])
-> [EventF Arc a] -> [EventF Arc a]
forall a b. (a -> b) -> a -> b
$ Pattern a -> State -> [EventF Arc a]
forall a. Pattern a -> State -> [Event a]
query Pattern a
p (State
st {arc = minus $ arc st})
      where
        minus :: Arc -> Arc
minus = (Time -> Time) -> Arc -> Arc
forall a b. (a -> b) -> ArcF a -> ArcF b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Time -> Time -> Time
forall a. Num a => a -> a -> a
subtract (Time -> Time
sam Time
s))
        plus :: Arc -> Arc
plus = (Time -> Time) -> Arc -> Arc
forall a b. (a -> b) -> ArcF a -> ArcF b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time -> Time
sam Time
s)
        s :: Time
s = Arc -> Time
forall a. ArcF a -> a
start (Arc -> Time) -> Arc -> Time
forall a b. (a -> b) -> a -> b
$ State -> Arc
arc State
st

timeLoop :: Pattern Time -> Pattern a -> Pattern a
timeLoop :: forall a. Pattern Time -> Pattern a -> Pattern a
timeLoop Pattern Time
n = Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a1 a.
Pattern Time
-> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a
outside Pattern Time
n Pattern a -> Pattern a
forall a. Pattern a -> Pattern a
loopFirst

-- |
--  @seqPLoop@ will keep looping the sequence when it gets to the end:
--
--  > d1 $ qtrigger $ seqPLoop
--  >   [ (0, 12, sound "bd bd*2")
--  >   , (4, 12, sound "hh*2 [sn cp] cp future*4")
--  >   , (8, 12, sound (samples "arpy*8" (run 16)))
--  >   ]
seqPLoop :: [(Time, Time, Pattern a)] -> Pattern a
seqPLoop :: forall a. [(Time, Time, Pattern a)] -> Pattern a
seqPLoop [(Time, Time, Pattern a)]
ps = Pattern Time -> Pattern a -> Pattern a
forall a. Pattern Time -> Pattern a -> Pattern a
timeLoop (Time -> Pattern Time
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Time -> Pattern Time) -> Time -> Pattern Time
forall a b. (a -> b) -> a -> b
$ Time
maxT Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
minT) (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ Time
minT Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
`rotL` [(Time, Time, Pattern a)] -> Pattern a
forall a. [(Time, Time, Pattern a)] -> Pattern a
seqP [(Time, Time, Pattern a)]
ps
  where
    minT :: Time
minT = [Time] -> Time
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Time] -> Time) -> [Time] -> Time
forall a b. (a -> b) -> a -> b
$ ((Time, Time, Pattern a) -> Time)
-> [(Time, Time, Pattern a)] -> [Time]
forall a b. (a -> b) -> [a] -> [b]
map (\(Time
x, Time
_, Pattern a
_) -> Time
x) [(Time, Time, Pattern a)]
ps
    maxT :: Time
maxT = [Time] -> Time
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Time] -> Time) -> [Time] -> Time
forall a b. (a -> b) -> a -> b
$ ((Time, Time, Pattern a) -> Time)
-> [(Time, Time, Pattern a)] -> [Time]
forall a b. (a -> b) -> [a] -> [b]
map (\(Time
_, Time
x, Pattern a
_) -> Time
x) [(Time, Time, Pattern a)]
ps

-- |
-- @toScale@ lets you turn a pattern of notes within a scale (expressed as a
-- list) to note numbers.
--
-- For example:
--
-- > toScale [0, 4, 7] "0 1 2 3"
--
-- will turn into the pattern @"0 4 7 12"@.
--
-- @toScale@ is handy for quickly applying a scale without naming it:
--
-- > d1 $ n (toScale [0,2,3,5,7,8,10] "0 1 2 3 4 5 6 7") # sound "superpiano"
--
-- This function assumes your scale fits within an octave; if that's not true,
-- use 'toScale''.
--
-- @toScale = toScale' 12@
toScale :: (Num a) => [a] -> Pattern Int -> Pattern a
toScale :: forall a. Num a => [a] -> Pattern Int -> Pattern a
toScale = Int -> [a] -> Pattern Int -> Pattern a
forall a. Num a => Int -> [a] -> Pattern Int -> Pattern a
toScale' Int
12

-- | As 'toScale', though allowing scales of arbitrary size.
--
-- An example: @toScale' 24 [0,4,7,10,14,17] (run 8)@ turns into @"0 4 7 10 14 17 24 28"@.
toScale' :: (Num a) => Int -> [a] -> Pattern Int -> Pattern a
toScale' :: forall a. Num a => Int -> [a] -> Pattern Int -> Pattern a
toScale' Int
_ [] = Pattern a -> Pattern Int -> Pattern a
forall a b. a -> b -> a
const Pattern a
forall a. Pattern a
silence
toScale' Int
o [a]
s = (Int -> a) -> Pattern Int -> Pattern a
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> a
noteInScale
  where
    octave :: Int -> Int
octave Int
x = Int
x Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
s
    noteInScale :: Int -> a
noteInScale Int
x = ([a]
s [a] -> Int -> a
forall a. [a] -> Int -> a
!!! Int
x) a -> a -> a
forall a. Num a => a -> a -> a
+ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int -> Int
octave Int
x)

-- | @swingBy x n@ divides a cycle into @n@ slices and delays the notes in the
--  second half of each slice by @x@ fraction of a slice. So if @x@ is 0 it does
--  nothing, 0.5 delays for half the note duration, and 1 will wrap around to
--  doing nothing again. The end result is a shuffle or swing-like rhythm. For
--  example, the following will delay every other @"hh"@ 1/3 of the way to the
--  next @"hh"@:
--
--  > d1 $ swingBy (1/3) 4 $ sound "hh*8"
swingBy :: Pattern Time -> Pattern Time -> Pattern a -> Pattern a
swingBy :: forall a. Pattern Time -> Pattern Time -> Pattern a -> Pattern a
swingBy Pattern Time
x Pattern Time
n = Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a1 a.
Pattern Time
-> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a
inside Pattern Time
n (Arc -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a. Arc -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
withinArc (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc Time
0.5 Time
1) (Pattern Time
x Pattern Time -> Pattern a -> Pattern a
forall a. Pattern Time -> Pattern a -> Pattern a
~>))

-- |
-- As 'swingBy', with the cycle division set to ⅓.
swing :: Pattern Time -> Pattern a -> Pattern a
swing :: forall a. Pattern Time -> Pattern a -> Pattern a
swing = Pattern Time -> Pattern Time -> Pattern a -> Pattern a
forall a. Pattern Time -> Pattern Time -> Pattern a -> Pattern a
swingBy (Time -> Pattern Time
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Time -> Pattern Time) -> Time -> Pattern Time
forall a b. (a -> b) -> a -> b
$ Integer
1 Integer -> Integer -> Time
forall a. Integral a => a -> a -> Ratio a
% Integer
3)

-- | @cycleChoose@ is like `choose` but only picks a new item from the list
--  once each cycle.
--
--  > d1 $ sound "drum ~ drum drum" # n (cycleChoose [0,2,3])
cycleChoose :: [a] -> Pattern a
cycleChoose :: forall a. [a] -> Pattern a
cycleChoose = Pattern Time -> Pattern a -> Pattern a
forall a. Pattern Time -> Pattern a -> Pattern a
segment Pattern Time
1 (Pattern a -> Pattern a) -> ([a] -> Pattern a) -> [a] -> Pattern a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Pattern a
forall a. [a] -> Pattern a
choose

-- | Internal function used by shuffle and scramble
_rearrangeWith :: Pattern Int -> Int -> Pattern a -> Pattern a
_rearrangeWith :: forall a. Pattern Int -> Int -> Pattern a -> Pattern a
_rearrangeWith Pattern Int
ipat Int
n Pattern a
pat = Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
innerJoin (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ (\Int
i -> Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
_fast Time
nT (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ Int -> Pattern a -> Pattern a
forall a. Int -> Pattern a -> Pattern a
_repeatCycles Int
n (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ [Pattern a]
pats [Pattern a] -> Int -> Pattern a
forall a. HasCallStack => [a] -> Int -> a
!! Int
i) (Int -> Pattern a) -> Pattern Int -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Int
ipat
  where
    pats :: [Pattern a]
pats = (Int -> Pattern a) -> [Int] -> [Pattern a]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> (Time, Time) -> Pattern a -> Pattern a
forall a. (Time, Time) -> Pattern a -> Pattern a
zoom (Int -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Time
nT, Int -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Time
nT) Pattern a
pat) [Int
0 .. (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)]
    nT :: Time
    nT :: Time
nT = Int -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n

-- | @shuffle n p@ evenly divides one cycle of the pattern @p@ into @n@ parts,
-- and returns a random permutation of the parts each cycle.  For example,
-- @shuffle 3 "a b c"@ could return @"a b c"@, @"a c b"@, @"b a c"@, @"b c a"@,
-- @"c a b"@, or @"c b a"@.  But it will /never/ return @"a a a"@, because that
-- is not a permutation of the parts.
--
-- This could also be called “sampling without replacement”.
shuffle :: Pattern Int -> Pattern a -> Pattern a
shuffle :: forall c. Pattern Int -> Pattern c -> Pattern c
shuffle = (Int -> Pattern a -> Pattern a)
-> Pattern Int -> Pattern a -> Pattern a
forall b c a.
(b -> Pattern c -> Pattern a)
-> Pattern b -> Pattern c -> Pattern a
patternify' Int -> Pattern a -> Pattern a
forall a. Int -> Pattern a -> Pattern a
_shuffle

_shuffle :: Int -> Pattern a -> Pattern a
_shuffle :: forall a. Int -> Pattern a -> Pattern a
_shuffle Int
n = Pattern Int -> Int -> Pattern a -> Pattern a
forall a. Pattern Int -> Int -> Pattern a -> Pattern a
_rearrangeWith (Int -> Pattern Int
randrun Int
n) Int
n

-- | @scramble n p@ is like 'shuffle' but randomly selects from the parts
-- of @p@ instead of making permutations.
-- For example, @scramble 3 "a b c"@ will randomly select 3 parts from
-- @"a"@ @"b"@ and @"c"@, possibly repeating a single part.
--
-- This could also be called “sampling with replacement”.
scramble :: Pattern Int -> Pattern a -> Pattern a
scramble :: forall c. Pattern Int -> Pattern c -> Pattern c
scramble = (Int -> Pattern a -> Pattern a)
-> Pattern Int -> Pattern a -> Pattern a
forall b c a.
(b -> Pattern c -> Pattern a)
-> Pattern b -> Pattern c -> Pattern a
patternify' Int -> Pattern a -> Pattern a
forall a. Int -> Pattern a -> Pattern a
_scramble

_scramble :: Int -> Pattern a -> Pattern a
_scramble :: forall a. Int -> Pattern a -> Pattern a
_scramble Int
n = Pattern Int -> Int -> Pattern a -> Pattern a
forall a. Pattern Int -> Int -> Pattern a -> Pattern a
_rearrangeWith (Time -> Pattern Int -> Pattern Int
forall a. Time -> Pattern a -> Pattern a
_segment (Int -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) (Pattern Int -> Pattern Int) -> Pattern Int -> Pattern Int
forall a b. (a -> b) -> a -> b
$ Int -> Pattern Int
forall a. Num a => Int -> Pattern a
_irand Int
n) Int
n

-- |
-- @randrun n@ generates a pattern of random integers less than @n@.
--
-- The following plays random notes in an octave:
--
-- @
-- d1 $ s "superhammond!12" # n (fromIntegral <$> randrun 13)
-- @
randrun :: Int -> Pattern Int
randrun :: Int -> Pattern Int
randrun Int
0 = Pattern Int
forall a. Pattern a
silence
randrun Int
n' =
  Pattern Int -> Pattern Int
forall a. Pattern a -> Pattern a
splitQueries (Pattern Int -> Pattern Int) -> Pattern Int -> Pattern Int
forall a b. (a -> b) -> a -> b
$ (State -> [EventF Arc Int]) -> Pattern Int
forall a. (State -> [Event a]) -> Pattern a
pattern (\(State a :: Arc
a@(Arc Time
s Time
_) ValueMap
_) -> Arc -> Time -> [EventF Arc Int]
forall {p}. RealFrac p => Arc -> p -> [EventF Arc Int]
events Arc
a (Time -> [EventF Arc Int]) -> Time -> [EventF Arc Int]
forall a b. (a -> b) -> a -> b
$ Time -> Time
sam Time
s)
  where
    events :: Arc -> p -> [EventF Arc Int]
events Arc
a p
seed = ((Arc, Int) -> Maybe (EventF Arc Int))
-> [(Arc, Int)] -> [EventF Arc Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Arc, Int) -> Maybe (EventF Arc Int)
forall {b}. (Arc, b) -> Maybe (EventF Arc b)
toEv ([(Arc, Int)] -> [EventF Arc Int])
-> [(Arc, Int)] -> [EventF Arc Int]
forall a b. (a -> b) -> a -> b
$ [Arc] -> [Int] -> [(Arc, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Arc]
arcs [Int]
shuffled
      where
        shuffled :: [Int]
shuffled = ((Double, Int) -> Int) -> [(Double, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Double, Int) -> Int
forall a b. (a, b) -> b
snd ([(Double, Int)] -> [Int]) -> [(Double, Int)] -> [Int]
forall a b. (a -> b) -> a -> b
$ ((Double, Int) -> Double) -> [(Double, Int)] -> [(Double, Int)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Double, Int) -> Double
forall a b. (a, b) -> a
fst ([(Double, Int)] -> [(Double, Int)])
-> [(Double, Int)] -> [(Double, Int)]
forall a b. (a -> b) -> a -> b
$ [Double] -> [Int] -> [(Double, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Double]
rs [Int
0 .. (Int
n' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)]
        rs :: [Double]
rs = p -> Int -> [Double]
forall a b. (RealFrac a, Fractional b) => a -> Int -> [b]
timeToRands p
seed Int
n' :: [Double]
        arcs :: [Arc]
arcs = (Time -> Time -> Arc) -> [Time] -> [Time] -> [Arc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc [Time]
fractions (Int -> [Time] -> [Time]
forall a. Int -> [a] -> [a]
drop Int
1 [Time]
fractions)
        fractions :: [Time]
fractions = (Time -> Time) -> [Time] -> [Time]
forall a b. (a -> b) -> [a] -> [b]
map (Time -> Time -> Time
forall a. Num a => a -> a -> a
+ (Time -> Time
sam (Time -> Time) -> Time -> Time
forall a b. (a -> b) -> a -> b
$ Arc -> Time
forall a. ArcF a -> a
start Arc
a)) [Time
0, Time
1 Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Int -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n' .. Time
1]
        toEv :: (Arc, b) -> Maybe (EventF Arc b)
toEv (Arc
a', b
v) = do
          Arc
a'' <- Arc -> Arc -> Maybe Arc
subArc Arc
a Arc
a'
          EventF Arc b -> Maybe (EventF Arc b)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (EventF Arc b -> Maybe (EventF Arc b))
-> EventF Arc b -> Maybe (EventF Arc b)
forall a b. (a -> b) -> a -> b
$ Context -> Maybe Arc -> Arc -> b -> EventF Arc b
forall a b. Context -> Maybe a -> a -> b -> EventF a b
Event ([((Int, Int), (Int, Int))] -> Context
Context []) (Arc -> Maybe Arc
forall a. a -> Maybe a
Just Arc
a') Arc
a'' b
v

-- ** Composing patterns

-- | The function @seqP@ allows you to define when
-- a sound within a list starts and ends. The code below contains three
-- separate patterns in a `stack`, but each has different start times
-- (zero cycles, eight cycles, and sixteen cycles, respectively). All
-- patterns stop after 128 cycles:
--
-- @
-- d1 $ seqP [
--  (0, 128, sound "bd bd*2"),
--  (8, 128, sound "hh*2 [sn cp] cp future*4"),
--  (16, 128, sound (samples "arpy*8" (run 16)))
-- ]
-- @
seqP :: [(Time, Time, Pattern a)] -> Pattern a
seqP :: forall a. [(Time, Time, Pattern a)] -> Pattern a
seqP [(Time, Time, Pattern a)]
ps = [Pattern a] -> Pattern a
forall a. [Pattern a] -> Pattern a
stack ([Pattern a] -> Pattern a) -> [Pattern a] -> Pattern a
forall a b. (a -> b) -> a -> b
$ ((Time, Time, Pattern a) -> Pattern a)
-> [(Time, Time, Pattern a)] -> [Pattern a]
forall a b. (a -> b) -> [a] -> [b]
map (\(Time
s, Time
e, Pattern a
p) -> Time -> Time -> Pattern a -> Pattern a
forall a. Time -> Time -> Pattern a -> Pattern a
playFor Time
s Time
e (Time -> Time
sam Time
s Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
`rotR` Pattern a
p)) [(Time, Time, Pattern a)]
ps

-- |
-- The @ur@ function is designed for longer form composition, by allowing you to
-- create ‘patterns of patterns’ in a repeating loop. It takes four parameters:
-- how long the loop will take, a pattern giving the structure of the composition,
-- a lookup table for named patterns to feed into that structure, and a second
-- lookup table for named transformations\/effects.
--
-- The /ur-/ prefix [comes from German](https://en.wiktionary.org/wiki/ur-#German) and
-- means /proto-/ or /original/. For a mnemonic device, think of this function as
-- assembling a set of original patterns (ur-patterns) into a larger, newer whole.
--
-- Lets say you had three patterns (called @a@, @b@ and @c@), and that you wanted
-- to play them four cycles each, over twelve cycles in total. Here is one way to
-- do it:
--
-- @
-- let pats =
--   [ ( "a", stack [ n "c4 c5 g4 f4 f5 g4 e5 g4" # s "superpiano" # gain "0.7"
--                  , n "[c3,g4,c4]" # s "superpiano"# gain "0.7"
--                  ]
--     )
--   , ( "b", stack [ n "d4 c5 g4 f4 f5 g4 e5 g4" # s "superpiano" # gain "0.7"
--                  , n "[d3,a4,d4]" # s "superpiano"# gain "0.7"
--                  ]
--     )
--   , ( "c", stack [ n "f4 c5 g4 f4 f5 g4 e5 g4" # s "superpiano" # gain "0.7"
--                  , n "[f4,c5,f4]" # s "superpiano"# gain "0.7"
--                  ]
--     )
--   ]
-- in
-- d1 $ ur 12 "a b c" pats []
-- @
--
-- In the above, the fourth parameter is given as an empty list, but that is where
-- you can put another lookup table, of functions rather than patterns this time.
-- For example:
--
-- @
-- let
--   pats = ...
--   fx   = [ ("reverb", ( # (room 0.8 # sz 0.99 # orbit 1)))
--          , ("faster", fast 2)
--          ]
-- in
-- d1 $ ur 12 "a b:reverb c:faster" pats fx
-- @
--
-- In this example, @b@ has the function applied that’s named as reverb, while @c@
-- is made to go faster. It’s also possible to schedule multiple patterns at once,
-- like in the following:
--
-- @
-- let pats = [ ("drums", s "drum cp*2")
--            , ("melody", s "arpy:2 arpy:3 arpy:5")
--            , ("craziness", s "cp:4*8" # speed ( sine + 0.5 ))
--            ]
--     fx = [("higher", ( # speed 2))]
-- in
-- d1 $ ur 8 "[drums, melody] [drums,craziness,melody] melody:higher" pats fx
-- @
ur :: Time -> Pattern String -> [(String, Pattern a)] -> [(String, Pattern a -> Pattern a)] -> Pattern a
ur :: forall a.
Time
-> Pattern [Char]
-> [([Char], Pattern a)]
-> [([Char], Pattern a -> Pattern a)]
-> Pattern a
ur Time
t Pattern [Char]
outer_p [([Char], Pattern a)]
ps [([Char], Pattern a -> Pattern a)]
fs = Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
_slow Time
t (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
unwrap (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ (Arc, (Pattern a, Arc -> Pattern a -> Pattern a)) -> Pattern a
forall {t} {t} {t}. (t, (t, t -> t -> t)) -> t
adjust ((Arc, (Pattern a, Arc -> Pattern a -> Pattern a)) -> Pattern a)
-> Pattern (Arc, (Pattern a, Arc -> Pattern a -> Pattern a))
-> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern (Pattern a, Arc -> Pattern a -> Pattern a)
-> Pattern (Arc, (Pattern a, Arc -> Pattern a -> Pattern a))
forall {b}. Pattern b -> Pattern (Arc, b)
timedValues ([[Char]] -> (Pattern a, Arc -> Pattern a -> Pattern a)
getPat ([[Char]] -> (Pattern a, Arc -> Pattern a -> Pattern a))
-> ([Char] -> [[Char]])
-> [Char]
-> (Pattern a, Arc -> Pattern a -> Pattern a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
split ([Char] -> (Pattern a, Arc -> Pattern a -> Pattern a))
-> Pattern [Char]
-> Pattern (Pattern a, Arc -> Pattern a -> Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern [Char]
outer_p)
  where
    split :: [Char] -> [[Char]]
split = (Char -> Bool) -> [Char] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [[a]]
wordsBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':')
    getPat :: [[Char]] -> (Pattern a, Arc -> Pattern a -> Pattern a)
getPat ([Char]
s : [[Char]]
xs) = ([Char] -> Pattern a
match [Char]
s, [[Char]] -> Arc -> Pattern a -> Pattern a
transform [[Char]]
xs)
    -- TODO - check this really can't happen..
    getPat [[Char]]
_ = [Char] -> (Pattern a, Arc -> Pattern a -> Pattern a)
forall a. HasCallStack => [Char] -> a
error [Char]
"can't happen?"
    match :: [Char] -> Pattern a
match [Char]
s = Pattern a -> Maybe (Pattern a) -> Pattern a
forall a. a -> Maybe a -> a
fromMaybe Pattern a
forall a. Pattern a
silence (Maybe (Pattern a) -> Pattern a) -> Maybe (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ [Char] -> [([Char], Pattern a)] -> Maybe (Pattern a)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
s [([Char], Pattern a)]
ps'
    ps' :: [([Char], Pattern a)]
ps' = (([Char], Pattern a) -> ([Char], Pattern a))
-> [([Char], Pattern a)] -> [([Char], Pattern a)]
forall a b. (a -> b) -> [a] -> [b]
map ((Pattern a -> Pattern a)
-> ([Char], Pattern a) -> ([Char], Pattern a)
forall a b. (a -> b) -> ([Char], a) -> ([Char], b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
_fast Time
t)) [([Char], Pattern a)]
ps
    adjust :: (t, (t, t -> t -> t)) -> t
adjust (t
a, (t
p, t -> t -> t
f)) = t -> t -> t
f t
a t
p
    transform :: [[Char]] -> Arc -> Pattern a -> Pattern a
transform ([Char]
x : [[Char]]
_) Arc
a = [Char] -> Arc -> Pattern a -> Pattern a
transform' [Char]
x Arc
a
    transform [[Char]]
_ Arc
_ = Pattern a -> Pattern a
forall a. a -> a
id
    transform' :: [Char] -> Arc -> Pattern a -> Pattern a
transform' [Char]
str (Arc Time
s Time
e) Pattern a
p = Time
s Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
`rotR` Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a1 a.
Pattern Time
-> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a
inside (Time -> Pattern Time
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Time -> Pattern Time) -> Time -> Pattern Time
forall a b. (a -> b) -> a -> b
$ Time
1 Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ (Time
e Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
s)) ([Char] -> Pattern a -> Pattern a
matchF [Char]
str) Pattern a
p
    matchF :: [Char] -> Pattern a -> Pattern a
matchF [Char]
str = (Pattern a -> Pattern a)
-> Maybe (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a. a -> Maybe a -> a
fromMaybe Pattern a -> Pattern a
forall a. a -> a
id (Maybe (Pattern a -> Pattern a) -> Pattern a -> Pattern a)
-> Maybe (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ [Char]
-> [([Char], Pattern a -> Pattern a)]
-> Maybe (Pattern a -> Pattern a)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
str [([Char], Pattern a -> Pattern a)]
fs
    timedValues :: Pattern b -> Pattern (Arc, b)
timedValues =
      Pattern (Maybe (Arc, b)) -> Pattern (Arc, b)
forall a. Pattern (Maybe a) -> Pattern a
filterJust
        (Pattern (Maybe (Arc, b)) -> Pattern (Arc, b))
-> (Pattern b -> Pattern (Maybe (Arc, b)))
-> Pattern b
-> Pattern (Arc, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event b -> Event (Maybe (Arc, b)))
-> Pattern b -> Pattern (Maybe (Arc, b))
forall a b. (Event a -> Event b) -> Pattern a -> Pattern b
withEvent
          (\(Event Context
c Maybe Arc
ma Arc
a' b
v) -> Context
-> Maybe Arc -> Arc -> Maybe (Arc, b) -> Event (Maybe (Arc, b))
forall a b. Context -> Maybe a -> a -> b -> EventF a b
Event Context
c Maybe Arc
ma Arc
a' (Maybe Arc
ma Maybe Arc -> (Arc -> Maybe (Arc, b)) -> Maybe (Arc, b)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Arc
a -> (Arc, b) -> Maybe (Arc, b)
forall a. a -> Maybe a
Just (Arc
a, b
v)))
        (Pattern b -> Pattern (Maybe (Arc, b)))
-> (Pattern b -> Pattern b)
-> Pattern b
-> Pattern (Maybe (Arc, b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern b -> Pattern b
forall a. Pattern a -> Pattern a
filterDigital

-- | A simpler version of 'ur' that just provides name-value bindings that are
--  reflected in the provided pattern.
--
--  @inhabit@ allows you to link patterns to some @String@, or in other words,
--  to give patterns a name and then call them from within another pattern of
--  @String@s.
--
--  For example, we can make our own bassdrum, hi-hat and snaredrum kit:
--
--  > do
--  >   let drum = inhabit [ ("bd", s "sine" |- accelerate 1.5)
--  >                      , ("hh", s "alphabet:7" # begin 0.7 # hpf 7000)
--  >                      , ("sd", s "invaders:3" # speed 12)
--  >                      ]
--  >   d1 $ drum "[bd*8?, [~hh]*4, sd(6,16)]"
--
--  @inhabit@ can be very useful when using MIDI controlled drum machines, since you
--  can give understandable drum names to patterns of notes.
inhabit :: [(String, Pattern a)] -> Pattern String -> Pattern a
inhabit :: forall a. [([Char], Pattern a)] -> Pattern [Char] -> Pattern a
inhabit [([Char], Pattern a)]
ps Pattern [Char]
p = Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
squeezeJoin (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ (\[Char]
s -> Pattern a -> Maybe (Pattern a) -> Pattern a
forall a. a -> Maybe a -> a
fromMaybe Pattern a
forall a. Pattern a
silence (Maybe (Pattern a) -> Pattern a) -> Maybe (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ [Char] -> [([Char], Pattern a)] -> Maybe (Pattern a)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
s [([Char], Pattern a)]
ps) ([Char] -> Pattern a) -> Pattern [Char] -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern [Char]
p

-- | @spaceOut xs p@ repeats a 'Pattern' @p@ at different durations given by the list of time values in @xs@.
spaceOut :: [Time] -> Pattern a -> Pattern a
spaceOut :: forall a. [Time] -> Pattern a -> Pattern a
spaceOut [Time]
xs Pattern a
p = Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
_slow (Time -> Time
forall a. Real a => a -> Time
toRational (Time -> Time) -> Time -> Time
forall a b. (a -> b) -> a -> b
$ [Time] -> Time
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Time]
xs) (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ [Pattern a] -> Pattern a
forall a. [Pattern a] -> Pattern a
stack ([Pattern a] -> Pattern a) -> [Pattern a] -> Pattern a
forall a b. (a -> b) -> a -> b
$ (Arc -> Pattern a) -> [Arc] -> [Pattern a]
forall a b. (a -> b) -> [a] -> [b]
map (Arc -> Pattern a -> Pattern a
forall a. Arc -> Pattern a -> Pattern a
`compressArc` Pattern a
p) [Arc]
spaceArcs
  where
    markOut :: Time -> [Time] -> [Arc]
    markOut :: Time -> [Time] -> [Arc]
markOut Time
_ [] = []
    markOut Time
offset (Time
x : [Time]
xs') = Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc Time
offset (Time
offset Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
x) Arc -> [Arc] -> [Arc]
forall a. a -> [a] -> [a]
: Time -> [Time] -> [Arc]
markOut (Time
offset Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
x) [Time]
xs'
    spaceArcs :: [Arc]
spaceArcs = (Arc -> Arc) -> [Arc] -> [Arc]
forall a b. (a -> b) -> [a] -> [b]
map (\(Arc Time
a Time
b) -> Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc (Time
a Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Time
s) (Time
b Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Time
s)) ([Arc] -> [Arc]) -> [Arc] -> [Arc]
forall a b. (a -> b) -> a -> b
$ Time -> [Time] -> [Arc]
markOut Time
0 [Time]
xs
    s :: Time
s = [Time] -> Time
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Time]
xs

-- | @flatpat@ takes a 'Pattern' of lists and pulls the list elements as
--  separate 'Event's. For example, the following code uses @flatpat@ in combination with @listToPat@ to create an alternating pattern of chords:
--
--  > d1 $ n (flatpat $ listToPat [[0,4,7],[(-12),(-8),(-5)]])
--  >    # s "superpiano" # sustain 2
--
--  This code is equivalent to:
--
--  > d1 $ n ("[0,4,7] [-12,-8,-5]") # s "superpiano" # sustain 2
flatpat :: Pattern [a] -> Pattern a
flatpat :: forall a. Pattern [a] -> Pattern a
flatpat Pattern [a]
p = Pattern [a]
p {query = concatMap (\(Event Context
c Maybe Arc
b Arc
b' [a]
xs) -> (a -> Event a) -> [a] -> [Event a]
forall a b. (a -> b) -> [a] -> [b]
map (Context -> Maybe Arc -> Arc -> a -> Event a
forall a b. Context -> Maybe a -> a -> b -> EventF a b
Event Context
c Maybe Arc
b Arc
b') [a]
xs) . query p, pureValue = Nothing}

-- | @layer@ takes a list of 'Pattern'-returning functions and a seed element,
-- stacking the result of applying the seed element to each function in the list.
--
-- It allows you to layer up multiple functions on one pattern. For example, the following
-- will play two versions of the pattern at the same time, one reversed and one at twice
-- the speed:
--
-- > d1 $ layer [rev, fast 2] $ sound "arpy [~ arpy:4]"
--
-- The original version of the pattern can be included by using the @id@ function:
--
-- > d1 $ layer [id, rev, fast 2] $ sound "arpy [~ arpy:4]"
layer :: [a -> Pattern b] -> a -> Pattern b
layer :: forall a b. [a -> Pattern b] -> a -> Pattern b
layer [a -> Pattern b]
fs a
p = [Pattern b] -> Pattern b
forall a. [Pattern a] -> Pattern a
stack ([Pattern b] -> Pattern b) -> [Pattern b] -> Pattern b
forall a b. (a -> b) -> a -> b
$ ((a -> Pattern b) -> Pattern b) -> [a -> Pattern b] -> [Pattern b]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> Pattern b) -> a -> Pattern b
forall a b. (a -> b) -> a -> b
$ a
p) [a -> Pattern b]
fs

-- | @arpeggiate@ finds events that share the same timespan, and spreads
-- them out during that timespan, so for example @arpeggiate "[bd,sn]"@
-- gets turned into @"bd sn"@. Useful for creating arpeggios/broken chords.
arpeggiate :: Pattern a -> Pattern a
arpeggiate :: forall a. Pattern a -> Pattern a
arpeggiate = ([EventF Arc a] -> [EventF Arc a]) -> Pattern a -> Pattern a
forall a b.
([EventF Arc a] -> [EventF Arc b]) -> Pattern a -> Pattern b
arpWith [EventF Arc a] -> [EventF Arc a]
forall a. a -> a
id

-- | Shorthand alias for arpeggiate
arpg :: Pattern a -> Pattern a
arpg :: forall a. Pattern a -> Pattern a
arpg = Pattern a -> Pattern a
forall a. Pattern a -> Pattern a
arpeggiate

arpWith :: ([EventF (ArcF Time) a] -> [EventF (ArcF Time) b]) -> Pattern a -> Pattern b
arpWith :: forall a b.
([EventF Arc a] -> [EventF Arc b]) -> Pattern a -> Pattern b
arpWith [EventF Arc a] -> [EventF Arc b]
f Pattern a
p = ([EventF Arc a] -> [EventF Arc b]) -> Pattern a -> Pattern b
forall a b.
([EventF Arc a] -> [EventF Arc b]) -> Pattern a -> Pattern b
withEvents [EventF Arc a] -> [EventF Arc b]
munge Pattern a
p
  where
    munge :: [EventF Arc a] -> [EventF Arc b]
munge [EventF Arc a]
es = ([EventF Arc a] -> [EventF Arc b])
-> [[EventF Arc a]] -> [EventF Arc b]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([EventF Arc b] -> [EventF Arc b]
forall {b}. [EventF Arc b] -> [EventF Arc b]
spreadOut ([EventF Arc b] -> [EventF Arc b])
-> ([EventF Arc a] -> [EventF Arc b])
-> [EventF Arc a]
-> [EventF Arc b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [EventF Arc a] -> [EventF Arc b]
f) ((EventF Arc a -> EventF Arc a -> Bool)
-> [EventF Arc a] -> [[EventF Arc a]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\EventF Arc a
a EventF Arc a
b -> EventF Arc a -> Maybe Arc
forall a b. EventF a b -> Maybe a
whole EventF Arc a
a Maybe Arc -> Maybe Arc -> Bool
forall a. Eq a => a -> a -> Bool
== EventF Arc a -> Maybe Arc
forall a b. EventF a b -> Maybe a
whole EventF Arc a
b) ([EventF Arc a] -> [[EventF Arc a]])
-> [EventF Arc a] -> [[EventF Arc a]]
forall a b. (a -> b) -> a -> b
$ (EventF Arc a -> Maybe Arc) -> [EventF Arc a] -> [EventF Arc a]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn EventF Arc a -> Maybe Arc
forall a b. EventF a b -> Maybe a
whole [EventF Arc a]
es)
    spreadOut :: [EventF Arc b] -> [EventF Arc b]
spreadOut [EventF Arc b]
xs = ((Int, EventF Arc b) -> Maybe (EventF Arc b))
-> [(Int, EventF Arc b)] -> [EventF Arc b]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(Int
n, EventF Arc b
x) -> Int -> Int -> EventF Arc b -> Maybe (EventF Arc b)
forall {p} {p} {b}.
(Integral p, Integral p) =>
p -> p -> EventF Arc b -> Maybe (EventF Arc b)
shiftIt Int
n ([EventF Arc b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EventF Arc b]
xs) EventF Arc b
x) ([(Int, EventF Arc b)] -> [EventF Arc b])
-> [(Int, EventF Arc b)] -> [EventF Arc b]
forall a b. (a -> b) -> a -> b
$ [EventF Arc b] -> [(Int, EventF Arc b)]
forall a. [a] -> [(Int, a)]
enumerate [EventF Arc b]
xs
    shiftIt :: p -> p -> EventF Arc b -> Maybe (EventF Arc b)
shiftIt p
n p
d (Event Context
c (Just (Arc Time
s Time
e)) Arc
a' b
v) =
      do
        Arc
a'' <- Arc -> Arc -> Maybe Arc
subArc (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc Time
newS Time
newE) Arc
a'
        EventF Arc b -> Maybe (EventF Arc b)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> Maybe Arc -> Arc -> b -> EventF Arc b
forall a b. Context -> Maybe a -> a -> b -> EventF a b
Event Context
c (Arc -> Maybe Arc
forall a. a -> Maybe a
Just (Arc -> Maybe Arc) -> Arc -> Maybe Arc
forall a b. (a -> b) -> a -> b
$ Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc Time
newS Time
newE) Arc
a'' b
v)
      where
        newS :: Time
newS = Time
s Time -> Time -> Time
forall a. Num a => a -> a -> a
+ (Time
dur Time -> Time -> Time
forall a. Num a => a -> a -> a
* p -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral p
n)
        newE :: Time
newE = Time
newS Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
dur
        dur :: Time
dur = (Time
e Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
s) Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ p -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral p
d
    -- TODO ignoring analog events.. Should we just leave them as-is?
    shiftIt p
_ p
_ EventF Arc b
_ = Maybe (EventF Arc b)
forall a. Maybe a
Nothing

-- | The @arp@ function takes an additional pattern of arpeggiate modes. For example:
--
-- @
-- d1 $ sound "superpiano" # n (arp "<up down diverge>" "<a'm9'8 e'7sus4'8>")
-- @
--
-- The different arpeggiate modes are:
-- @
-- up down updown downup up&down down&up converge
-- diverge disconverge pinkyup pinkyupdown
-- thumbup thumbupdown
-- @
arp :: Pattern String -> Pattern a -> Pattern a
arp :: forall a. Pattern [Char] -> Pattern a -> Pattern a
arp = ([Char] -> Pattern a -> Pattern a)
-> Pattern [Char] -> Pattern a -> Pattern a
forall t1 t2 a.
(t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a
patternify [Char] -> Pattern a -> Pattern a
forall a. [Char] -> Pattern a -> Pattern a
_arp

_arp :: String -> Pattern a -> Pattern a
_arp :: forall a. [Char] -> Pattern a -> Pattern a
_arp [Char]
name Pattern a
p = ([EventF Arc a] -> [EventF Arc a]) -> Pattern a -> Pattern a
forall a b.
([EventF Arc a] -> [EventF Arc b]) -> Pattern a -> Pattern b
arpWith [EventF Arc a] -> [EventF Arc a]
forall a. [a] -> [a]
f Pattern a
p
  where
    f :: [a] -> [a]
f = ([a] -> [a]) -> Maybe ([a] -> [a]) -> [a] -> [a]
forall a. a -> Maybe a -> a
fromMaybe [a] -> [a]
forall a. a -> a
id (Maybe ([a] -> [a]) -> [a] -> [a])
-> Maybe ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [Char] -> [([Char], [a] -> [a])] -> Maybe ([a] -> [a])
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
name [([Char], [a] -> [a])]
forall a. [([Char], [a] -> [a])]
arps
    arps :: [(String, [a] -> [a])]
    arps :: forall a. [([Char], [a] -> [a])]
arps =
      [ ([Char]
"up", [a] -> [a]
forall a. a -> a
id),
        ([Char]
"down", [a] -> [a]
forall a. [a] -> [a]
reverse),
        ([Char]
"updown", \[a]
x -> [a] -> [a]
forall a. HasCallStack => [a] -> [a]
init [a]
x [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a]
forall a. HasCallStack => [a] -> [a]
init ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
x)),
        ([Char]
"downup", \[a]
x -> [a] -> [a]
forall a. HasCallStack => [a] -> [a]
init ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
x) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a]
forall a. HasCallStack => [a] -> [a]
init [a]
x),
        ([Char]
"up&down", \[a]
x -> [a]
x [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a]
forall a. [a] -> [a]
reverse [a]
x),
        ([Char]
"down&up", \[a]
x -> [a] -> [a]
forall a. [a] -> [a]
reverse [a]
x [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
x),
        ([Char]
"converge", [a] -> [a]
forall a. [a] -> [a]
converge),
        ([Char]
"diverge", [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. [a] -> [a]
converge),
        ([Char]
"disconverge", \[a]
x -> [a] -> [a]
forall a. [a] -> [a]
converge [a]
x [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
1 ([a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
converge [a]
x)),
        ([Char]
"pinkyup", [a] -> [a]
forall a. [a] -> [a]
pinkyup),
        ([Char]
"pinkyupdown", \[a]
x -> [a] -> [a]
forall a. HasCallStack => [a] -> [a]
init ([a] -> [a]
forall a. [a] -> [a]
pinkyup [a]
x) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a]
forall a. HasCallStack => [a] -> [a]
init ([a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
pinkyup [a]
x)),
        ([Char]
"thumbup", [a] -> [a]
forall a. [a] -> [a]
thumbup),
        ([Char]
"thumbupdown", \[a]
x -> [a] -> [a]
forall a. HasCallStack => [a] -> [a]
init ([a] -> [a]
forall a. [a] -> [a]
thumbup [a]
x) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a]
forall a. HasCallStack => [a] -> [a]
init ([a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
thumbup [a]
x))
      ]
    converge :: [a] -> [a]
converge [] = []
    converge (a
x : [a]
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
converge' [a]
xs
    converge' :: [a] -> [a]
converge' [] = []
    converge' [a]
xs = [a] -> a
forall a. HasCallStack => [a] -> a
last [a]
xs a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
converge ([a] -> [a]
forall a. HasCallStack => [a] -> [a]
init [a]
xs)
    pinkyup :: [b] -> [b]
pinkyup [b]
xs = (b -> [b]) -> [b] -> [b]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b
pinky]) ([b] -> [b]) -> [b] -> [b]
forall a b. (a -> b) -> a -> b
$ [b] -> [b]
forall a. HasCallStack => [a] -> [a]
init [b]
xs
      where
        pinky :: b
pinky = [b] -> b
forall a. HasCallStack => [a] -> a
last [b]
xs
    thumbup :: [b] -> [b]
thumbup [b]
xs = (b -> [b]) -> [b] -> [b]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\b
x -> [b
thumb, b
x]) ([b] -> [b]) -> [b] -> [b]
forall a b. (a -> b) -> a -> b
$ Int -> [b] -> [b]
forall a. Int -> [a] -> [a]
drop Int
1 [b]
xs
      where
        thumb :: b
thumb = [b] -> b
forall a. HasCallStack => [a] -> a
head [b]
xs

-- | @rolled@ plays each note of a chord quickly in order, as opposed to
-- simultaneously; to give a chord a harp-like or strum effect.
--
-- Notes are played low to high, and are evenly distributed within (1/4) of the chord event length, as opposed to arp/arpeggiate that spread the notes over the whole event.
--
-- @
-- rolled $ n "c'maj'4" # s "superpiano"
-- @
--
-- @rolled = rolledBy (1/4)@
rolled :: Pattern a -> Pattern a
rolled :: forall a. Pattern a -> Pattern a
rolled = Pattern Time -> Pattern a -> Pattern a
forall a. Pattern Time -> Pattern a -> Pattern a
rolledBy (Pattern Time
1 Pattern Time -> Pattern Time -> Pattern Time
forall a. Fractional a => a -> a -> a
/ Pattern Time
4)

{-
As 'rolled', but allows you to specify the length of the roll, i.e., the
fraction of the event that the notes will be spread over. The value in the
passed pattern is the divisor of the cycle length. A negative value will play
the arpeggio in reverse order.

@
rolledBy "<1 -0.5 0.25 -0.125>" $ note "c'maj9" # s "superpiano"
@
-}
rolledBy :: Pattern (Ratio Integer) -> Pattern a -> Pattern a
rolledBy :: forall a. Pattern Time -> Pattern a -> Pattern a
rolledBy Pattern Time
pt = (Time -> Pattern a -> Pattern a)
-> Pattern Time -> Pattern a -> Pattern a
forall t1 t2 a.
(t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a
patternify Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
rolledWith (Pattern Time -> Pattern Time -> Pattern Time
forall a. Pattern Time -> Pattern a -> Pattern a
segment Pattern Time
1 (Pattern Time -> Pattern Time) -> Pattern Time -> Pattern Time
forall a b. (a -> b) -> a -> b
$ Pattern Time
pt)

rolledWith :: Ratio Integer -> Pattern a -> Pattern a
rolledWith :: forall a. Time -> Pattern a -> Pattern a
rolledWith Time
t = ([Event a] -> [Event a]) -> Pattern a -> Pattern a
forall a b.
([EventF Arc a] -> [EventF Arc b]) -> Pattern a -> Pattern b
withEvents [Event a] -> [Event a]
forall {b}. [EventF Arc b] -> [EventF Arc b]
aux
  where
    aux :: [EventF Arc b] -> [EventF Arc b]
aux [EventF Arc b]
es = ([EventF Arc b] -> [EventF Arc b])
-> [[EventF Arc b]] -> [EventF Arc b]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [EventF Arc b] -> [EventF Arc b]
forall {b}. [EventF Arc b] -> [EventF Arc b]
steppityIn ((EventF Arc b -> EventF Arc b -> Bool)
-> [EventF Arc b] -> [[EventF Arc b]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\EventF Arc b
a EventF Arc b
b -> EventF Arc b -> Maybe Arc
forall a b. EventF a b -> Maybe a
whole EventF Arc b
a Maybe Arc -> Maybe Arc -> Bool
forall a. Eq a => a -> a -> Bool
== EventF Arc b -> Maybe Arc
forall a b. EventF a b -> Maybe a
whole EventF Arc b
b) ([EventF Arc b] -> [[EventF Arc b]])
-> [EventF Arc b] -> [[EventF Arc b]]
forall a b. (a -> b) -> a -> b
$ Time -> [EventF Arc b] -> [EventF Arc b]
forall {a} {a}. (Ord a, Num a) => a -> [a] -> [a]
isRev Time
t [EventF Arc b]
es)
    isRev :: a -> [a] -> [a]
isRev a
b = (\a
x -> if a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0 then [a] -> [a]
forall a. a -> a
id else [a] -> [a]
forall a. [a] -> [a]
reverse) a
b
    steppityIn :: [EventF Arc b] -> [EventF Arc b]
steppityIn [EventF Arc b]
xs = ((Int, EventF Arc b) -> Maybe (EventF Arc b))
-> [(Int, EventF Arc b)] -> [EventF Arc b]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(Int
n, EventF Arc b
ev) -> Int
-> [EventF Arc b] -> EventF Arc b -> Time -> Maybe (EventF Arc b)
forall {p} {t :: * -> *} {a} {a} {b}.
(Integral p, Foldable t, Num a, Eq a) =>
p -> t a -> EventF Arc b -> a -> Maybe (EventF Arc b)
timeguard Int
n [EventF Arc b]
xs EventF Arc b
ev Time
t) ([(Int, EventF Arc b)] -> [EventF Arc b])
-> [(Int, EventF Arc b)] -> [EventF Arc b]
forall a b. (a -> b) -> a -> b
$ [EventF Arc b] -> [(Int, EventF Arc b)]
forall a. [a] -> [(Int, a)]
enumerate [EventF Arc b]
xs
    timeguard :: p -> t a -> EventF Arc b -> a -> Maybe (EventF Arc b)
timeguard p
_ t a
_ EventF Arc b
ev a
0 = EventF Arc b -> Maybe (EventF Arc b)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return EventF Arc b
ev
    timeguard p
n t a
xs EventF Arc b
ev a
_ = p -> Int -> EventF Arc b -> Maybe (EventF Arc b)
forall {p} {p} {b}.
(Integral p, Integral p) =>
p -> p -> EventF Arc b -> Maybe (EventF Arc b)
shiftIt p
n (t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
xs) EventF Arc b
ev
    shiftIt :: p -> p -> EventF Arc b -> Maybe (EventF Arc b)
shiftIt p
n p
d (Event Context
c (Just (Arc Time
s Time
e)) Arc
a' b
v) = do
      Arc
a'' <- Arc -> Arc -> Maybe Arc
subArc (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc Time
newS Time
e) Arc
a'
      EventF Arc b -> Maybe (EventF Arc b)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> Maybe Arc -> Arc -> b -> EventF Arc b
forall a b. Context -> Maybe a -> a -> b -> EventF a b
Event Context
c (Arc -> Maybe Arc
forall a. a -> Maybe a
Just (Arc -> Maybe Arc) -> Arc -> Maybe Arc
forall a b. (a -> b) -> a -> b
$ Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc Time
newS Time
e) Arc
a'' b
v)
      where
        newS :: Time
newS = Time
s Time -> Time -> Time
forall a. Num a => a -> a -> a
+ (Time
dur Time -> Time -> Time
forall a. Num a => a -> a -> a
* p -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral p
n)
        dur :: Time
dur = (Time
e Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
s) Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ ((Time
1 Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Time -> Time
forall a. Num a => a -> a
abs Time
t) Time -> Time -> Time
forall a. Num a => a -> a -> a
* p -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral p
d)
    shiftIt p
_ p
_ EventF Arc b
ev = EventF Arc b -> Maybe (EventF Arc b)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return EventF Arc b
ev

{- TODO !

-- | @fill@ 'fills in' gaps in one pattern with events from another. For example @fill "bd" "cp ~ cp"@ would result in the equivalent of `"~ bd ~"`. This only finds gaps in a resulting pattern, in other words @"[bd ~, sn]"@ doesn't contain any gaps (because @sn@ covers it all), and @"bd ~ ~ sn"@ only contains a single gap that bridges two steps.
fill :: Pattern a -> Pattern a -> Pattern a
fill p' p = struct (splitQueries $ p {query = q, pureValue = Nothing}) p'
  where
    q st = removeTolerance (s,e) $ invert (s-tolerance, e+tolerance) $ query p (st {arc = (s-tolerance, e+tolerance)})
      where (s,e) = arc st
    invert (s,e) es = map arcToEvent $ foldr remove [(s,e)] (map part es)
    remove (s,e) xs = concatMap (remove' (s, e)) xs
    remove' (s,e) (s',e') | s > s' && e < e' = [(s',s),(e,e')] -- inside
                          | s > s' && s < e' = [(s',s)] -- cut off right
                          | e > s' && e < e' = [(e,e')] -- cut off left
                          | s <= s' && e >= e' = [] -- swallow
                          | otherwise = [(s',e')] -- miss
    arcToEvent a = ((a,a),"x")
    removeTolerance (s,e) es = concatMap (expand) $ map (withPart f) es
      where f a = concatMap (remove' (e,e+tolerance)) $ remove' (s-tolerance,s) a
            expand ((a,xs),c) = map (\x -> ((a,x),c)) xs
    tolerance = 0.01
-}

-- | @ply n@ repeats each event @n@ times within its arc.
--
-- For example, the following are equivalent:
--
-- @
-- d1 $ ply 3 $ s "bd ~ sn cp"
-- d1 $ s "[bd bd bd] ~ [sn sn sn] [cp cp cp]"
-- @
--
-- The first parameter may be given as a pattern, so that the following are equivalent:
--
-- @
-- d1 $ ply "2 3" $ s "bd ~ sn cp"
-- d1 $ s "[bd bd] ~ [sn sn sn] [cp cp cp]"
-- @
--
-- Here is an example of it being used conditionally:
--
-- @
-- d1 $ every 3 (ply 4) $ s "bd ~ sn cp"
-- @
ply :: Pattern Rational -> Pattern a -> Pattern a
ply :: forall a. Pattern Time -> Pattern a -> Pattern a
ply = (Time -> Pattern a -> Pattern a)
-> Pattern Time -> Pattern a -> Pattern a
forall b c a.
(b -> Pattern c -> Pattern a)
-> Pattern b -> Pattern c -> Pattern a
patternify' Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
_ply

_ply :: Rational -> Pattern a -> Pattern a
_ply :: forall a. Time -> Pattern a -> Pattern a
_ply Time
n Pattern a
pat = Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
squeezeJoin (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
_fast Time
n (Pattern a -> Pattern a) -> (a -> Pattern a) -> a -> Pattern a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Pattern a
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Pattern a) -> Pattern a -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a
pat

-- | As 'ply', but applies a function each time. The applications are compounded.
plyWith :: (Ord t, Num t) => Pattern t -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
plyWith :: forall t a.
(Ord t, Num t) =>
Pattern t -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
plyWith Pattern t
np Pattern a -> Pattern a
f Pattern a
p = Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
innerJoin (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ (\t
n -> t -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall t a.
(Ord t, Num t) =>
t -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
_plyWith t
n Pattern a -> Pattern a
f Pattern a
p) (t -> Pattern a) -> Pattern t -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern t
np

_plyWith :: (Ord t, Num t) => t -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
_plyWith :: forall t a.
(Ord t, Num t) =>
t -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
_plyWith t
numPat Pattern a -> Pattern a
f Pattern a
p = Pattern a -> Pattern a
forall a. Pattern a -> Pattern a
arpeggiate (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ t -> Pattern a
forall {a}. (Ord a, Num a) => a -> Pattern a
compound t
numPat
  where
    compound :: a -> Pattern a
compound a
n
      | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
1 = Pattern a
p
      | Bool
otherwise = Pattern a -> Pattern a -> Pattern a
forall a. Pattern a -> Pattern a -> Pattern a
overlay Pattern a
p (Pattern a -> Pattern a
f (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ a -> Pattern a
compound (a -> Pattern a) -> a -> Pattern a
forall a b. (a -> b) -> a -> b
$ a
n a -> a -> a
forall a. Num a => a -> a -> a
- a
1)

-- | Syncopates a rhythm, shifting (delaying) each event halfway into its arc
--  (timespan).
--
--  In mini-notation terms, it basically turns every instance of a into @[~ a]@,
--  e.g., @"a b [c d] e"@ becomes the equivalent of
--  @"[~ a] [~ b] [[~ c] [~ d]] [~ e]"@.
--  Every beat then becomes an offbeat, and so the overall effect is to
--  syncopate a pattern.
--
--  In the following example, you can hear that the piano chords play between the
--  snare and the bass drum. In 4/4 time, they are playing in the 2 and a half,
--  and 4 and a half beats:
--
--  > do
--  >   resetCycles
--  >   d1 $ stack [
--  >     press $ n "~ c'maj ~ c'maj" # s "superpiano" # gain 0.9 # pan 0.6,
--  >     s "[bd,clap sd bd sd]" # pan 0.4
--  >     ] # cps (90/60/4)
--
--  In the next example, the C major chord plays before the G major. As the slot
--  that occupies the C chord is that of one eighth note, it is displaced by press
--  only a sixteenth note:
--
--  > do
--  >   resetCycles
--  >   d1 $ stack [
--  >     press $ n "~ [c'maj ~] ~ ~" # s "superpiano" # gain 0.9 # pan 0.6,
--  >     press $ n "~ g'maj ~ ~" # s "superpiano" # gain 0.9 # pan 0.4,
--  >     s "[bd,clap sd bd sd]"
--  >    ] # cps (90/60/4)
press :: Pattern a -> Pattern a
press :: forall a. Pattern a -> Pattern a
press = Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
_pressBy Time
0.5

-- | Like @press@, but allows you to specify the amount in which each event is
--  shifted as a float from 0 to 1 (exclusive).
--
--  @pressBy 0.5@ is the same as @press@, while @pressBy (1/3)@ shifts each event
--  by a third of its arc.
--
--  You can pattern the displacement to create interesting rhythmic effects:
--
--  > d1 $ stack [
--  >   s "bd sd bd sd",
--  >   pressBy "<0 0.5>" $ s "co:2*4"
--  > ]
--
--  > d1 $ stack [
--  >   s "[bd,co sd bd sd]",
--  >   pressBy "<0 0.25 0.5 0.75>" $ s "cp"
--  > ]
pressBy :: Pattern Time -> Pattern a -> Pattern a
pressBy :: forall a. Pattern Time -> Pattern a -> Pattern a
pressBy = (Time -> Pattern a -> Pattern a)
-> Pattern Time -> Pattern a -> Pattern a
forall b c a.
(b -> Pattern c -> Pattern a)
-> Pattern b -> Pattern c -> Pattern a
patternify' Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
_pressBy

_pressBy :: Time -> Pattern a -> Pattern a
_pressBy :: forall a. Time -> Pattern a -> Pattern a
_pressBy Time
r Pattern a
pat = Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
squeezeJoin (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ (Time, Time) -> Pattern a -> Pattern a
forall a. (Time, Time) -> Pattern a -> Pattern a
compressTo (Time
r, Time
1) (Pattern a -> Pattern a) -> (a -> Pattern a) -> a -> Pattern a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Pattern a
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Pattern a) -> Pattern a -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a
pat

{-
  Uses the first (binary) pattern to switch between the following
  two patterns. The resulting structure comes from the source patterns, not the
  binary pattern. See also `stitch`.

  The following will play the first pattern for the first half of a cycle, and
  the second pattern for the other half; it combines two patterns of strings and
  passes the result to the sound function:

  > d1 $ sound (sew "t f" "bd*8" "cp*8")

  It’s possible to sew together two control patterns:

  > d1 $ sew "t <f t> <f [f t] t>"
  >          (n "0 .. 15" # s "future")
  >          (s "cp:3*16" # speed saw + 1.2)

  You can also use Euclidean rhythm syntax in the boolean sequence:

  > d1 $ sew "t(11,16)"
  >          (n "0 .. 15" # s "future")
  >          (s "cp:3*16" # speed sine + 1.5)
-}
sew :: Pattern Bool -> Pattern a -> Pattern a -> Pattern a
-- Replaced with more efficient version below
-- sew pb a b = overlay (mask pb a) (mask (inv pb) b)
sew :: forall a. Pattern Bool -> Pattern a -> Pattern a -> Pattern a
sew Pattern Bool
pb Pattern a
a Pattern a
b = (State -> [Event a])
-> Maybe (Pattern Time) -> Maybe a -> Pattern a
forall a.
(State -> [Event a])
-> Maybe (Pattern Time) -> Maybe a -> Pattern a
Pattern State -> [Event a]
pf Maybe (Pattern Time)
forall a. Maybe a
Nothing Maybe a
forall a. Maybe a
Nothing
  where
    pf :: State -> [Event a]
pf State
st = (Event Bool -> [Event a]) -> [Event Bool] -> [Event a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Event Bool -> [Event a]
match [Event Bool]
evs
      where
        evs :: [Event Bool]
evs = Pattern Bool -> State -> [Event Bool]
forall a. Pattern a -> State -> [Event a]
query Pattern Bool
pb State
st
        parts :: [Arc]
parts = (Event Bool -> Arc) -> [Event Bool] -> [Arc]
forall a b. (a -> b) -> [a] -> [b]
map Event Bool -> Arc
forall a b. EventF a b -> a
part [Event Bool]
evs
        subarc :: Arc
subarc = Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc ([Time] -> Time
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Time] -> Time) -> [Time] -> Time
forall a b. (a -> b) -> a -> b
$ (Arc -> Time) -> [Arc] -> [Time]
forall a b. (a -> b) -> [a] -> [b]
map Arc -> Time
forall a. ArcF a -> a
start [Arc]
parts) ([Time] -> Time
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Time] -> Time) -> [Time] -> Time
forall a b. (a -> b) -> a -> b
$ (Arc -> Time) -> [Arc] -> [Time]
forall a b. (a -> b) -> [a] -> [b]
map Arc -> Time
forall a. ArcF a -> a
stop [Arc]
parts)
        match :: Event Bool -> [Event a]
match Event Bool
ev
          | Event Bool -> Bool
forall a b. EventF a b -> b
value Event Bool
ev = [Event a] -> Event Bool -> [Event a]
forall {b} {b}. [EventF Arc b] -> EventF Arc b -> [EventF Arc b]
find (Pattern a -> State -> [Event a]
forall a. Pattern a -> State -> [Event a]
query Pattern a
a State
st {arc = subarc}) Event Bool
ev
          | Bool
otherwise = [Event a] -> Event Bool -> [Event a]
forall {b} {b}. [EventF Arc b] -> EventF Arc b -> [EventF Arc b]
find (Pattern a -> State -> [Event a]
forall a. Pattern a -> State -> [Event a]
query Pattern a
b State
st {arc = subarc}) Event Bool
ev
        find :: [EventF Arc b] -> EventF Arc b -> [EventF Arc b]
find [EventF Arc b]
evs' EventF Arc b
ev = [Maybe (EventF Arc b)] -> [EventF Arc b]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (EventF Arc b)] -> [EventF Arc b])
-> [Maybe (EventF Arc b)] -> [EventF Arc b]
forall a b. (a -> b) -> a -> b
$ (EventF Arc b -> Maybe (EventF Arc b))
-> [EventF Arc b] -> [Maybe (EventF Arc b)]
forall a b. (a -> b) -> [a] -> [b]
map (EventF Arc b -> EventF Arc b -> Maybe (EventF Arc b)
forall {b} {b}.
EventF Arc b -> EventF Arc b -> Maybe (EventF Arc b)
check EventF Arc b
ev) [EventF Arc b]
evs'
        check :: EventF Arc b -> EventF Arc b -> Maybe (EventF Arc b)
check EventF Arc b
bev EventF Arc b
xev = do
          Arc
newarc <- Arc -> Arc -> Maybe Arc
subArc (EventF Arc b -> Arc
forall a b. EventF a b -> a
part EventF Arc b
bev) (EventF Arc b -> Arc
forall a b. EventF a b -> a
part EventF Arc b
xev)
          EventF Arc b -> Maybe (EventF Arc b)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (EventF Arc b -> Maybe (EventF Arc b))
-> EventF Arc b -> Maybe (EventF Arc b)
forall a b. (a -> b) -> a -> b
$ EventF Arc b
xev {part = newarc}

-- | Uses the first (binary) pattern to switch between the following
--  two patterns. The resulting structure comes from the binary
--  pattern, not the source patterns. (In 'sew', by contrast, the resulting structure comes from the source patterns.)
--
--  The following uses a euclidean pattern to control CC0:
--
--  > d1 $ ccv (stitch "t(7,16)" 127 0) # ccn 0  # "midi"
stitch :: Pattern Bool -> Pattern a -> Pattern a -> Pattern a
stitch :: forall a. Pattern Bool -> Pattern a -> Pattern a -> Pattern a
stitch Pattern Bool
pb Pattern a
a Pattern a
b = Pattern a -> Pattern a -> Pattern a
forall a. Pattern a -> Pattern a -> Pattern a
overlay (Pattern Bool -> Pattern a -> Pattern a
forall a. Pattern Bool -> Pattern a -> Pattern a
struct Pattern Bool
pb Pattern a
a) (Pattern Bool -> Pattern a -> Pattern a
forall a. Pattern Bool -> Pattern a -> Pattern a
struct (Pattern Bool -> Pattern Bool
forall (f :: * -> *). Functor f => f Bool -> f Bool
inv Pattern Bool
pb) Pattern a
b)

-- | A binary pattern is used to conditionally apply a function to a
-- source pattern. The function is applied when a @True@ value is
-- active, and the pattern is let through unchanged when a @False@
-- value is active. No events are let through where no binary values
-- are active.
while :: Pattern Bool -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
while :: forall a.
Pattern Bool -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
while Pattern Bool
b Pattern a -> Pattern a
f Pattern a
pat = Pattern a -> Pattern a -> Pattern a
forall a b. Pattern a -> Pattern b -> Pattern b
keepTactus Pattern a
pat (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ Pattern Bool -> Pattern a -> Pattern a -> Pattern a
forall a. Pattern Bool -> Pattern a -> Pattern a -> Pattern a
sew Pattern Bool
b (Pattern a -> Pattern a
f Pattern a
pat) Pattern a
pat

-- |
-- @stutter n t pat@ repeats each event in @pat@ @n@ times, separated by @t@ time (in fractions of a cycle).
-- It is like 'Sound.Tidal.Control.echo' that doesn't reduce the volume, or 'ply' if you controlled the timing.
--
-- > d1 $ stutter 4 (1/16) $ s "bd cp"
--
-- is functionally equivalent to
--
-- > d1 $ stut 4 1 (1/16) $ s "bd cp"
stutter :: (Integral i) => i -> Time -> Pattern a -> Pattern a
stutter :: forall i a. Integral i => i -> Time -> Pattern a -> Pattern a
stutter i
n Time
t Pattern a
p = [Pattern a] -> Pattern a
forall a. [Pattern a] -> Pattern a
stack ([Pattern a] -> Pattern a) -> [Pattern a] -> Pattern a
forall a b. (a -> b) -> a -> b
$ (i -> Pattern a) -> [i] -> [Pattern a]
forall a b. (a -> b) -> [a] -> [b]
map (\i
i -> (Time
t Time -> Time -> Time
forall a. Num a => a -> a -> a
* i -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral i
i) Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
`rotR` Pattern a
p) [i
0 .. (i
n i -> i -> i
forall a. Num a => a -> a -> a
- i
1)]

-- | The @jux@ function creates strange stereo effects by applying a
--  function to a pattern, but only in the right-hand channel. For
--  example, the following reverses the pattern on the righthand side:
--
--  > d1 $ slow 32 $ jux (rev) $ striateBy 32 (1/16) $ sound "bev"
--
--  When passing pattern transforms to functions like @jux@ and 'every',
--  it's possible to chain multiple transforms together with `.` (function
--  composition). For example this both reverses and halves the playback speed of
--  the pattern in the righthand channel:
--
--  > d1 $ slow 32 $ jux ((# speed "0.5") . rev) $ striateBy 32 (1/16) $ sound "bev"
jux ::
  (Pattern ValueMap -> Pattern ValueMap) ->
  Pattern ValueMap ->
  Pattern ValueMap
jux :: (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
jux = Pattern Double
-> (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap
-> Pattern ValueMap
juxBy Pattern Double
1

juxcut ::
  (Pattern ValueMap -> Pattern ValueMap) ->
  Pattern ValueMap ->
  Pattern ValueMap
juxcut :: (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
juxcut Pattern ValueMap -> Pattern ValueMap
f Pattern ValueMap
p =
  [Pattern ValueMap] -> Pattern ValueMap
forall a. [Pattern a] -> Pattern a
stack
    [ Pattern ValueMap
p Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern Double -> Pattern ValueMap
P.pan (Double -> Pattern Double
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
0) Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern Int -> Pattern ValueMap
P.cut (Int -> Pattern Int
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (-Int
1)),
      Pattern ValueMap -> Pattern ValueMap
f (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ Pattern ValueMap
p Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern Double -> Pattern ValueMap
P.pan (Double -> Pattern Double
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
1) Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern Int -> Pattern ValueMap
P.cut (Int -> Pattern Int
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (-Int
2))
    ]

juxcut' :: [t -> Pattern ValueMap] -> t -> Pattern ValueMap
juxcut' :: forall t. [t -> Pattern ValueMap] -> t -> Pattern ValueMap
juxcut' [t -> Pattern ValueMap]
fs t
p = [Pattern ValueMap] -> Pattern ValueMap
forall a. [Pattern a] -> Pattern a
stack ([Pattern ValueMap] -> Pattern ValueMap)
-> [Pattern ValueMap] -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ (Int -> Pattern ValueMap) -> [Int] -> [Pattern ValueMap]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
n -> (([t -> Pattern ValueMap]
fs [t -> Pattern ValueMap] -> Int -> t -> Pattern ValueMap
forall a. HasCallStack => [a] -> Int -> a
!! Int
n) t
p Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall a. Num a => Pattern a -> Pattern a -> Pattern a
|+ Pattern Int -> Pattern ValueMap
P.cut (Int -> Pattern Int
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Pattern Int) -> Int -> Pattern Int
forall a b. (a -> b) -> a -> b
$ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n)) Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern Double -> Pattern ValueMap
P.pan (Double -> Pattern Double
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> Pattern Double) -> Double -> Pattern Double
forall a b. (a -> b) -> a -> b
$ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l)) [Int
0 .. Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
  where
    l :: Int
l = [t -> Pattern ValueMap] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [t -> Pattern ValueMap]
fs

-- | In addition to `jux`, `jux'` allows using a list of pattern
--  transformations. Resulting patterns from each transformation will be spread via
--  pan from left to right.
--
--  For example, the following will put @iter 4@ of the pattern to the far left
--  and `palindrome` to the far right. In the center, the original pattern will
--  play and the chopped and the reversed version will appear mid left and mid
--  right respectively.
--
--  > d1 $ jux' [iter 4, chop 16, id, rev, palindrome] $ sound "bd sn"
--
-- One could also write:
--
-- @
-- d1 $ stack
--      [ iter 4 $ sound "bd sn" # pan "0"
--      , chop 16 $ sound "bd sn" # pan "0.25"
--      , sound "bd sn" # pan "0.5"
--      , rev $ sound "bd sn" # pan "0.75"
--      , palindrome $ sound "bd sn" # pan "1"
--      ]
-- @
jux' :: [t -> Pattern ValueMap] -> t -> Pattern ValueMap
jux' :: forall t. [t -> Pattern ValueMap] -> t -> Pattern ValueMap
jux' [t -> Pattern ValueMap]
fs t
p = [Pattern ValueMap] -> Pattern ValueMap
forall a. [Pattern a] -> Pattern a
stack ([Pattern ValueMap] -> Pattern ValueMap)
-> [Pattern ValueMap] -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ (Int -> Pattern ValueMap) -> [Int] -> [Pattern ValueMap]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
n -> ([t -> Pattern ValueMap]
fs [t -> Pattern ValueMap] -> Int -> t -> Pattern ValueMap
forall a. HasCallStack => [a] -> Int -> a
!! Int
n) t
p Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall a. Num a => Pattern a -> Pattern a -> Pattern a
|+ Pattern Double -> Pattern ValueMap
P.pan (Double -> Pattern Double
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> Pattern Double) -> Double -> Pattern Double
forall a b. (a -> b) -> a -> b
$ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l)) [Int
0 .. Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
  where
    l :: Int
l = [t -> Pattern ValueMap] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [t -> Pattern ValueMap]
fs

-- | Multichannel variant of `jux`, /not sure what it does/
jux4 ::
  (Pattern ValueMap -> Pattern ValueMap) ->
  Pattern ValueMap ->
  Pattern ValueMap
jux4 :: (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
jux4 Pattern ValueMap -> Pattern ValueMap
f Pattern ValueMap
p = [Pattern ValueMap] -> Pattern ValueMap
forall a. [Pattern a] -> Pattern a
stack [Pattern ValueMap
p Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern Double -> Pattern ValueMap
P.pan (Double -> Pattern Double
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double
5 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
8)), Pattern ValueMap -> Pattern ValueMap
f (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ Pattern ValueMap
p Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern Double -> Pattern ValueMap
P.pan (Double -> Pattern Double
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
8))]

-- |
-- With `jux`, the original and effected versions of the pattern are
-- panned hard left and right (i.e., panned at 0 and 1). This can be a
-- bit much, especially when listening on headphones. The variant @juxBy@
-- has an additional parameter, which brings the channel closer to the
-- centre. For example:
--
-- > d1 $ juxBy 0.5 (fast 2) $ sound "bd sn:1"
--
-- In the above, the two versions of the pattern would be panned at 0.25
-- and 0.75, rather than 0 and 1.
juxBy ::
  Pattern Double ->
  (Pattern ValueMap -> Pattern ValueMap) ->
  Pattern ValueMap ->
  Pattern ValueMap
-- TODO: lcm tactus of p and f p?
juxBy :: Pattern Double
-> (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap
-> Pattern ValueMap
juxBy Pattern Double
n Pattern ValueMap -> Pattern ValueMap
f Pattern ValueMap
p = Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall a b. Pattern a -> Pattern b -> Pattern b
keepTactus Pattern ValueMap
p (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ [Pattern ValueMap] -> Pattern ValueMap
forall a. [Pattern a] -> Pattern a
stack [Pattern ValueMap
p Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall a. Num a => Pattern a -> Pattern a -> Pattern a
|+ Pattern Double -> Pattern ValueMap
P.pan Pattern Double
0.5 Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall a. Num a => Pattern a -> Pattern a -> Pattern a
|- Pattern Double -> Pattern ValueMap
P.pan (Pattern Double
n Pattern Double -> Pattern Double -> Pattern Double
forall a. Fractional a => a -> a -> a
/ Pattern Double
2), Pattern ValueMap -> Pattern ValueMap
f (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ Pattern ValueMap
p Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall a. Num a => Pattern a -> Pattern a -> Pattern a
|+ Pattern Double -> Pattern ValueMap
P.pan Pattern Double
0.5 Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall a. Num a => Pattern a -> Pattern a -> Pattern a
|+ Pattern Double -> Pattern ValueMap
P.pan (Pattern Double
n Pattern Double -> Pattern Double -> Pattern Double
forall a. Fractional a => a -> a -> a
/ Pattern Double
2)]

-- |
-- Given a sample's directory name and number, this generates a string
-- suitable to pass to 'Data.String.fromString' to create a 'Pattern String'.
-- 'samples' is a 'Pattern'-compatible interface to this function.
--
-- @pick name n = name ++ ":" ++ show n@
pick :: String -> Int -> String
pick :: [Char] -> Int -> [Char]
pick [Char]
name Int
n = [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n

-- |
-- Given a pattern of sample directory names and a of pattern indices
-- create a pattern of strings corresponding to the sample at each
-- name-index pair.
--
-- An example:
--
-- > samples "jvbass [~ latibro] [jvbass [latibro jvbass]]"
-- >         ((1%2) `rotL` slow 6 "[1 6 8 7 3]")
--
-- The type signature is more general here, but you can consider this
-- to be a function of type @Pattern String -> Pattern Int -> Pattern String@.
--
-- @samples = liftA2 pick@
samples :: (Applicative f) => f String -> f Int -> f String
samples :: forall (f :: * -> *).
Applicative f =>
f [Char] -> f Int -> f [Char]
samples f [Char]
p f Int
p' = [Char] -> Int -> [Char]
pick ([Char] -> Int -> [Char]) -> f [Char] -> f (Int -> [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f [Char]
p f (Int -> [Char]) -> f Int -> f [Char]
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f Int
p'

-- |
-- Equivalent to 'samples', though the sample specifier pattern
-- (the @f Int@) will be evaluated first. Not a large difference
-- in the majority of cases.
samples' :: (Applicative f) => f String -> f Int -> f String
samples' :: forall (f :: * -> *).
Applicative f =>
f [Char] -> f Int -> f [Char]
samples' f [Char]
p f Int
p' = ([Char] -> Int -> [Char]) -> Int -> [Char] -> [Char]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Char] -> Int -> [Char]
pick (Int -> [Char] -> [Char]) -> f Int -> f ([Char] -> [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Int
p' f ([Char] -> [Char]) -> f [Char] -> f [Char]
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f [Char]
p

{-
scrumple :: Time -> Pattern a -> Pattern a -> Pattern a
scrumple o p p' = p'' -- overlay p (o `rotR` p'')
  where p'' = pattern $ \a -> concatMap
                              (\((s,d), vs) -> map (\x -> ((s,d),
                                                           snd x
                                                          )
                                                   )
                                                   (arc p' (s,s))
                              ) (arc p a)
-}

{-
 As 'spread', but specialized so that the list contains functions returning patterns.

@spreadf = 'spread' ($)@
-}
spreadf :: [a -> Pattern b] -> a -> Pattern b
spreadf :: forall a b. [a -> Pattern b] -> a -> Pattern b
spreadf = ((a -> Pattern b) -> a -> Pattern b)
-> [a -> Pattern b] -> a -> Pattern b
forall a t b. (a -> t -> Pattern b) -> [a] -> t -> Pattern b
spread (a -> Pattern b) -> a -> Pattern b
forall a b. (a -> b) -> a -> b
($)

stackwith :: (Unionable a) => Pattern a -> [Pattern a] -> Pattern a
stackwith :: forall a. Unionable a => Pattern a -> [Pattern a] -> Pattern a
stackwith Pattern a
p [Pattern a]
ps
  | [Pattern a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pattern a]
ps = Pattern a
forall a. Pattern a
silence
  | Bool
otherwise = [Pattern a] -> Pattern a
forall a. [Pattern a] -> Pattern a
stack ([Pattern a] -> Pattern a) -> [Pattern a] -> Pattern a
forall a b. (a -> b) -> a -> b
$ (Int -> Pattern a -> Pattern a)
-> [Int] -> [Pattern a] -> [Pattern a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
i Pattern a
p' -> Pattern a
p' Pattern a -> Pattern a -> Pattern a
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# ((Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i Integer -> Integer -> Time
forall a. Integral a => a -> a -> Ratio a
% Integer
l) Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
`rotL` Pattern a
p)) [Int
0 :: Int ..] [Pattern a]
ps
  where
    l :: Integer
l = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ [Pattern a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern a]
ps

{-
cross f p p' = pattern $ \t -> concat [filter flt $ arc p t,
                                       filter (not . flt) $ arc p' t
                                      ]
]  where flt = f . cyclePos . fst . fst
-}

-- | `range` will take a pattern which goes from 0 to 1 (like `sine`), and range it to a different range - between the first and second arguments. In the below example, `range 1 1.5` shifts the range of `sine1` from 0 - 1 to 1 - 1.5.
--
-- > d1 $ jux (iter 4) $ sound "arpy arpy:2*2"
-- >   |+ speed (slow 4 $ range 1 1.5 sine1)
--
-- The above is equivalent to:
--
-- > d1 $ jux (iter 4) $ sound "arpy arpy:2*2"
-- >   |+ speed (slow 4 $ sine1 * 0.5 + 1)
range :: (Num a) => Pattern a -> Pattern a -> Pattern a -> Pattern a
range :: forall a. Num a => Pattern a -> Pattern a -> Pattern a -> Pattern a
range Pattern a
fromP Pattern a
toP Pattern a
p = (\a
from a
to a
v -> ((a
v a -> a -> a
forall a. Num a => a -> a -> a
* (a
to a -> a -> a
forall a. Num a => a -> a -> a
- a
from)) a -> a -> a
forall a. Num a => a -> a -> a
+ a
from)) (a -> a -> a -> a) -> Pattern a -> Pattern (a -> a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a
fromP Pattern (a -> a -> a) -> Pattern a -> Pattern (a -> a)
forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
*> Pattern a
toP Pattern (a -> a) -> Pattern a -> Pattern a
forall a b. Pattern (a -> b) -> Pattern a -> Pattern b
*> Pattern a
p

_range :: (Functor f, Num b) => b -> b -> f b -> f b
_range :: forall (f :: * -> *) b. (Functor f, Num b) => b -> b -> f b -> f b
_range b
from b
to f b
p = (b -> b -> b
forall a. Num a => a -> a -> a
+ b
from) (b -> b) -> (b -> b) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> b -> b
forall a. Num a => a -> a -> a
* (b
to b -> b -> b
forall a. Num a => a -> a -> a
- b
from)) (b -> b) -> f b -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f b
p

-- | `rangex` is an exponential version of `range`, good for using with
-- frequencies. For example, @range 20 2000 "0.5"@ will give @1010@ - halfway
-- between @20@ and @2000@. But @rangex 20 2000 0.5@ will give @200@ - halfway
-- between on a logarithmic scale. This usually sounds better if you’re using the
-- numbers as pitch frequencies. Since rangex uses logarithms, don’t try to scale
-- things to zero or less.
rangex :: (Functor f, Floating b) => b -> b -> f b -> f b
rangex :: forall (f :: * -> *) b.
(Functor f, Floating b) =>
b -> b -> f b -> f b
rangex b
from b
to f b
p = b -> b
forall {a}. Floating a => a -> a
exp (b -> b) -> f b -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> b -> f b -> f b
forall (f :: * -> *) b. (Functor f, Num b) => b -> b -> f b -> f b
_range (b -> b
forall {a}. Floating a => a -> a
log b
from) (b -> b
forall {a}. Floating a => a -> a
log b
to) f b
p

-- |
--  @off@ is similar to 'superimpose', in that it applies a function to a pattern
--  and layers up the results on top of the original pattern. The difference
--  is that @off@ takes an extra pattern being a time (in cycles) to shift the
--  transformed version of the pattern by.
--
--  The following plays a pattern on top of itself, but offset by an eighth of a
--  cycle, with a distorting bitcrush effect applied:
--
--  > d1 $ off 0.125 (# crush 2) $ sound "bd [~ sn:2] mt lt*2"
--
--  The following makes arpeggios by adding offset patterns that are shifted up
--  the scale:
--
--  > d1 $ slow 2
--  >    $ n (off 0.25 (+12)
--  >    $ off 0.125 (+7)
--  >    $ slow 2 "c(3,8) a(3,8,2) f(3,8) e(3,8,4)")
--  >    # sound "superpiano"
off :: Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
off :: forall a.
Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
off Pattern Time
tp Pattern a -> Pattern a
f Pattern a
p = Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
innerJoin (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ (\Time
tv -> Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a.
Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
_off Time
tv Pattern a -> Pattern a
f Pattern a
p) (Time -> Pattern a) -> Pattern Time -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Time
tp

_off :: Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
_off :: forall a.
Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
_off Time
t Pattern a -> Pattern a
f Pattern a
p = (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a. (Pattern a -> Pattern a) -> Pattern a -> Pattern a
superimpose (Pattern a -> Pattern a
f (Pattern a -> Pattern a)
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Time
t Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
`rotR`)) Pattern a
p

offadd :: (Num a) => Pattern Time -> Pattern a -> Pattern a -> Pattern a
offadd :: forall a.
Num a =>
Pattern Time -> Pattern a -> Pattern a -> Pattern a
offadd Pattern Time
tp Pattern a
pn Pattern a
p = Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a.
Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
off Pattern Time
tp (Pattern a -> Pattern a -> Pattern a
forall a. Num a => a -> a -> a
+ Pattern a
pn) Pattern a
p

-- |
--  @sseq@ acts as a kind of simple step-sequencer using strings. For example,
--  @sseq "sn" "x x 12"@ is equivalent to the pattern of strings given by @"sn ~
--  sn ~ sn:1 sn:2 ~"@. @sseq@ substitutes the given string for each @x@, for each number
--  it substitutes the string followed by a colon and the number, and for everything
--  else it puts in a rest.
--
--  In other words, @sseq@ generates a pattern of strings in exactly the syntax you’d want for selecting samples and that can be fed directly into the 's' function.
--
--  > d1 $ s (sseq "sn" "x x 12 ")
sseq :: String -> String -> Pattern String
sseq :: [Char] -> [Char] -> Pattern [Char]
sseq [Char]
s [Char]
cs = [Pattern [Char]] -> Pattern [Char]
forall a. [Pattern a] -> Pattern a
fastcat ([Pattern [Char]] -> Pattern [Char])
-> [Pattern [Char]] -> Pattern [Char]
forall a b. (a -> b) -> a -> b
$ (Char -> Pattern [Char]) -> [Char] -> [Pattern [Char]]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Pattern [Char]
f [Char]
cs
  where
    f :: Char -> Pattern [Char]
f Char
c
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'x' = [Char] -> Pattern [Char]
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
s
      | Char -> Bool
isDigit Char
c = [Char] -> Pattern [Char]
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Pattern [Char]) -> [Char] -> Pattern [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char
c]
      | Bool
otherwise = Pattern [Char]
forall a. Pattern a
silence

-- | @sseqs@ is like @sseq@ but it takes a list of pairs, like sseq would, and
--  it plays them all simultaneously.
--
--  > d1 $ s (sseqs [("cp","x  x x  x x  x"),("bd", "xxxx")])
sseqs :: [(String, String)] -> Pattern String
sseqs :: [([Char], [Char])] -> Pattern [Char]
sseqs = [Pattern [Char]] -> Pattern [Char]
forall a. [Pattern a] -> Pattern a
stack ([Pattern [Char]] -> Pattern [Char])
-> ([([Char], [Char])] -> [Pattern [Char]])
-> [([Char], [Char])]
-> Pattern [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char], [Char]) -> Pattern [Char])
-> [([Char], [Char])] -> [Pattern [Char]]
forall a b. (a -> b) -> [a] -> [b]
map (([Char] -> [Char] -> Pattern [Char])
-> ([Char], [Char]) -> Pattern [Char]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Char] -> [Char] -> Pattern [Char]
sseq)

-- | like `sseq`, but allows you to specify an array of strings to use for @0,1,2...@
--  For example,
--
--  > d1 $ s (sseq' ["superpiano","supermandolin"] "0 1 000 1")
--  >    # sustain 4 # n 0
--
--  is equivalent to
--
--  > d1 $ s "superpiano ~ supermandolin ~ superpiano!3 ~ supermandolin"
--  >    # sustain 4 # n 0
sseq' :: [String] -> String -> Pattern String
sseq' :: [[Char]] -> [Char] -> Pattern [Char]
sseq' [[Char]]
ss [Char]
cs = [Pattern [Char]] -> Pattern [Char]
forall a. [Pattern a] -> Pattern a
fastcat ([Pattern [Char]] -> Pattern [Char])
-> [Pattern [Char]] -> Pattern [Char]
forall a b. (a -> b) -> a -> b
$ (Char -> Pattern [Char]) -> [Char] -> [Pattern [Char]]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Pattern [Char]
f [Char]
cs
  where
    f :: Char -> Pattern [Char]
f Char
c
      | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'x' = [Char] -> Pattern [Char]
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Pattern [Char]) -> [Char] -> Pattern [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall a. HasCallStack => [a] -> a
head [[Char]]
ss
      | Char -> Bool
isDigit Char
c = [Char] -> Pattern [Char]
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Pattern [Char]) -> [Char] -> Pattern [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]]
ss [[Char]] -> Int -> [Char]
forall a. HasCallStack => [a] -> Int -> a
!! Char -> Int
digitToInt Char
c
      | Bool
otherwise = Pattern [Char]
forall a. Pattern a
silence

-- | Deprecated backwards-compatible alias for 'ghostWith'.
ghost'' :: Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
ghost'' :: forall a.
Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
ghost'' = Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a.
Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
ghostWith

-- | Like 'ghost'', but a user-supplied function describes how to alter the pattern.
--
--  In this example, ghost notes are applied to the snare hit, but these notes will
--  be louder, not quieter, and the sample will have its beginning slightly cut:
--
--  > d1 $ slow 2
--  >    $ ghostWith (1/16) ((|*| gain 1.1) . (|> begin 0.05))
--  >    $ sound "sn"
ghostWith :: Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
ghostWith :: forall a.
Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
ghostWith Time
a Pattern a -> Pattern a
f Pattern a
p = (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a. (Pattern a -> Pattern a) -> Pattern a -> Pattern a
superimpose (((Time
a Time -> Time -> Time
forall a. Num a => a -> a -> a
* Time
2.5) Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
`rotR`) (Pattern a -> Pattern a)
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern a -> Pattern a
f) (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a. (Pattern a -> Pattern a) -> Pattern a -> Pattern a
superimpose (((Time
a Time -> Time -> Time
forall a. Num a => a -> a -> a
* Time
1.5) Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
`rotR`) (Pattern a -> Pattern a)
-> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern a -> Pattern a
f) Pattern a
p

{-
@ghost' t pat@ Adds quieter, pitch-shifted, copies of an event @t@ cycles after events in @pat@, emulating ghost notes that are common in drumming patterns.

The following creates a kick snare pattern with ghost notes applied to the snare hit:

> d1 $ stack [ ghost' 0.125 $ sound "~ sn", sound "bd*2 [~ bd]" ]
-}
ghost' :: Time -> Pattern ValueMap -> Pattern ValueMap
ghost' :: Time -> Pattern ValueMap -> Pattern ValueMap
ghost' Time
a Pattern ValueMap
p = Time
-> (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap
-> Pattern ValueMap
forall a.
Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
ghostWith Time
a ((Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall (a :: * -> *) b. (Applicative a, Num b) => a b -> a b -> a b
|*| Pattern Double -> Pattern ValueMap
P.gain (Double -> Pattern Double
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
0.7)) (Pattern ValueMap -> Pattern ValueMap)
-> (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap
-> Pattern ValueMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
|> Pattern Double -> Pattern ValueMap
P.end (Double -> Pattern Double
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
0.2)) (Pattern ValueMap -> Pattern ValueMap)
-> (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap
-> Pattern ValueMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall (a :: * -> *) b. (Applicative a, Num b) => a b -> a b -> a b
|*| Pattern Double -> Pattern ValueMap
P.speed (Double -> Pattern Double
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
1.25))) Pattern ValueMap
p

-- | As 'ghost'', but with the copies set to appear one-eighth of a cycle afterwards.
--
-- @ghost = ghost' 0.125@
--
-- The following creates a kick snare pattern with ghost notes applied to the snare hit:
--
-- > d1 $ stack [ ghost $ sound "~ sn", sound "bd*2 [~ bd]" ]
ghost :: Pattern ValueMap -> Pattern ValueMap
ghost :: Pattern ValueMap -> Pattern ValueMap
ghost = Time -> Pattern ValueMap -> Pattern ValueMap
ghost' Time
0.125

-- | A more literal weaving than the `weave` function. Given @tabby threads p1 p@,
--   parameters representing the threads per cycle and the patterns to weave, and
--   this function will weave them together using a plain (aka ’tabby’) weave,
--   with a simple over/under structure
tabby :: Int -> Pattern a -> Pattern a -> Pattern a
tabby :: forall a. Int -> Pattern a -> Pattern a -> Pattern a
tabby Int
nInt Pattern a
p Pattern a
p' =
  [Pattern a] -> Pattern a
forall a. [Pattern a] -> Pattern a
stack
    [ Pattern a
maskedWarp,
      Pattern a
maskedWeft
    ]
  where
    n :: Integer
n = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nInt
    weft :: [[Integer]]
weft = (Integer -> [[Integer]]) -> [Integer] -> [[Integer]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([[Integer]] -> Integer -> [[Integer]]
forall a b. a -> b -> a
const [[Integer
0 .. Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1], [Integer] -> [Integer]
forall a. [a] -> [a]
reverse [Integer
0 .. Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1]]) [Integer
0 .. (Integer
n Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
2) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1]
    warp :: [[Integer]]
warp = [[Integer]] -> [[Integer]]
forall a. [[a]] -> [[a]]
transpose [[Integer]]
weft
    thread :: t [Integer] -> Pattern a -> Pattern a
thread t [Integer]
xs Pattern a
p'' = Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
_slow (Integer
n Integer -> Integer -> Time
forall a. Integral a => a -> a -> Ratio a
% Integer
1) (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ [Pattern a] -> Pattern a
forall a. [Pattern a] -> Pattern a
fastcat ([Pattern a] -> Pattern a) -> [Pattern a] -> Pattern a
forall a b. (a -> b) -> a -> b
$ (Integer -> Pattern a) -> [Integer] -> [Pattern a]
forall a b. (a -> b) -> [a] -> [b]
map (\Integer
i -> Arc -> Pattern a -> Pattern a
forall a. Arc -> Pattern a -> Pattern a
zoomArc (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc (Integer
i Integer -> Integer -> Time
forall a. Integral a => a -> a -> Ratio a
% Integer
n) ((Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) Integer -> Integer -> Time
forall a. Integral a => a -> a -> Ratio a
% Integer
n)) Pattern a
p'') (t [Integer] -> [Integer]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat t [Integer]
xs)
    weftP :: Pattern a
weftP = [[Integer]] -> Pattern a -> Pattern a
forall {t :: * -> *} {a}.
Foldable t =>
t [Integer] -> Pattern a -> Pattern a
thread [[Integer]]
weft Pattern a
p'
    warpP :: Pattern a
warpP = [[Integer]] -> Pattern a -> Pattern a
forall {t :: * -> *} {a}.
Foldable t =>
t [Integer] -> Pattern a -> Pattern a
thread [[Integer]]
warp Pattern a
p
    maskedWeft :: Pattern a
maskedWeft = Pattern Bool -> Pattern a -> Pattern a
forall a. Pattern Bool -> Pattern a -> Pattern a
mask (Pattern Int
-> (Pattern Bool -> Pattern Bool) -> Pattern Bool -> Pattern Bool
forall b.
Pattern Int -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b
every Pattern Int
2 Pattern Bool -> Pattern Bool
forall a. Pattern a -> Pattern a
rev (Pattern Bool -> Pattern Bool) -> Pattern Bool -> Pattern Bool
forall a b. (a -> b) -> a -> b
$ Time -> Pattern Bool -> Pattern Bool
forall a. Time -> Pattern a -> Pattern a
_fast (Integer
n Integer -> Integer -> Time
forall a. Integral a => a -> a -> Ratio a
% Integer
2) (Pattern Bool -> Pattern Bool) -> Pattern Bool -> Pattern Bool
forall a b. (a -> b) -> a -> b
$ [Pattern Bool] -> Pattern Bool
forall a. [Pattern a] -> Pattern a
fastCat [Pattern Bool
forall a. Pattern a
silence, Bool -> Pattern Bool
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True]) Pattern a
weftP
    maskedWarp :: Pattern a
maskedWarp = Pattern Bool -> Pattern a -> Pattern a
forall a. Pattern Bool -> Pattern a -> Pattern a
mask (Pattern Int
-> (Pattern Bool -> Pattern Bool) -> Pattern Bool -> Pattern Bool
forall b.
Pattern Int -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b
every Pattern Int
2 Pattern Bool -> Pattern Bool
forall a. Pattern a -> Pattern a
rev (Pattern Bool -> Pattern Bool) -> Pattern Bool -> Pattern Bool
forall a b. (a -> b) -> a -> b
$ Time -> Pattern Bool -> Pattern Bool
forall a. Time -> Pattern a -> Pattern a
_fast (Integer
n Integer -> Integer -> Time
forall a. Integral a => a -> a -> Ratio a
% Integer
2) (Pattern Bool -> Pattern Bool) -> Pattern Bool -> Pattern Bool
forall a b. (a -> b) -> a -> b
$ [Pattern Bool] -> Pattern Bool
forall a. [Pattern a] -> Pattern a
fastCat [Bool -> Pattern Bool
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True, Pattern Bool
forall a. Pattern a
silence]) Pattern a
warpP

-- | Chooses from a list of patterns, using a pattern of floats (from 0 to 1).
select :: Pattern Double -> [Pattern a] -> Pattern a
select :: forall a. Pattern Double -> [Pattern a] -> Pattern a
select = (Double -> [Pattern a] -> Pattern a)
-> Pattern Double -> [Pattern a] -> Pattern a
forall t1 t2 a.
(t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a
patternify Double -> [Pattern a] -> Pattern a
forall a. Double -> [Pattern a] -> Pattern a
_select

_select :: Double -> [Pattern a] -> Pattern a
_select :: forall a. Double -> [Pattern a] -> Pattern a
_select Double
f [Pattern a]
ps = [Pattern a]
ps [Pattern a] -> Int -> Pattern a
forall a. HasCallStack => [a] -> Int -> a
!! Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0 (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
1 Double
f) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Pattern a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern a]
ps Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))

-- | Chooses from a list of functions, using a pattern of floats (from 0 to 1).
selectF :: Pattern Double -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a
selectF :: forall a.
Pattern Double
-> [Pattern a -> Pattern a] -> Pattern a -> Pattern a
selectF Pattern Double
pf [Pattern a -> Pattern a]
ps Pattern a
p = Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
innerJoin (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ (\Double
f -> Double -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a
forall a.
Double -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a
_selectF Double
f [Pattern a -> Pattern a]
ps Pattern a
p) (Double -> Pattern a) -> Pattern Double -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Double
pf

_selectF :: Double -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a
_selectF :: forall a.
Double -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a
_selectF Double
f [Pattern a -> Pattern a]
ps Pattern a
p = ([Pattern a -> Pattern a]
ps [Pattern a -> Pattern a] -> Int -> Pattern a -> Pattern a
forall a. HasCallStack => [a] -> Int -> a
!! Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Double -> Double
forall a. Ord a => a -> a -> a
max Double
0 (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
0.999999 Double
f) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Pattern a -> Pattern a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern a -> Pattern a]
ps))) Pattern a
p

-- | Chooses from a list of functions, using a pattern of integers.
pickF :: Pattern Int -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a
pickF :: forall a.
Pattern Int -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a
pickF Pattern Int
pInt [Pattern a -> Pattern a]
fs Pattern a
pat = Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
innerJoin (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ (\Int
i -> Int -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a
forall a. Int -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a
_pickF Int
i [Pattern a -> Pattern a]
fs Pattern a
pat) (Int -> Pattern a) -> Pattern Int -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Int
pInt

_pickF :: Int -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a
_pickF :: forall a. Int -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a
_pickF Int
i [Pattern a -> Pattern a]
fs Pattern a
p = ([Pattern a -> Pattern a]
fs [Pattern a -> Pattern a] -> Int -> Pattern a -> Pattern a
forall a. [a] -> Int -> a
!!! Int
i) Pattern a
p

-- | @contrast f f' p p'@ splits the control pattern @p'@ in two, applying
--  the function @f@ to one and @f'@ to the other. This depends on
--  whether events in @p'@ contain values matching with those in @p@.
--  For example, in
--
--  > contrast (# crush 3) (# vowel "a") (n "1") $ n "0 1" # s "bd sn" # speed 3
--
--  the first event will have the vowel effect applied and the second will have
--  the crush applied.
--
--  @contrast@ is like an if-else-statement over patterns. For @contrast t f p@
--  you can think of @t@ as the true branch, @f@ as the false branch, and @p@ as
--  the test.
--
--  You can use any control pattern as a test of equality, e.g., @n "<0 1>", speed
--  "0.5"@, or things like that. This lets you choose specific properties of the
--  pattern you’re transforming for testing, like in the following example,
--
--  > d1 $ contrast (|+ n 12) (|- n 12) (n "c") $ n (run 4) # s "superpiano"
--
--  where every note that isn’t middle-c will be shifted down an octave but
--  middle-c will be shifted up to c5.
--
--  Since the test given to contrast is also a pattern, you can do things like have
--  it alternate between options:
--
--  > d1 $ contrast (|+ n 12) (|- n 12) (s "<superpiano superchip>")
--  >    $ s "superpiano superchip" # n 0
--
--  If you listen to this you’ll hear that which instrument is shifted up and which
--  instrument is shifted down alternates between cycles.
contrast ::
  (ControlPattern -> ControlPattern) ->
  (ControlPattern -> ControlPattern) ->
  ControlPattern ->
  ControlPattern ->
  ControlPattern
contrast :: (Pattern ValueMap -> Pattern ValueMap)
-> (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap
-> Pattern ValueMap
-> Pattern ValueMap
contrast = (Value -> Value -> Bool)
-> (Pattern ValueMap -> Pattern ValueMap)
-> (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap
-> Pattern ValueMap
-> Pattern ValueMap
forall a b.
(a -> Value -> Bool)
-> (Pattern ValueMap -> Pattern b)
-> (Pattern ValueMap -> Pattern b)
-> Pattern (Map [Char] a)
-> Pattern ValueMap
-> Pattern b
contrastBy Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
(==)

-- |
--  @contrastBy@ is contrastBy is the general version of 'contrast', in which you can specify an abritrary boolean function that will be used to compare the control patterns.
--
--  > d2 $ contrastBy (>=) (|+ n 12) (|- n 12) (n "2") $ n "0 1 2 [3 4]" # s "superpiano"
contrastBy ::
  (a -> Value -> Bool) ->
  (ControlPattern -> Pattern b) ->
  (ControlPattern -> Pattern b) ->
  Pattern (Map.Map String a) ->
  Pattern (Map.Map String Value) ->
  Pattern b
contrastBy :: forall a b.
(a -> Value -> Bool)
-> (Pattern ValueMap -> Pattern b)
-> (Pattern ValueMap -> Pattern b)
-> Pattern (Map [Char] a)
-> Pattern ValueMap
-> Pattern b
contrastBy a -> Value -> Bool
comp Pattern ValueMap -> Pattern b
f Pattern ValueMap -> Pattern b
f' Pattern (Map [Char] a)
p Pattern ValueMap
p' = Pattern b -> Pattern b -> Pattern b
forall a. Pattern a -> Pattern a -> Pattern a
overlay (Pattern ValueMap -> Pattern b
f Pattern ValueMap
matched) (Pattern ValueMap -> Pattern b
f' Pattern ValueMap
unmatched)
  where
    matches :: Pattern (Bool, ValueMap)
matches = (ValueMap -> Map [Char] a -> Bool)
-> Pattern (Map [Char] a)
-> Pattern ValueMap
-> Pattern (Bool, ValueMap)
forall b a.
(b -> a -> Bool) -> Pattern a -> Pattern b -> Pattern (Bool, b)
matchManyToOne ((Map [Char] a -> ValueMap -> Bool)
-> ValueMap -> Map [Char] a -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Map [Char] a -> ValueMap -> Bool)
 -> ValueMap -> Map [Char] a -> Bool)
-> (Map [Char] a -> ValueMap -> Bool)
-> ValueMap
-> Map [Char] a
-> Bool
forall a b. (a -> b) -> a -> b
$ (a -> Value -> Bool) -> Map [Char] a -> ValueMap -> Bool
forall k a b.
Ord k =>
(a -> b -> Bool) -> Map k a -> Map k b -> Bool
Map.isSubmapOfBy a -> Value -> Bool
comp) Pattern (Map [Char] a)
p Pattern ValueMap
p'
    matched :: ControlPattern
    matched :: Pattern ValueMap
matched = Pattern (Maybe ValueMap) -> Pattern ValueMap
forall a. Pattern (Maybe a) -> Pattern a
filterJust (Pattern (Maybe ValueMap) -> Pattern ValueMap)
-> Pattern (Maybe ValueMap) -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ (\(Bool
t, ValueMap
a) -> if Bool
t then ValueMap -> Maybe ValueMap
forall a. a -> Maybe a
Just ValueMap
a else Maybe ValueMap
forall a. Maybe a
Nothing) ((Bool, ValueMap) -> Maybe ValueMap)
-> Pattern (Bool, ValueMap) -> Pattern (Maybe ValueMap)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern (Bool, ValueMap)
matches
    unmatched :: ControlPattern
    unmatched :: Pattern ValueMap
unmatched = Pattern (Maybe ValueMap) -> Pattern ValueMap
forall a. Pattern (Maybe a) -> Pattern a
filterJust (Pattern (Maybe ValueMap) -> Pattern ValueMap)
-> Pattern (Maybe ValueMap) -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ (\(Bool
t, ValueMap
a) -> if Bool -> Bool
not Bool
t then ValueMap -> Maybe ValueMap
forall a. a -> Maybe a
Just ValueMap
a else Maybe ValueMap
forall a. Maybe a
Nothing) ((Bool, ValueMap) -> Maybe ValueMap)
-> Pattern (Bool, ValueMap) -> Pattern (Maybe ValueMap)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern (Bool, ValueMap)
matches

contrastRange ::
  (ControlPattern -> Pattern a) ->
  (ControlPattern -> Pattern a) ->
  Pattern (Map.Map String (Value, Value)) ->
  ControlPattern ->
  Pattern a
contrastRange :: forall a.
(Pattern ValueMap -> Pattern a)
-> (Pattern ValueMap -> Pattern a)
-> Pattern (Map [Char] (Value, Value))
-> Pattern ValueMap
-> Pattern a
contrastRange = ((Value, Value) -> Value -> Bool)
-> (Pattern ValueMap -> Pattern a)
-> (Pattern ValueMap -> Pattern a)
-> Pattern (Map [Char] (Value, Value))
-> Pattern ValueMap
-> Pattern a
forall a b.
(a -> Value -> Bool)
-> (Pattern ValueMap -> Pattern b)
-> (Pattern ValueMap -> Pattern b)
-> Pattern (Map [Char] a)
-> Pattern ValueMap
-> Pattern b
contrastBy (Value, Value) -> Value -> Bool
f
  where
    f :: (Value, Value) -> Value -> Bool
f (VI Int
s, VI Int
e) (VI Int
v) = Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
s Bool -> Bool -> Bool
&& Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
e
    f (VF Double
s, VF Double
e) (VF Double
v) = Double
v Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
s Bool -> Bool -> Bool
&& Double
v Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
e
    f (VN Note
s, VN Note
e) (VN Note
v) = Note
v Note -> Note -> Bool
forall a. Ord a => a -> a -> Bool
>= Note
s Bool -> Bool -> Bool
&& Note
v Note -> Note -> Bool
forall a. Ord a => a -> a -> Bool
<= Note
e
    f (VS [Char]
s, VS [Char]
e) (VS [Char]
v) = [Char]
v [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
s Bool -> Bool -> Bool
&& [Char]
v [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
e
    f (Value, Value)
_ Value
_ = Bool
False

-- |
--  The @fix@ function applies another function to matching events in a pattern of
--  controls. @fix@ is 'contrast' where the false-branching function is set to the
--  identity 'id'. It is like 'contrast', but one function is given and applied to
--  events with matching controls.
--
--  For example, the following only adds the 'crush' control when the @n@ control
--  is set to either 1 or 4:
--
--  > d1 $ slow 2
--  >    $ fix (# crush 3) (n "[1,4]")
--  >    $ n "0 1 2 3 4 5 6"
--  >    # sound "arpy"
--
--  You can be quite specific; for example, the following applies the function
--  @'hurry' 2@ to sample 1 of the drum sample set, and leaves the rest as they are:
--
--  > fix (hurry 2) (s "drum" # n "1")
fix :: (ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern -> ControlPattern
fix :: (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
fix Pattern ValueMap -> Pattern ValueMap
f = (Pattern ValueMap -> Pattern ValueMap)
-> (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap
-> Pattern ValueMap
-> Pattern ValueMap
contrast Pattern ValueMap -> Pattern ValueMap
f Pattern ValueMap -> Pattern ValueMap
forall a. a -> a
id

-- | Like 'contrast', but one function is given, and applied to events with
-- controls which don't match. @unfix@ is 'fix' but only applies when the
-- testing pattern is /not/ a match.
unfix :: (ControlPattern -> ControlPattern) -> ControlPattern -> ControlPattern -> ControlPattern
unfix :: (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
unfix = (Pattern ValueMap -> Pattern ValueMap)
-> (Pattern ValueMap -> Pattern ValueMap)
-> Pattern ValueMap
-> Pattern ValueMap
-> Pattern ValueMap
contrast Pattern ValueMap -> Pattern ValueMap
forall a. a -> a
id

-- |
--  The @fixRange@ function isn’t very user-friendly at the moment, but you can
--  create a @fix@ variant with a range condition. Any value of a 'ControlPattern'
--  wich matches the values will apply the passed function.
--
--  > d1 $ ( fixRange ( (# distort 1) . (# gain 0.8) )
--  >                 ( pure $ Map.singleton "note" ((VN 0, VN 7)) )
--  >      )
--  >    $ s "superpiano"
--  >   <| note "1 12 7 11"
fixRange ::
  (ControlPattern -> Pattern ValueMap) ->
  Pattern (Map.Map String (Value, Value)) ->
  ControlPattern ->
  ControlPattern
fixRange :: (Pattern ValueMap -> Pattern ValueMap)
-> Pattern (Map [Char] (Value, Value))
-> Pattern ValueMap
-> Pattern ValueMap
fixRange Pattern ValueMap -> Pattern ValueMap
f = (Pattern ValueMap -> Pattern ValueMap)
-> (Pattern ValueMap -> Pattern ValueMap)
-> Pattern (Map [Char] (Value, Value))
-> Pattern ValueMap
-> Pattern ValueMap
forall a.
(Pattern ValueMap -> Pattern a)
-> (Pattern ValueMap -> Pattern a)
-> Pattern (Map [Char] (Value, Value))
-> Pattern ValueMap
-> Pattern a
contrastRange Pattern ValueMap -> Pattern ValueMap
f Pattern ValueMap -> Pattern ValueMap
forall a. a -> a
id

unfixRange ::
  (ControlPattern -> Pattern ValueMap) ->
  Pattern (Map.Map String (Value, Value)) ->
  ControlPattern ->
  ControlPattern
unfixRange :: (Pattern ValueMap -> Pattern ValueMap)
-> Pattern (Map [Char] (Value, Value))
-> Pattern ValueMap
-> Pattern ValueMap
unfixRange = (Pattern ValueMap -> Pattern ValueMap)
-> (Pattern ValueMap -> Pattern ValueMap)
-> Pattern (Map [Char] (Value, Value))
-> Pattern ValueMap
-> Pattern ValueMap
forall a.
(Pattern ValueMap -> Pattern a)
-> (Pattern ValueMap -> Pattern a)
-> Pattern (Map [Char] (Value, Value))
-> Pattern ValueMap
-> Pattern a
contrastRange Pattern ValueMap -> Pattern ValueMap
forall a. a -> a
id

-- | @quantise@ limits values in a Pattern (or other Functor) to @n@ equally spaced
-- divisions of 1.
--
-- It is useful for rounding a collection of numbers to some particular base
-- fraction. For example,
--
-- > quantise 5 [0, 1.3 ,2.6,3.2,4.7,5]
--
-- It will round all the values to the nearest @(1/5)=0.2@ and thus will output
-- the list @[0.0,1.2,2.6,3.2,4.8,5.0]@. You can use this function to force a
-- continuous pattern like sine into specific values. In the following example:
--
-- > d1 $ s "superchip*8" # n (quantise 1 $ range (-10) (10) $ slow 8 $ cosine)
-- >                      # release (quantise 5 $ slow 8 $ sine + 0.1)
--
-- all the releases selected be rounded to the nearest @0.1@ and the notes selected
-- to the nearest @1@.
--
-- @quantise@ with fractional inputs does the consistent thing: @quantise 0.5@
-- rounds values to the nearest @2@, @quantise 0.25@ rounds the nearest @4@, etc.
quantise :: (Functor f, RealFrac b) => b -> f b -> f b
quantise :: forall (f :: * -> *) b. (Functor f, RealFrac b) => b -> f b -> f b
quantise b
n = (b -> b) -> f b -> f b
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b -> b -> b
forall a. Fractional a => a -> a -> a
/ b
n) (b -> b) -> (b -> b) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> b
forall {b}. RealFrac b => Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: (RealFrac b) => Int -> b) (Int -> b) -> (b -> Int) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Int
forall b. Integral b => b -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (b -> Int) -> (b -> b) -> b -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> b -> b
forall a. Num a => a -> a -> a
* b
n))

-- | As 'quantise', but uses 'Prelude.floor' to calculate divisions.
qfloor :: (Functor f, RealFrac b) => b -> f b -> f b
qfloor :: forall (f :: * -> *) b. (Functor f, RealFrac b) => b -> f b -> f b
qfloor b
n = (b -> b) -> f b -> f b
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b -> b -> b
forall a. Fractional a => a -> a -> a
/ b
n) (b -> b) -> (b -> b) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> b
forall {b}. RealFrac b => Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: (RealFrac b) => Int -> b) (Int -> b) -> (b -> Int) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Int
forall b. Integral b => b -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (b -> Int) -> (b -> b) -> b -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> b -> b
forall a. Num a => a -> a -> a
* b
n))

-- | As 'quantise', but uses 'Prelude.ceiling' to calculate divisions.
qceiling :: (Functor f, RealFrac b) => b -> f b -> f b
qceiling :: forall (f :: * -> *) b. (Functor f, RealFrac b) => b -> f b -> f b
qceiling b
n = (b -> b) -> f b -> f b
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b -> b -> b
forall a. Fractional a => a -> a -> a
/ b
n) (b -> b) -> (b -> b) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> b
forall {b}. RealFrac b => Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: (RealFrac b) => Int -> b) (Int -> b) -> (b -> Int) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Int
forall b. Integral b => b -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (b -> Int) -> (b -> b) -> b -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> b -> b
forall a. Num a => a -> a -> a
* b
n))

-- | An alias for 'quantise'.
qround :: (Functor f, RealFrac b) => b -> f b -> f b
qround :: forall (f :: * -> *) b. (Functor f, RealFrac b) => b -> f b -> f b
qround = b -> f b -> f b
forall (f :: * -> *) b. (Functor f, RealFrac b) => b -> f b -> f b
quantise

-- | Inverts all the values in a boolean pattern
inv :: (Functor f) => f Bool -> f Bool
inv :: forall (f :: * -> *). Functor f => f Bool -> f Bool
inv = (Bool -> Bool
not (Bool -> Bool) -> f Bool -> f Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)

-- |
-- @smooth@ receives a pattern of numbers and linearly goes from one to the next, passing through all of them. As time is cycle-based, after reaching the last number in the pattern, it will smoothly go to the first one again.
--
-- > d1 $ sound "bd*4" # pan (slow 4 $ smooth "0 1 0.5 1")
--
-- This sound will pan gradually from left to right, then to the center, then to the right again, and finally comes back to the left.

-- serialize the given pattern
-- find the middle of the query's arc and use that to query the serialized pattern. We should get either no events or a single event back
-- if we don't get any events, return nothing
-- if we get an event, get the stop of its arc, and use that to query the serialized pattern, to see if there's an adjoining event
-- if there isn't, return the event as-is.
-- if there is, check where we are in the 'whole' of the event, and use that to tween between the values of the event and the next event
-- smooth :: Pattern Double -> Pattern Double

-- TODO - test this with analog events
smooth :: (Fractional a) => Pattern a -> Pattern a
smooth :: forall a. Fractional a => Pattern a -> Pattern a
smooth Pattern a
p = (State -> [Event a]) -> Pattern a
forall a. (State -> [Event a]) -> Pattern a
pattern ((State -> [Event a]) -> Pattern a)
-> (State -> [Event a]) -> Pattern a
forall a b. (a -> b) -> a -> b
$ \st :: State
st@(State Arc
a ValueMap
cm) -> State -> Arc -> [Event a] -> [Event a]
forall {a}. State -> a -> [Event a] -> [EventF a a]
tween State
st Arc
a ([Event a] -> [Event a]) -> [Event a] -> [Event a]
forall a b. (a -> b) -> a -> b
$ Pattern a -> State -> [Event a]
forall a. Pattern a -> State -> [Event a]
query Pattern a
monoP (Arc -> ValueMap -> State
State (Arc -> Arc
forall {a}. Fractional a => ArcF a -> ArcF a
midArc Arc
a) ValueMap
cm)
  where
    midArc :: ArcF a -> ArcF a
midArc ArcF a
a = a -> a -> ArcF a
forall a. a -> a -> ArcF a
Arc ((a, a) -> a
forall a. Fractional a => (a, a) -> a
mid (ArcF a -> a
forall a. ArcF a -> a
start ArcF a
a, ArcF a -> a
forall a. ArcF a -> a
stop ArcF a
a)) ((a, a) -> a
forall a. Fractional a => (a, a) -> a
mid (ArcF a -> a
forall a. ArcF a -> a
start ArcF a
a, ArcF a -> a
forall a. ArcF a -> a
stop ArcF a
a))
    tween :: State -> a -> [Event a] -> [EventF a a]
tween State
_ a
_ [] = []
    tween State
st a
queryA (Event a
e : [Event a]
_) = [EventF a a] -> (a -> [EventF a a]) -> Maybe a -> [EventF a a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Event a
e {whole = Just queryA, part = queryA}] (a -> a -> [EventF a a]
forall {a}. a -> a -> [EventF a a]
tween' a
queryA) (State -> Maybe a
nextV State
st)
      where
        aStop :: Arc
aStop = Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc (Event a -> Time
forall a. Event a -> Time
wholeStop Event a
e) (Event a -> Time
forall a. Event a -> Time
wholeStop Event a
e)
        nextEs :: State -> [Event a]
nextEs State
st' = Pattern a -> State -> [Event a]
forall a. Pattern a -> State -> [Event a]
query Pattern a
monoP (State
st' {arc = aStop})
        nextV :: State -> Maybe a
nextV State
st'
          | [Event a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (State -> [Event a]
nextEs State
st') = Maybe a
forall a. Maybe a
Nothing
          | Bool
otherwise = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ Event a -> a
forall a b. EventF a b -> b
value ([Event a] -> Event a
forall a. HasCallStack => [a] -> a
head (State -> [Event a]
nextEs State
st'))
        tween' :: a -> a -> [EventF a a]
tween' a
queryA' a
v =
          [ Event
              { context :: Context
context = Event a -> Context
forall a b. EventF a b -> Context
context Event a
e,
                whole :: Maybe a
whole = a -> Maybe a
forall a. a -> Maybe a
Just a
queryA',
                part :: a
part = a
queryA',
                value :: a
value = Event a -> a
forall a b. EventF a b -> b
value Event a
e a -> a -> a
forall a. Num a => a -> a -> a
+ ((a
v a -> a -> a
forall a. Num a => a -> a -> a
- Event a -> a
forall a b. EventF a b -> b
value Event a
e) a -> a -> a
forall a. Num a => a -> a -> a
* a
pc)
              }
          ]
        pc :: a
pc
          | Arc -> Time
forall {a}. Num a => ArcF a -> a
delta' (Event a -> Arc
forall a. Event a -> Arc
wholeOrPart Event a
e) Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
0 = a
0
          | Bool
otherwise = Time -> a
forall a. Fractional a => Time -> a
fromRational (Time -> a) -> Time -> a
forall a b. (a -> b) -> a -> b
$ (Event a -> Time
forall a. Event a -> Time
eventPartStart Event a
e Time -> Time -> Time
forall a. Num a => a -> a -> a
- Event a -> Time
forall a. Event a -> Time
wholeStart Event a
e) Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Arc -> Time
forall {a}. Num a => ArcF a -> a
delta' (Event a -> Arc
forall a. Event a -> Arc
wholeOrPart Event a
e)
        delta' :: ArcF a -> a
delta' ArcF a
a = ArcF a -> a
forall a. ArcF a -> a
stop ArcF a
a a -> a -> a
forall a. Num a => a -> a -> a
- ArcF a -> a
forall a. ArcF a -> a
start ArcF a
a
    monoP :: Pattern a
monoP = Pattern a -> Pattern a
forall a. Pattern a -> Pattern a
mono Pattern a
p

-- | Looks up values from a list of tuples, in order to swap values in the given pattern
swap :: (Eq a) => [(a, b)] -> Pattern a -> Pattern b
swap :: forall a b. Eq a => [(a, b)] -> Pattern a -> Pattern b
swap [(a, b)]
things Pattern a
p = Pattern (Maybe b) -> Pattern b
forall a. Pattern (Maybe a) -> Pattern a
filterJust (Pattern (Maybe b) -> Pattern b) -> Pattern (Maybe b) -> Pattern b
forall a b. (a -> b) -> a -> b
$ (a -> [(a, b)] -> Maybe b
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(a, b)]
things) (a -> Maybe b) -> Pattern a -> Pattern (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a
p

-- |
--  @snowball@ takes a function that can combine patterns (like '+'),
--  a function that transforms a pattern (like 'slow'),
--  a depth, and a starting pattern,
--  it will then transform the pattern and combine it with the last transformation until the depth is reached.
--  This is like putting an effect (like a filter) in the feedback of a delay line; each echo is more affected.
--
--  > d1 $ note ( scale "hexDorian"
--  >           $ snowball 8 (+) (slow 2 . rev) "0 ~ . -1 . 5 3 4 . ~ -2"
--  >           )
--  >    # s "gtr"
snowball :: Int -> (Pattern a -> Pattern a -> Pattern a) -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
snowball :: forall a.
Int
-> (Pattern a -> Pattern a -> Pattern a)
-> (Pattern a -> Pattern a)
-> Pattern a
-> Pattern a
snowball Int
depth Pattern a -> Pattern a -> Pattern a
combinationFunction Pattern a -> Pattern a
f Pattern a
pat = [Pattern a] -> Pattern a
forall a. [Pattern a] -> Pattern a
cat ([Pattern a] -> Pattern a) -> [Pattern a] -> Pattern a
forall a b. (a -> b) -> a -> b
$ Int -> [Pattern a] -> [Pattern a]
forall a. Int -> [a] -> [a]
take Int
depth ([Pattern a] -> [Pattern a]) -> [Pattern a] -> [Pattern a]
forall a b. (a -> b) -> a -> b
$ (Pattern a -> Pattern a -> Pattern a)
-> Pattern a -> [Pattern a] -> [Pattern a]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Pattern a -> Pattern a -> Pattern a
combinationFunction Pattern a
pat ([Pattern a] -> [Pattern a]) -> [Pattern a] -> [Pattern a]
forall a b. (a -> b) -> a -> b
$ Int -> [Pattern a] -> [Pattern a]
forall a. Int -> [a] -> [a]
drop Int
1 ([Pattern a] -> [Pattern a]) -> [Pattern a] -> [Pattern a]
forall a b. (a -> b) -> a -> b
$ (Pattern a -> Pattern a) -> Pattern a -> [Pattern a]
forall a. (a -> a) -> a -> [a]
iterate Pattern a -> Pattern a
f Pattern a
pat

-- |
--  Applies a function to a pattern and cats the resulting pattern, then continues
--  applying the function until the depth is reached this can be used to create
--  a pattern that wanders away from the original pattern by continually adding
--  random numbers.
--
--  > d1 $ note ( scale "hexDorian" mutateBy (+ (range -1 1 $ irand 2)) 8
--  >           $ "0 1 . 2 3 4"
--  >           )
--  >    # s "gtr"
soak :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
soak :: forall a. Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
soak Int
depth Pattern a -> Pattern a
f Pattern a
pat = [Pattern a] -> Pattern a
forall a. [Pattern a] -> Pattern a
cat ([Pattern a] -> Pattern a) -> [Pattern a] -> Pattern a
forall a b. (a -> b) -> a -> b
$ Int -> [Pattern a] -> [Pattern a]
forall a. Int -> [a] -> [a]
take Int
depth ([Pattern a] -> [Pattern a]) -> [Pattern a] -> [Pattern a]
forall a b. (a -> b) -> a -> b
$ (Pattern a -> Pattern a) -> Pattern a -> [Pattern a]
forall a. (a -> a) -> a -> [a]
iterate Pattern a -> Pattern a
f Pattern a
pat

-- | @construct n p@ breaks @p@ into pieces and then reassembles them
-- so that it fits into @n@ steps.
deconstruct :: Int -> Pattern String -> String
deconstruct :: Int -> Pattern [Char] -> [Char]
deconstruct Int
n Pattern [Char]
p = [[Char]] -> [Char]
unwords ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ ([[Char]] -> [Char]) -> [[[Char]]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [[Char]] -> [Char]
showStep ([[[Char]]] -> [[Char]]) -> [[[Char]]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ Pattern [Char] -> [[[Char]]]
forall a. Pattern a -> [[a]]
toList Pattern [Char]
p
  where
    showStep :: [String] -> String
    showStep :: [[Char]] -> [Char]
showStep [] = [Char]
"~"
    showStep [[Char]
x] = [Char]
x
    showStep [[Char]]
xs = [Char]
"[" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " [[Char]]
xs) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"]"
    toList :: Pattern a -> [[a]]
    toList :: forall a. Pattern a -> [[a]]
toList Pattern a
pat = ((Time, Time) -> [a]) -> [(Time, Time)] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (\(Time
s, Time
e) -> (EventF Arc a -> a) -> [EventF Arc a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map EventF Arc a -> a
forall a b. EventF a b -> b
value ([EventF Arc a] -> [a]) -> [EventF Arc a] -> [a]
forall a b. (a -> b) -> a -> b
$ Pattern a -> Arc -> [EventF Arc a]
forall a. Pattern a -> Arc -> [Event a]
queryArc (Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
_segment Time
n' Pattern a
pat) (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc Time
s Time
e)) [(Time, Time)]
arcs
      where
        breaks :: [Time]
breaks = [Time
0, (Time
1 Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Time
n') ..]
        arcs :: [(Time, Time)]
arcs = [Time] -> [Time] -> [(Time, Time)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int -> [Time] -> [Time]
forall a. Int -> [a] -> [a]
take Int
n [Time]
breaks) (Int -> [Time] -> [Time]
forall a. Int -> [a] -> [a]
drop Int
1 [Time]
breaks)
        n' :: Time
n' = Int -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n

-- | @bite n ipat pat@ slices a pattern @pat@ into @n@ pieces, then uses the
--  @ipat@ pattern of integers to index into those slices. So @bite 4 "0 2*2" (run
--  8)@ is the same as @"[0 1] [4 5]*2"@.
--
--  I.e., it allows you to slice each cycle into a given number of equal sized
--  bits, and then pattern those bits by number. It’s similar to @slice@, but is
--  for slicing up patterns, rather than samples. The following slices the pattern
--  into four bits, and then plays those bits in turn:
--
--  > d1 $ bite 4 "0 1 2 3" $ n "0 .. 7" # sound "arpy"
--
--  Of course that doesn’t actually change anything, but then you can reorder those bits:
--
--  > d1 $ bite 4 "2 0 1 3" $ n "0 .. 7" # sound "arpy"
--
--  The slices bits of pattern will be squeezed or contracted to fit:
--
--  > d1 $ bite 4 "2 [0 3] 1*4 1" $ n "0 .. 7" # sound "arpy"
bite :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a
bite :: forall a. Pattern Int -> Pattern Int -> Pattern a -> Pattern a
bite Pattern Int
npat Pattern Int
ipat Pattern a
pat = Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
innerJoin (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ (\Int
n -> Int -> Pattern Int -> Pattern a -> Pattern a
forall a. Int -> Pattern Int -> Pattern a -> Pattern a
_bite Int
n Pattern Int
ipat Pattern a
pat) (Int -> Pattern a) -> Pattern Int -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Int
npat

_bite :: Int -> Pattern Int -> Pattern a -> Pattern a
_bite :: forall a. Int -> Pattern Int -> Pattern a -> Pattern a
_bite Int
n Pattern Int
ipat Pattern a
pat = Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
squeezeJoin (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ Int -> Pattern a
zoomslice (Int -> Pattern a) -> Pattern Int -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Int
ipat
  where
    zoomslice :: Int -> Pattern a
zoomslice Int
i = (Time, Time) -> Pattern a -> Pattern a
forall a. (Time, Time) -> Pattern a -> Pattern a
zoom (Time
i' Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Int -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n, (Time
i' Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
1) Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Int -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) Pattern a
pat
      where
        i' :: Time
i' = Int -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Time) -> Int -> Time
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
n

-- | Chooses from a list of patterns, using a pattern of integers.
squeeze :: Pattern Int -> [Pattern a] -> Pattern a
squeeze :: forall a. Pattern Int -> [Pattern a] -> Pattern a
squeeze Pattern Int
_ [] = Pattern a
forall a. Pattern a
silence
squeeze Pattern Int
ipat [Pattern a]
pats = Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
squeezeJoin (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ ([Pattern a]
pats [Pattern a] -> Int -> Pattern a
forall a. [a] -> Int -> a
!!!) (Int -> Pattern a) -> Pattern Int -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Int
ipat

squeezeJoinUp :: Pattern ControlPattern -> ControlPattern
squeezeJoinUp :: Pattern (Pattern ValueMap) -> Pattern ValueMap
squeezeJoinUp Pattern (Pattern ValueMap)
pp = Pattern (Pattern ValueMap)
pp {query = q, pureValue = Nothing}
  where
    q :: State -> [EventF Arc ValueMap]
q State
st = (EventF Arc (Pattern ValueMap) -> [EventF Arc ValueMap])
-> [EventF Arc (Pattern ValueMap)] -> [EventF Arc ValueMap]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (State -> EventF Arc (Pattern ValueMap) -> [EventF Arc ValueMap]
f State
st) (Pattern (Pattern ValueMap)
-> State -> [EventF Arc (Pattern ValueMap)]
forall a. Pattern a -> State -> [Event a]
query (Pattern (Pattern ValueMap) -> Pattern (Pattern ValueMap)
forall a. Pattern a -> Pattern a
filterDigital Pattern (Pattern ValueMap)
pp) State
st)
    f :: State -> EventF Arc (Pattern ValueMap) -> [EventF Arc ValueMap]
f State
st (Event Context
c (Just Arc
w) Arc
p Pattern ValueMap
v) =
      (EventF Arc ValueMap -> Maybe (EventF Arc ValueMap))
-> [EventF Arc ValueMap] -> [EventF Arc ValueMap]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Context
-> Arc -> Arc -> EventF Arc ValueMap -> Maybe (EventF Arc ValueMap)
forall {b}.
Context -> Arc -> Arc -> EventF Arc b -> Maybe (EventF Arc b)
munge Context
c Arc
w Arc
p) ([EventF Arc ValueMap] -> [EventF Arc ValueMap])
-> [EventF Arc ValueMap] -> [EventF Arc ValueMap]
forall a b. (a -> b) -> a -> b
$ Pattern ValueMap -> State -> [EventF Arc ValueMap]
forall a. Pattern a -> State -> [Event a]
query (Arc -> Pattern ValueMap -> Pattern ValueMap
forall a. Arc -> Pattern a -> Pattern a
compressArc (Arc -> Arc
cycleArc Arc
w) (Pattern ValueMap
v Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall a. Num a => Pattern a -> Pattern a -> Pattern a
|* Pattern Double -> Pattern ValueMap
P.speed (Double -> Pattern Double
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> Pattern Double) -> Double -> Pattern Double
forall a b. (a -> b) -> a -> b
$ Time -> Double
forall a. Fractional a => Time -> a
fromRational (Time -> Double) -> Time -> Double
forall a b. (a -> b) -> a -> b
$ Time
1 Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ (Arc -> Time
forall a. ArcF a -> a
stop Arc
w Time -> Time -> Time
forall a. Num a => a -> a -> a
- Arc -> Time
forall a. ArcF a -> a
start Arc
w)))) State
st {arc = p}
    -- already ignoring analog events, but for completeness..
    f State
_ EventF Arc (Pattern ValueMap)
_ = []
    munge :: Context -> Arc -> Arc -> EventF Arc b -> Maybe (EventF Arc b)
munge Context
co Arc
oWhole Arc
oPart (Event Context
ci (Just Arc
iWhole) Arc
iPart b
v) =
      do
        Arc
w' <- Arc -> Arc -> Maybe Arc
subArc Arc
oWhole Arc
iWhole
        Arc
p' <- Arc -> Arc -> Maybe Arc
subArc Arc
oPart Arc
iPart
        EventF Arc b -> Maybe (EventF Arc b)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> Maybe Arc -> Arc -> b -> EventF Arc b
forall a b. Context -> Maybe a -> a -> b -> EventF a b
Event ([Context] -> Context
combineContexts [Context
ci, Context
co]) (Arc -> Maybe Arc
forall a. a -> Maybe a
Just Arc
w') Arc
p' b
v)
    munge Context
_ Arc
_ Arc
_ EventF Arc b
_ = Maybe (EventF Arc b)
forall a. Maybe a
Nothing

_chew :: Int -> Pattern Int -> ControlPattern -> ControlPattern
_chew :: Int -> Pattern Int -> Pattern ValueMap -> Pattern ValueMap
_chew Int
n Pattern Int
ipat Pattern ValueMap
pat = Pattern (Pattern ValueMap) -> Pattern ValueMap
squeezeJoinUp (Int -> Pattern ValueMap
zoomslice (Int -> Pattern ValueMap)
-> Pattern Int -> Pattern (Pattern ValueMap)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Int
ipat) Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall a. Fractional a => Pattern a -> Pattern a -> Pattern a
|/ Pattern Double -> Pattern ValueMap
P.speed (Double -> Pattern Double
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> Pattern Double) -> Double -> Pattern Double
forall a b. (a -> b) -> a -> b
$ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
  where
    zoomslice :: Int -> Pattern ValueMap
zoomslice Int
i = (Time, Time) -> Pattern ValueMap -> Pattern ValueMap
forall a. (Time, Time) -> Pattern a -> Pattern a
zoom (Time
i' Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ (Int -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n), (Time
i' Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
1) Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ (Int -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)) (Pattern ValueMap
pat)
      where
        i' :: Time
i' = Int -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Time) -> Int -> Time
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
n

-- |
--  @chew@ works the same as 'bite', but speeds up\/slows down playback of sounds as
--  well as squeezing\/contracting the slices of the provided pattern. Compare:
--
--  > d1 $ 'bite' 4 "0 1*2 2*2 [~ 3]" $ n "0 .. 7" # sound "drum"
--  > d1 $ chew 4 "0 1*2 2*2 [~ 3]" $ n "0 .. 7" # sound "drum"

-- TODO maybe _chew could pattern the first parameter directly..
chew :: Pattern Int -> Pattern Int -> ControlPattern -> ControlPattern
chew :: Pattern Int -> Pattern Int -> Pattern ValueMap -> Pattern ValueMap
chew Pattern Int
npat Pattern Int
ipat Pattern ValueMap
pat = Pattern (Pattern ValueMap) -> Pattern ValueMap
forall a. Pattern (Pattern a) -> Pattern a
innerJoin (Pattern (Pattern ValueMap) -> Pattern ValueMap)
-> Pattern (Pattern ValueMap) -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ (\Int
n -> Int -> Pattern Int -> Pattern ValueMap -> Pattern ValueMap
_chew Int
n Pattern Int
ipat Pattern ValueMap
pat) (Int -> Pattern ValueMap)
-> Pattern Int -> Pattern (Pattern ValueMap)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Int
npat

__binary :: (Data.Bits.Bits b) => Int -> b -> [Bool]
__binary :: forall b. Bits b => Int -> b -> [Bool]
__binary Int
n b
num = (Int -> Bool) -> [Int] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (b -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit b
num) ([Int] -> [Bool]) -> [Int] -> [Bool]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]

_binary :: (Data.Bits.Bits b) => Int -> b -> Pattern Bool
_binary :: forall b. Bits b => Int -> b -> Pattern Bool
_binary Int
n b
num = [Bool] -> Pattern Bool
forall a. [a] -> Pattern a
listToPat ([Bool] -> Pattern Bool) -> [Bool] -> Pattern Bool
forall a b. (a -> b) -> a -> b
$ Int -> b -> [Bool]
forall b. Bits b => Int -> b -> [Bool]
__binary Int
n b
num

_binaryN :: Int -> Pattern Int -> Pattern Bool
_binaryN :: Int -> Pattern Int -> Pattern Bool
_binaryN Int
n Pattern Int
p = Maybe (Pattern Time) -> Pattern Bool -> Pattern Bool
forall a. Maybe (Pattern Time) -> Pattern a -> Pattern a
setTactus (Pattern Time -> Maybe (Pattern Time)
forall a. a -> Maybe a
Just (Pattern Time -> Maybe (Pattern Time))
-> Pattern Time -> Maybe (Pattern Time)
forall a b. (a -> b) -> a -> b
$ Time -> Pattern Time
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Time -> Pattern Time) -> Time -> Pattern Time
forall a b. (a -> b) -> a -> b
$ Int -> Time
forall a. Real a => a -> Time
toRational Int
n) (Pattern Bool -> Pattern Bool) -> Pattern Bool -> Pattern Bool
forall a b. (a -> b) -> a -> b
$ Pattern (Pattern Bool) -> Pattern Bool
forall a. Pattern (Pattern a) -> Pattern a
squeezeJoin (Pattern (Pattern Bool) -> Pattern Bool)
-> Pattern (Pattern Bool) -> Pattern Bool
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Pattern Bool
forall b. Bits b => Int -> b -> Pattern Bool
_binary Int
n (Int -> Pattern Bool) -> Pattern Int -> Pattern (Pattern Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Int
p

binaryN :: Pattern Int -> Pattern Int -> Pattern Bool
binaryN :: Pattern Int -> Pattern Int -> Pattern Bool
binaryN Pattern Int
n Pattern Int
p = (Int -> Pattern Int -> Pattern Bool)
-> Pattern Int -> Pattern Int -> Pattern Bool
forall t1 t2 a.
(t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a
patternify Int -> Pattern Int -> Pattern Bool
_binaryN Pattern Int
n Pattern Int
p

binary :: Pattern Int -> Pattern Bool
binary :: Pattern Int -> Pattern Bool
binary = Pattern Int -> Pattern Int -> Pattern Bool
binaryN Pattern Int
8

ascii :: Pattern String -> Pattern Bool
ascii :: Pattern [Char] -> Pattern Bool
ascii Pattern [Char]
p = Pattern (Pattern Bool) -> Pattern Bool
forall a. Pattern (Pattern a) -> Pattern a
squeezeJoin (Pattern (Pattern Bool) -> Pattern Bool)
-> Pattern (Pattern Bool) -> Pattern Bool
forall a b. (a -> b) -> a -> b
$ [Bool] -> Pattern Bool
forall a. [a] -> Pattern a
listToPat ([Bool] -> Pattern Bool)
-> ([Char] -> [Bool]) -> [Char] -> Pattern Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> [Bool]) -> [Char] -> [Bool]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> Int -> [Bool]
forall b. Bits b => Int -> b -> [Bool]
__binary Int
8 (Int -> [Bool]) -> (Char -> Int) -> Char -> [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) ([Char] -> Pattern Bool)
-> Pattern [Char] -> Pattern (Pattern Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern [Char]
p

-- | Given a start point and a duration (both specified in cycles), this
--  generates a control pattern that makes a sound begin at the start
--  point and last the duration.
--
--  The following are equivalent:
--
--  > d1 $ slow 2 $ s "bev" # grain 0.2 0.1 # legato 1
--  > d1 $ slow 2 $ s "bev" # begin 0.2 # end 0.3 # legato 1
--
--  @grain@ is defined as:
--
--  > grain s d = 'Sound.Tidal.Params.begin' s # 'Sound.Tidal.Params.end' (s+d)
grain :: Pattern Double -> Pattern Double -> ControlPattern
grain :: Pattern Double -> Pattern Double -> Pattern ValueMap
grain Pattern Double
s Pattern Double
w = Pattern Double -> Pattern ValueMap
P.begin Pattern Double
b Pattern ValueMap -> Pattern ValueMap -> Pattern ValueMap
forall b. Unionable b => Pattern b -> Pattern b -> Pattern b
# Pattern Double -> Pattern ValueMap
P.end Pattern Double
e
  where
    b :: Pattern Double
b = Pattern Double
s
    e :: Pattern Double
e = Pattern Double
s Pattern Double -> Pattern Double -> Pattern Double
forall a. Num a => a -> a -> a
+ Pattern Double
w

-- | For specifying a boolean pattern according to a list of offsets
-- (aka inter-onset intervals). For example @necklace 12 [4,2]@ is
-- the same as "t f f f t f t f f f t f". That is, 12 steps per cycle,
-- with true values alternating between every 4 and every 2 steps.
necklace :: Rational -> [Int] -> Pattern Bool
necklace :: Time -> [Int] -> Pattern Bool
necklace Time
perCycle [Int]
xs = Time -> Pattern Bool -> Pattern Bool
forall a. Time -> Pattern a -> Pattern a
_slow ((Int -> Time
forall a. Real a => a -> Time
toRational (Int -> Time) -> Int -> Time
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
xs) Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/ Time
perCycle) (Pattern Bool -> Pattern Bool) -> Pattern Bool -> Pattern Bool
forall a b. (a -> b) -> a -> b
$ [Bool] -> Pattern Bool
forall a. [a] -> Pattern a
listToPat ([Bool] -> Pattern Bool) -> [Bool] -> Pattern Bool
forall a b. (a -> b) -> a -> b
$ [Int] -> [Bool]
list [Int]
xs
  where
    list :: [Int] -> [Bool]
    list :: [Int] -> [Bool]
list [] = []
    list (Int
x : [Int]
xs') = (Bool
True Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: (Int -> Bool -> [Bool]
forall a. Int -> a -> [a]
replicate (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Bool
False)) [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ [Int] -> [Bool]
list [Int]
xs'

-- | Inserts chromatic notes into a pattern.
--
-- The first argument indicates the (patternable) number of notes to insert,
-- and the second argument is the base pattern of "anchor notes" that gets transformed.
--
-- The following are equivalent:
--
-- > d1 $ up (chromaticiseBy "0 1 2 -1" "[0 2] [3 6] [5 6 8] [3 1 0]") # s "superpiano"
-- > d1 $ up "[0 2] [[3 4] [6 7]] [[5 6 7] [6 7 8] [8 9 10] [[3 2] [1 0] [0 -1]]" # s "superpiano"
chromaticiseBy :: (Num a, Enum a, Ord a) => Pattern a -> Pattern a -> Pattern a
chromaticiseBy :: forall a.
(Num a, Enum a, Ord a) =>
Pattern a -> Pattern a -> Pattern a
chromaticiseBy Pattern a
n Pattern a
pat = Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
innerJoin (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$ (\a
np -> a -> Pattern a -> Pattern a
forall a. (Num a, Enum a, Ord a) => a -> Pattern a -> Pattern a
_chromaticiseBy a
np Pattern a
pat) (a -> Pattern a) -> Pattern a -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a
n

_chromaticiseBy :: (Num a, Enum a, Ord a) => a -> Pattern a -> Pattern a
_chromaticiseBy :: forall a. (Num a, Enum a, Ord a) => a -> Pattern a -> Pattern a
_chromaticiseBy a
n Pattern a
pat =
  Pattern (Pattern a) -> Pattern a
forall a. Pattern (Pattern a) -> Pattern a
squeezeJoin (Pattern (Pattern a) -> Pattern a)
-> Pattern (Pattern a) -> Pattern a
forall a b. (a -> b) -> a -> b
$
    ( \a
val ->
        [Pattern a] -> Pattern a
forall a. [Pattern a] -> Pattern a
fastcat ([Pattern a] -> Pattern a) -> [Pattern a] -> Pattern a
forall a b. (a -> b) -> a -> b
$
          (a -> Pattern a) -> [a] -> [Pattern a]
forall a b. (a -> b) -> [a] -> [b]
map
            a -> Pattern a
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            ( if a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0
                then [a
val .. (a
val a -> a -> a
forall a. Num a => a -> a -> a
+ a
n)]
                else [a] -> [a]
forall a. [a] -> [a]
reverse [(a
val a -> a -> a
forall a. Num a => a -> a -> a
+ a
n) .. a
val]
            )
    )
      (a -> Pattern a) -> Pattern a -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern a
pat

-- | Alias for chromaticiseBy
chromaticizeBy :: (Num a, Enum a, Ord a) => Pattern a -> Pattern a -> Pattern a
chromaticizeBy :: forall a.
(Num a, Enum a, Ord a) =>
Pattern a -> Pattern a -> Pattern a
chromaticizeBy = Pattern a -> Pattern a -> Pattern a
forall a.
(Num a, Enum a, Ord a) =>
Pattern a -> Pattern a -> Pattern a
chromaticiseBy