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

module Sound.Tidal.UI where

{-
    UI.hs - Tidal's main 'user interface' functions, for transforming
    patterns, building on the Core ones.
    Copyright (C) 2020, 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/>.
-}

import           Prelude hiding ((<*), (*>))

import           Data.Char (digitToInt, isDigit, ord)
import           Data.Bits (testBit, Bits, xor, shiftL, shiftR)
import           Data.Fixed (mod')
import           Data.Ratio ((%))
import           Data.List (sort, sortOn, findIndices, elemIndex, groupBy, transpose, intercalate, findIndex)
import           Data.Maybe (isJust, fromJust, fromMaybe, mapMaybe)
import qualified Data.Text as T
import qualified Data.Map.Strict as Map
import           Data.Bool (bool)

import           Sound.Tidal.Bjorklund (bjorklund)
import           Sound.Tidal.Core
import qualified Sound.Tidal.Params as P
import           Sound.Tidal.Pattern
import           Sound.Tidal.Utils

------------------------------------------------------------------------
-- * UI

-- | Randomisation

-- cf. George Marsaglia (2003). "Xorshift RNGs". Journal of Statistical Software 8:14.
-- https://www.jstatsoft.org/article/view/v008i14
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 :: 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 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
. (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 :: 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 :: 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 :: a -> Int -> [b]
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' :: 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
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1))

{-|

`rand` generates a continuous pattern of (pseudo-)random numbers between `0` and `1`.

@
sound "bd*8" # pan rand
@

pans bass drums randomly

@
sound "sn sn ~ sn" # gain rand
@

makes the snares' randomly loud and quiet.

Numbers coming from this pattern are 'seeded' by time. So if you reset
time (via `cps (-1)`, then `cps 1.1` or whatever cps you want to
restart with) 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 :: 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 is 25% chance of being true.
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
prob -> Double -> Pattern Bool
_brandBy Double
prob) (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 (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 :: Pattern Int -> Pattern a
irand = (Pattern Int -> (Int -> Pattern a) -> Pattern a
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 :: 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 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 RNG'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 :: Pattern Double -> Pattern Double
perlinWith :: Pattern Double -> Pattern Double
perlinWith Pattern Double
p = 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
pPattern 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 (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 (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 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 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
ba -> 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
xa -> 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
xa -> 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
xa -> a -> a
forall a. Floating a => a -> a -> a
**a
3

perlin :: Pattern Double
perlin :: Pattern Double
perlin = Pattern Double -> Pattern Double
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
@
will generate a smooth random cutoff pattern that repeats every cycle without
any reversals or discontinuities (because the 2D path is a circle).
`perlin2` 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 (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 (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 (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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern Double
dotc Pattern (Double -> Double) -> Pattern Double -> Pattern Double
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 (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 a b. (RealFrac a, Integral b) => a -> b
floor)
  ce :: Pattern Double -> Pattern Double
ce = (Double -> Double) -> Pattern Double -> Pattern Double
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 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 (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 (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

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)

{- | 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\".
-}
choose :: [a] -> Pattern a
choose :: [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

chooseBy :: Pattern Double -> [a] -> Pattern a
chooseBy :: 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 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 (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 :: [(a,Double)] -> Pattern a
wchoose :: [(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

wchooseBy :: Pattern Double -> [(a,Double)] -> Pattern a
wchooseBy :: 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. [a] -> Int -> a
!! [Int] -> Int
forall a. [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
rDouble -> 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 (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

{- |
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"
@

-}
degradeBy :: Pattern Double -> Pattern a -> Pattern a
degradeBy :: Pattern Double -> Pattern a -> Pattern a
degradeBy = (Double -> Pattern a -> Pattern a)
-> Pattern Double -> Pattern a -> Pattern a
forall t1 t2 a.
(t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a
tParam Double -> Pattern a -> Pattern a
forall a. Double -> Pattern a -> Pattern a
_degradeBy

_degradeBy :: Double -> Pattern a -> Pattern a
_degradeBy :: 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 :: 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 (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

unDegradeBy :: Pattern Double -> Pattern a -> Pattern a
unDegradeBy :: Pattern Double -> Pattern a -> Pattern a
unDegradeBy = (Double -> Pattern a -> Pattern a)
-> Pattern Double -> Pattern a -> Pattern a
forall t1 t2 a.
(t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a
tParam Double -> Pattern a -> Pattern a
forall a. Double -> Pattern a -> Pattern a
_unDegradeBy

_unDegradeBy :: Double -> Pattern a -> Pattern a
_unDegradeBy :: Double -> Pattern a -> Pattern a
_unDegradeBy Double
x Pattern a
p = ((a, Double) -> a) -> Pattern (a, Double) -> Pattern a
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 :: 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 (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 :: 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)

sometimesBy' :: Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
sometimesBy' :: 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 :: (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' :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
sometimes' :: (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 :: (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' :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
often' :: (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 :: (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' :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
rarely' :: (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 :: (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' :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
almostNever' :: (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 :: (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' :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
almostAlways' :: (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 :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
never :: (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

always :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
always :: (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@. It has a
`someCycles = someCyclesBy 0.5` alias -}
someCyclesBy :: Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
someCyclesBy :: 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 :: 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

somecyclesBy :: Pattern Double -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
somecyclesBy :: 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 :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
someCycles :: (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

somecycles :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
somecycles :: (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

{- | `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 :: Pattern a -> Pattern a
degrade = Double -> Pattern a -> Pattern a
forall a. Double -> Pattern a -> Pattern a
_degradeBy Double
0.5

{- | (The above means that `brak` is a function from patterns of any type,
to a pattern of the same type.)

Make a pattern sound a bit like a breakbeat

Example:

@
d1 $ sound (brak "bd sn kurt")
@
-}
brak :: Pattern a -> Pattern a
brak :: 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
1Integer -> 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 :: Pattern Int -> Pattern c -> Pattern c
iter = (Int -> Pattern c -> Pattern c)
-> Pattern Int -> Pattern c -> Pattern c
forall t1 t2 a.
(t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a
tParam Int -> Pattern c -> Pattern c
forall a. Int -> Pattern a -> Pattern a
_iter

_iter :: Int -> Pattern a -> Pattern a
_iter :: 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
nInt -> 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.
iter' :: Pattern Int -> Pattern c -> Pattern c
iter' :: Pattern Int -> Pattern c -> Pattern c
iter' = (Int -> Pattern c -> Pattern c)
-> Pattern Int -> Pattern c -> Pattern c
forall t1 t2 a.
(t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a
tParam Int -> Pattern c -> Pattern c
forall a. Int -> Pattern a -> Pattern a
_iter'

_iter' :: Int -> Pattern a -> Pattern a
_iter' :: 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
nInt -> 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.
palindrome :: Pattern a -> Pattern a
palindrome :: 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)

-- | 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 :: [(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

-- | Degrades a pattern over the given time.
fadeOut :: Time -> Pattern a -> Pattern a
fadeOut :: 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 :: 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 :: 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 :: 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. 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 :: (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

slowspread :: (a -> t -> Pattern b) -> [a] -> t -> Pattern b
slowspread :: (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 :: (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' :: (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 (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. It has a
shorter alias `spreadr`.
-}
spreadChoose :: (t -> t1 -> Pattern b) -> [t] -> t1 -> Pattern b
spreadChoose :: (t -> t1 -> Pattern b) -> [t] -> t1 -> 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

spreadr :: (t -> t1 -> Pattern b) -> [t] -> t1 -> Pattern b
spreadr :: (t -> t1 -> Pattern b) -> [t] -> t1 -> 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 that 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 aply `# 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 :: (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 :: State -> [Event a]
query = State -> [Event a]
q}
  where q :: State -> [Event a]
q State
a | Int -> Bool
test (Time -> Int
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.
wedge :: Time -> Pattern a -> Pattern a -> Pattern a
wedge :: 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
1Time -> 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
1Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/(Time
1Time -> 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. 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 :: 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 (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 :: 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.

@
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 :: (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"
@
-}
trunc :: Pattern Time -> Pattern a -> Pattern a
trunc :: Pattern Time -> Pattern a -> Pattern a
trunc = (Time -> Pattern a -> Pattern a)
-> Pattern Time -> Pattern a -> Pattern a
forall t1 t2 a.
(t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a
tParam Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
_trunc

_trunc :: Time -> Pattern a -> Pattern a
_trunc :: 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` but the truncated part of the pattern loops until the end of the cycle.

@
d1 $ linger 0.25 $ sound "bd sn*2 cp hh*4 arpy bd*2 cp bd*2"
@

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 :: Pattern Time -> Pattern a -> Pattern a
linger = (Time -> Pattern a -> Pattern a)
-> Pattern Time -> Pattern a -> Pattern a
forall t1 t2 a.
(t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a
tParam Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
_linger

_linger :: Time -> Pattern a -> Pattern a
_linger :: 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
1Time -> 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
1Time -> 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. For example, to
apply `density 2` to only the first half of a pattern:

@
d1 $ within (0, 0.5) (density 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 :: (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 :: 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' :: (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
        ]

revArc :: (Time, Time) -> Pattern a -> Pattern a
revArc :: (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 @e@ function to apply a Euclidean algorithm over a
complex pattern, although the structure of that pattern will be lost:

@
d1 $ e 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 `e 3 8`. It ends up picking two `bd` sounds, a
`cp` and missing the `sn` entirely.

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 in some cases.

@
- (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.
@
-}
euclid :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a
euclid :: 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
tParam2 Int -> Int -> Pattern a -> Pattern a
forall a. Int -> Int -> Pattern a -> Pattern a
_euclid

_euclid :: Int -> Int -> Pattern a -> Pattern a
_euclid :: Int -> Int -> Pattern a -> Pattern a
_euclid Int
n Int
k Pattern a
a = [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 (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)

{- | `euclidfull n k pa pb` stacks @e n k pa@ with @einv n k pb@ -}
euclidFull :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a -> Pattern a
euclidFull :: 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 ]

_euclidBool :: Int -> Int -> Pattern Bool
_euclidBool :: Int -> Int -> Pattern Bool
_euclidBool Int
n Int
k = [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)

_euclid' :: Int -> Int -> Pattern a -> Pattern a
_euclid' :: 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))

euclidOff :: Pattern Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a
euclidOff :: 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
tParam3 Int -> Int -> Int -> Pattern a -> Pattern a
forall a. Int -> Int -> Int -> Pattern a -> Pattern a
_euclidOff

eoff :: Pattern Int -> Pattern Int -> Pattern Int -> Pattern a -> Pattern a
eoff :: 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 :: 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
sInteger -> 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)

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
tParam3 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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern Bool
p)

distrib :: [Pattern Int] -> Pattern a -> Pattern a
distrib :: [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)
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 :: [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 (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. [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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>[Int] -> [Int]
forall a. [a] -> [a]
tail)
    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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pattern b
b'

{- | `euclidInv` fills in the blanks left by `e`
 -
 @e 3 8 "x"@ -> @"x ~ ~ x ~ ~ x ~"@

 @euclidInv 3 8 "x"@ -> @"~ x x ~ x x ~ x"@
-}
euclidInv :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a
euclidInv :: 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
tParam2 Int -> Int -> Pattern a -> Pattern a
forall a. Int -> Int -> Pattern a -> Pattern a
_euclidInv

_euclidInv :: Int -> Int -> Pattern a -> Pattern a
_euclidInv :: Int -> Int -> Pattern a -> Pattern a
_euclidInv Int
n Int
k Pattern a
a = [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 (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)

index :: Real b => b -> Pattern b -> Pattern c -> Pattern c
index :: 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
1b -> 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
sTime -> 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.
-- Example: @d1 $ every 4 (rot 2) $ slow 2 $ sound "bd hh hh hh"@
rot :: Ord a => Pattern Int -> Pattern a -> Pattern a
rot :: Pattern Int -> Pattern a -> Pattern a
rot = (Int -> Pattern a -> Pattern a)
-> Pattern Int -> Pattern a -> Pattern a
forall t1 t2 a.
(t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a
tParam 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 :: 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 -> [Event a]
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 :: Arc
arc = Arc -> Arc
wholeCycle (State -> Arc
arc State
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 :: b
value = b
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. [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 :: b
value = b
s}) [EventF a b]
es
                         (Int -> [b] -> [b]
forall a. Int -> [a] -> [a]
drop ([EventF a b] -> 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. [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 :: 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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return Event a
e {part :: Arc
part = Arc
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.
segment :: Pattern Time -> Pattern a -> Pattern a
segment :: 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
tParam Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
_segment

_segment :: Time -> Pattern a -> Pattern a
_segment :: Time -> Pattern a -> Pattern a
_segment Time
n Pattern a
p = Time -> Pattern (a -> a) -> Pattern (a -> a)
forall a. Time -> Pattern a -> Pattern a
_fast Time
n ((a -> a) -> Pattern (a -> 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 :: Pattern Time -> Pattern a -> Pattern a
discretise = Pattern Time -> Pattern a -> Pattern a
forall a. Pattern Time -> Pattern a -> Pattern a
segment

-- | @randcat ps@: does a @slowcat@ on the list of patterns @ps@ but
-- randomises the order in which they are played.
randcat :: [Pattern a] -> Pattern a
randcat :: [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 (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)

wrandcat :: [(Pattern a, Double)] -> Pattern a
wrandcat :: [(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

-- @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 :: Int -> [a] -> Pattern Int -> Pattern a
_fit :: 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 :: State -> [Event Int]
query = (Event Int -> Event Int) -> [Event Int] -> [Event Int]
forall a b. (a -> b) -> [a] -> [b]
map (\Event Int
e -> (Int -> Int) -> Event Int -> Event Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Event Int -> Int
forall a b. RealFrac a => EventF (ArcF a) b -> Int
pos Event Int
e) Event Int
e) ([Event Int] -> [Event Int])
-> (State -> [Event Int]) -> State -> [Event Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern Int -> State -> [Event Int]
forall a. Pattern a -> State -> [Event a]
query Pattern Int
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 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)

fit :: Pattern Int -> [a] -> Pattern Int -> Pattern a
fit :: 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
tParam 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'

permstep :: RealFrac b => Int -> [a] -> Pattern b -> Pattern a
permstep :: 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. [a] -> Int -> a
!! b -> Int
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 (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 (t :: * -> *) a. Foldable t => t a -> Int
length [a]
things) Int
nSteps
            deviance :: a -> [a] -> a
deviance a
avg [a]
xs = [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
avga -> 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 a. (Eq a, Num a, Enum a) => a -> a -> [[a]]
perms a
n a
total
            perms :: a -> a -> [[a]]
perms a
0 a
_ = []
            perms a
1 a
n = [[a
n]]
            perms a
n a
total = (a -> [[a]]) -> [a] -> [[a]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\a
x -> ([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([[a]] -> [[a]]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ a -> a -> [[a]]
perms (a
na -> a -> a
forall a. Num a => a -> a -> a
-a
1) (a
totala -> a -> a
forall a. Num a => a -> a -> a
-a
x)) [a
1 .. (a
totala -> a -> a
forall a. Num a => a -> a -> a
-(a
na -> a -> a
forall a. Num a => a -> a -> a
-a
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.
struct :: Pattern Bool -> Pattern a -> Pattern a
struct :: 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 :: Pattern Bool -> Pattern b -> Pattern b
substruct Pattern Bool
s Pattern b
p = Pattern b
p {query :: State -> [Event b]
query = State -> [Event b]
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)
mapM (\Int
x -> Time -> Pattern Time
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
nInt -> 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 (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 (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. [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
bArcF a -> [ArcF a] -> [ArcF a]
forall a. a -> [a] -> [a]
: [a] -> [ArcF a]
pairUp' (a
ba -> [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
$ Pattern :: forall a. (State -> [Event a]) -> Pattern a
Pattern {query :: State -> [Event Int]
query = State -> [Event Int]
f}
  where f :: State -> [Event Int]
f State
st = ((Arc, Maybe Arc, Int) -> Event Int)
-> [(Arc, Maybe Arc, Int)] -> [Event Int]
forall a b. (a -> b) -> [a] -> [b]
map (\(Arc
a,Maybe Arc
b,Int
c) -> Context -> Maybe Arc -> Arc -> Int -> Event 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)] -> [Event Int])
-> [(Arc, Maybe Arc, Int)] -> [Event 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. [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' :: Pattern Int -> Pattern a -> Pattern a
substruct' Pattern Int
s Pattern a
p = Pattern a
p {query :: State -> [Event a]
query = \State
st -> (Event Int -> [Event a]) -> [Event Int] -> [Event a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (State -> Event Int -> [Event a]
forall a. Real a => State -> EventF Arc a -> [Event a]
f State
st) (Pattern Int -> State -> [Event 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 :: Context
context = [Context] -> Context
combineContexts [Context
c, Event a -> Context
forall a b. EventF a b -> Context
context Event a
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 (f :: * -> *) a. Applicative f => a -> f a
pure (Time -> Pattern Time) -> Time -> Pattern Time
forall a b. (a -> b) -> a -> b
$ Time
1Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/Int -> Time
forall a. Real a => a -> Time
toRational([Event Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Pattern Int -> Arc -> [Event 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. So
-- similar to @fast@, but with random durations. The repetitions will
-- be continguous (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 :: Pattern Int -> Pattern a -> Pattern a
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
tParam Int -> Pattern a -> Pattern a
forall a. Int -> Pattern a -> Pattern a
_stripe

_stripe :: Int -> Pattern a -> Pattern a
_stripe :: Int -> Pattern a -> Pattern a
_stripe = Pattern Int -> Pattern a -> Pattern a
forall a. Pattern Int -> Pattern a -> Pattern a
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@: 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 :: Pattern Int -> Pattern a -> Pattern a
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 a. Pattern Int -> Pattern a -> Pattern a
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 :: String -> [(String, String)]
parseLMRule String
s = (String -> (String, String)) -> [String] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (Char -> String -> (String, String)
forall a. Eq a => a -> [a] -> ([a], [a])
splitOn Char
':') [String]
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 :: [String]
commaSplit = (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack ([Text] -> [String]) -> [Text] -> [String]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn (String -> Text
T.pack String
",") (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
s

-- specific parser for step sequencer (chars map to string)
-- ruleset in form "a:b,b:ab"
parseLMRule' :: String -> [(Char, String)]
parseLMRule' :: String -> [(Char, String)]
parseLMRule' String
str = ((String, String) -> (Char, String))
-> [(String, String)] -> [(Char, String)]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> (Char, String)
forall a b. ([a], b) -> (a, b)
fixer ([(String, String)] -> [(Char, String)])
-> [(String, String)] -> [(Char, String)]
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)]
parseLMRule String
str
  where fixer :: ([a], b) -> (a, b)
fixer ([a]
c,b
r) = ([a] -> a
forall a. [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.

for example:

@
lindenmayer 1 "a:b,b:ab" "ab" -> "bab"
@
-}
lindenmayer :: Int -> String -> String -> String
lindenmayer :: Int -> String -> String -> String
lindenmayer Int
_ String
_ [] = []
lindenmayer Int
1 String
r (Char
c:String
cs) = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe [Char
c] (Char -> [(Char, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Char
c ([(Char, String)] -> Maybe String)
-> [(Char, String)] -> Maybe String
forall a b. (a -> b) -> a -> b
$ String -> [(Char, String)]
parseLMRule' String
r)
                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String -> String
lindenmayer Int
1 String
r String
cs
lindenmayer Int
n String
r String
s = (String -> String) -> String -> [String]
forall a. (a -> a) -> a -> [a]
iterate (Int -> String -> String -> String
lindenmayer Int
1 String
r) String
s [String] -> Int -> String
forall a. [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 :: Int -> String -> String -> [b]
lindenmayerI Int
n String
r String
s = (Char -> b) -> String -> [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) (String -> [b]) -> String -> [b]
forall a b. (a -> b) -> a -> b
$ Int -> String -> String -> String
lindenmayer Int
n String
r String
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. [a] -> Int -> a
!! (Int
nInt -> 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. [a] -> Int -> a
!!([Int] -> Int
forall a. [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 (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 (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:
@
tidal> 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
tParam2 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 = 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 -> [Event Int]) -> Pattern Int
forall a. (State -> [Event a]) -> Pattern a
Pattern (\(State a :: Arc
a@(Arc Time
s Time
_) ValueMap
_) ->
  Pattern Int -> Arc -> [Event 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)

{-|
Removes events from second pattern that don't start during an event from first.

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 :: 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 (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 (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 :: Pattern a -> Pattern a
-- TODO - should that be whole or part?
stretch :: 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 :: State -> [Event a]
query = State -> [Event a]
q}
  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
arc = Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc (Time -> Time
sam Time
s) (Time -> Time
nextSam Time
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' :: 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
nInt -> 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

{-| @chunk n f p@ 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.

@
d1 $ chunk 4 (density 4) $ sound "cp sn arpy [mt lt]"
@
-}
_chunk :: Int -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b
_chunk :: Int -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b
_chunk Int
n Pattern b -> Pattern b
f Pattern b
p = [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
% Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) ((Integer
iInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1) 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)) Pattern b -> Pattern b
f Pattern b
p | Integer
i <- [Integer
0 .. Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1]]


chunk :: Pattern Int -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b
chunk :: 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 b. Int -> (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

-- deprecated (renamed to chunk)
runWith :: Int -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b
runWith :: Int -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b
runWith = Int -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b
forall b. Int -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b
_chunk

{-| @chunk'@ works much the same as `chunk`, but runs from right to left.
-}
-- this was throwing a parse error when I ran it in tidal whenever I changed the function name..
_chunk' :: Integral a => a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b
_chunk' :: a -> (Pattern b -> Pattern b) -> Pattern b -> Pattern b
_chunk' a
n Pattern b -> Pattern b
f Pattern b
p = 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
iInteger -> 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

chunk' :: Integral a1 => Pattern a1 -> (Pattern a2 -> Pattern a2) -> Pattern a2 -> Pattern a2
chunk' :: 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

inside :: Pattern Time -> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a
inside :: Pattern Time
-> (Pattern a1 -> Pattern a) -> Pattern a1 -> Pattern a
inside Pattern Time
n Pattern a1 -> Pattern a
f Pattern a1
p = Pattern Time -> Pattern a -> Pattern a
forall a. Pattern Time -> Pattern a -> Pattern a
density Pattern Time
n (Pattern a -> Pattern a) -> Pattern a -> Pattern a
forall a b. (a -> b) -> a -> b
$ Pattern a1 -> Pattern a
f (Pattern Time -> Pattern a1 -> Pattern a1
forall a. Pattern Time -> Pattern a -> Pattern a
slow Pattern Time
n Pattern a1
p)

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

loopFirst :: Pattern a -> Pattern a
loopFirst :: 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 :: State -> [Event a]
query = State -> [Event a]
f}
  where f :: State -> [Event a]
f State
st = (Event a -> Event a) -> [Event a] -> [Event a]
forall a b. (a -> b) -> [a] -> [b]
map
          (\(Event Context
c Maybe Arc
w Arc
p' a
v) ->
             Context -> Maybe Arc -> Arc -> a -> Event 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) ([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
p (State
st {arc :: Arc
arc = Arc -> Arc
minus (Arc -> Arc) -> Arc -> Arc
forall a b. (a -> b) -> a -> b
$ State -> Arc
arc State
st})
          where minus :: Arc -> Arc
minus = (Time -> Time) -> Arc -> Arc
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 (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 :: 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 :: [(Time, Time, Pattern a)] -> Pattern a
seqPLoop :: [(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 (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 (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 (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"`.  It assumes your scale fits within an octave;
to change this use `toScale' size`.  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' :: 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 (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 (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)

toScale :: Num a => [a] -> Pattern Int -> Pattern a
toScale :: [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

{- | `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 . @swing@ is an alias
for `swingBy (1%3)`
-}
swingBy :: Pattern Time -> Pattern Time -> Pattern a -> Pattern a
swingBy :: 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
~>))

swing :: Pattern Time -> Pattern a -> Pattern a
swing :: 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 (f :: * -> *) a. Applicative f => a -> f a
pure (Time -> Pattern Time) -> Time -> Pattern Time
forall a b. (a -> b) -> a -> b
$ Integer
1Integer -> 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 -}
cycleChoose :: [a] -> Pattern a
cycleChoose :: [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 :: 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. [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
iInt -> 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
nInt -> 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.
-}
shuffle :: Pattern Int -> Pattern a -> Pattern a
shuffle :: Pattern Int -> Pattern a -> Pattern a
shuffle = (Int -> Pattern a -> Pattern a)
-> Pattern Int -> Pattern a -> Pattern a
forall t1 t2 a.
(t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a
tParam Int -> Pattern a -> Pattern a
forall a. Int -> Pattern a -> Pattern a
_shuffle

_shuffle :: Int -> Pattern a -> Pattern a
_shuffle :: 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.
-}
scramble :: Pattern Int -> Pattern a -> Pattern a
scramble :: Pattern Int -> Pattern a -> Pattern a
scramble = (Int -> Pattern a -> Pattern a)
-> Pattern Int -> Pattern a -> Pattern a
forall t1 t2 a.
(t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a
tParam Int -> Pattern a -> Pattern a
forall a. Int -> Pattern a -> Pattern a
_scramble

_scramble :: Int -> Pattern a -> Pattern a
_scramble :: 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 :: 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 -> [Event Int]) -> Pattern Int
forall a. (State -> [Event a]) -> Pattern a
Pattern (\(State a :: Arc
a@(Arc Time
s Time
_) ValueMap
_) -> Arc -> Time -> [Event Int]
forall a. RealFrac a => Arc -> a -> [Event Int]
events Arc
a (Time -> [Event Int]) -> Time -> [Event Int]
forall a b. (a -> b) -> a -> b
$ Time -> Time
sam Time
s)
  where events :: Arc -> a -> [Event Int]
events Arc
a a
seed = ((Arc, Int) -> Maybe (Event Int)) -> [(Arc, Int)] -> [Event Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Arc, Int) -> Maybe (Event Int)
forall b. (Arc, b) -> Maybe (EventF Arc b)
toEv ([(Arc, Int)] -> [Event Int]) -> [(Arc, Int)] -> [Event 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 = a -> Int -> [Double]
forall a b. (RealFrac a, Fractional b) => a -> Int -> [b]
timeToRands a
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 ([Time] -> [Time]
forall a. [a] -> [a]
tail [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 (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


ur :: Time -> Pattern String -> [(String, Pattern a)] -> [(String, Pattern a -> Pattern a)] -> Pattern a
ur :: Time
-> Pattern String
-> [(String, Pattern a)]
-> [(String, Pattern a -> Pattern a)]
-> Pattern a
ur Time
t Pattern String
outer_p [(String, Pattern a)]
ps [(String, 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 ([String] -> (Pattern a, Arc -> Pattern a -> Pattern a)
getPat ([String] -> (Pattern a, Arc -> Pattern a -> Pattern a))
-> (String -> [String])
-> String
-> (Pattern a, Arc -> Pattern a -> Pattern a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
split (String -> (Pattern a, Arc -> Pattern a -> Pattern a))
-> Pattern String
-> Pattern (Pattern a, Arc -> Pattern a -> Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern String
outer_p)
  where split :: String -> [String]
split = (Char -> Bool) -> String -> [String]
forall a. (a -> Bool) -> [a] -> [[a]]
wordsBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
':')
        getPat :: [String] -> (Pattern a, Arc -> Pattern a -> Pattern a)
getPat (String
s:[String]
xs) = (String -> Pattern a
match String
s, [String] -> Arc -> Pattern a -> Pattern a
transform [String]
xs)
        -- TODO - check this really can't happen..
        getPat [String]
_ = String -> (Pattern a, Arc -> Pattern a -> Pattern a)
forall a. HasCallStack => String -> a
error String
"can't happen?"
        match :: String -> Pattern a
match String
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
$ String -> [(String, Pattern a)] -> Maybe (Pattern a)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
s [(String, Pattern a)]
ps'
        ps' :: [(String, Pattern a)]
ps' = ((String, Pattern a) -> (String, Pattern a))
-> [(String, Pattern a)] -> [(String, Pattern a)]
forall a b. (a -> b) -> [a] -> [b]
map ((Pattern a -> Pattern a)
-> (String, Pattern a) -> (String, Pattern a)
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)) [(String, 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 :: [String] -> Arc -> Pattern a -> Pattern a
transform (String
x:[String]
_) Arc
a = String -> Arc -> Pattern a -> Pattern a
transform' String
x Arc
a
        transform [String]
_ Arc
_ = Pattern a -> Pattern a
forall a. a -> a
id
        transform' :: String -> Arc -> Pattern a -> Pattern a
transform' String
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 (f :: * -> *) a. Applicative f => a -> f a
pure (Time -> Pattern Time) -> Time -> Pattern Time
forall a b. (a -> b) -> a -> b
$ Time
1Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/(Time
eTime -> Time -> Time
forall a. Num a => a -> a -> a
-Time
s)) (String -> Pattern a -> Pattern a
matchF String
str) Pattern a
p
        matchF :: String -> Pattern a -> Pattern a
matchF String
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
$ String
-> [(String, Pattern a -> Pattern a)]
-> Maybe (Pattern a -> Pattern a)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
str [(String, Pattern a -> Pattern a)]
fs
        timedValues :: Pattern b -> Pattern (Arc, b)
timedValues = (Event b -> Event (Arc, b)) -> Pattern b -> Pattern (Arc, b)
forall a b. (Event a -> Event b) -> Pattern a -> Pattern b
withEvent (\(Event Context
c (Just Arc
a) Arc
a' b
v) -> Context -> Maybe Arc -> Arc -> (Arc, b) -> Event (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
a) Arc
a' (Arc
a,b
v)) (Pattern b -> Pattern (Arc, b))
-> (Pattern b -> Pattern b) -> Pattern b -> Pattern (Arc, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern b -> Pattern b
forall a. Pattern a -> Pattern a
filterDigital

inhabit :: [(String, Pattern a)] -> Pattern String -> Pattern a
inhabit :: [(String, Pattern a)] -> Pattern String -> Pattern a
inhabit [(String, Pattern a)]
ps Pattern String
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
$ (\String
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
$ String -> [(String, Pattern a)] -> Maybe (Pattern a)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
s [(String, Pattern a)]
ps) (String -> Pattern a) -> Pattern String -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern String
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 :: [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 (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
offsetTime -> Time -> Time
forall a. Num a => a -> a -> a
+Time
x)Arc -> [Arc] -> [Arc]
forall a. a -> [a] -> [a]
:Time -> [Time] -> [Arc]
markOut (Time
offsetTime -> 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
aTime -> Time -> Time
forall a. Fractional a => a -> a -> a
/Time
s) (Time
bTime -> 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 (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 Events
flatpat :: Pattern [a] -> Pattern a
flatpat :: Pattern [a] -> Pattern a
flatpat Pattern [a]
p = Pattern [a]
p {query :: State -> [Event a]
query = (EventF Arc [a] -> [Event a]) -> [EventF Arc [a]] -> [Event a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
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) ([EventF Arc [a]] -> [Event a])
-> (State -> [EventF Arc [a]]) -> State -> [Event a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern [a] -> State -> [EventF Arc [a]]
forall a. Pattern a -> State -> [Event a]
query Pattern [a]
p}

-- | @layer@ takes a Pattern of lists and pulls the list elements as
-- separate Events
layer :: [a -> Pattern b] -> a -> Pattern b
layer :: [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 :: 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 :: 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 :: ([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 a a b.
(Integral a, Integral a) =>
a -> a -> EventF Arc b -> Maybe (EventF Arc b)
shiftIt Int
n ([EventF Arc b] -> 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 :: a -> a -> EventF Arc b -> Maybe (EventF Arc b)
shiftIt a
n a
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 (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
* a -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
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
/ a -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
d
        -- TODO ignoring analog events.. Should we just leave them as-is?
        shiftIt a
_ a
_ EventF Arc b
_ = Maybe (EventF Arc b)
forall a. Maybe a
Nothing

arp :: Pattern String -> Pattern a -> Pattern a
arp :: Pattern String -> Pattern a -> Pattern a
arp = (String -> Pattern a -> Pattern a)
-> Pattern String -> Pattern a -> Pattern a
forall t1 t2 a.
(t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a
tParam String -> Pattern a -> Pattern a
forall a. String -> Pattern a -> Pattern a
_arp

_arp :: String -> Pattern a -> Pattern a
_arp :: String -> Pattern a -> Pattern a
_arp String
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
$ String -> [(String, [a] -> [a])] -> Maybe ([a] -> [a])
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
name [(String, [a] -> [a])]
forall a. [(String, [a] -> [a])]
arps
        arps :: [(String, [a] -> [a])]
        arps :: [(String, [a] -> [a])]
arps = [(String
"up", [a] -> [a]
forall a. a -> a
id),
                (String
"down", [a] -> [a]
forall a. [a] -> [a]
reverse),
                (String
"updown", \[a]
x -> [a] -> [a]
forall a. [a] -> [a]
init [a]
x [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a]
forall a. [a] -> [a]
init ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
x)),
                (String
"downup", \[a]
x -> [a] -> [a]
forall a. [a] -> [a]
init ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
x) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a]
forall a. [a] -> [a]
init [a]
x),
                (String
"up&down", \[a]
x -> [a]
x [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a]
forall a. [a] -> [a]
reverse [a]
x),
                (String
"down&up", \[a]
x -> [a] -> [a]
forall a. [a] -> [a]
reverse [a]
x [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
x),
                (String
"converge", [a] -> [a]
forall a. [a] -> [a]
converge),
                (String
"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),
                (String
"disconverge", \[a]
x -> [a] -> [a]
forall a. [a] -> [a]
converge [a]
x [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a]
forall a. [a] -> [a]
tail ([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)),
                (String
"pinkyup", [a] -> [a]
forall a. [a] -> [a]
pinkyup),
                (String
"pinkyupdown", \[a]
x -> [a] -> [a]
forall a. [a] -> [a]
init ([a] -> [a]
forall a. [a] -> [a]
pinkyup [a]
x) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a]
forall a. [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)),
                (String
"thumbup", [a] -> [a]
forall a. [a] -> [a]
thumbup),
                (String
"thumbupdown", \[a]
x -> [a] -> [a]
forall a. [a] -> [a]
init ([a] -> [a]
forall a. [a] -> [a]
thumbup [a]
x) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a]
forall a. [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. [a] -> a
last [a]
xs a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
converge ([a] -> [a]
forall a. [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. [a] -> [a]
init [b]
xs
          where pinky :: b
pinky = [b] -> b
forall a. [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
$ [b] -> [b]
forall a. [a] -> [a]
tail [b]
xs
          where thumb :: b
thumb = [b] -> b
forall a. [a] -> a
head [b]
xs


{- 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}) 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
-}

-- Repeats each event @n@ times within its arc
ply :: Pattern Rational -> Pattern a -> Pattern a
ply :: Pattern Time -> Pattern a -> Pattern a
ply = (Time -> Pattern a -> Pattern a)
-> Pattern Time -> Pattern a -> Pattern a
forall t1 t2 a.
(t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a
tParam Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
_ply

_ply :: Rational -> Pattern a -> Pattern a
_ply :: 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 (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

-- Like 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 :: 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 :: 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 t. (Ord t, Num t) => t -> Pattern a
compound t
numPat
  where compound :: t -> Pattern a
compound t
n | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
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
$ t -> Pattern a
compound (t -> Pattern a) -> t -> Pattern a
forall a b. (a -> b) -> a -> b
$ t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1)

-- | Syncopates a rhythm, shifting each event halfway into its arc (aka timespan), e.g. @"a b [c d] e"@ becomes the equivalent of @"[~ a] [~ b] [[~ c] [~ d]] [~ e]"@
press :: Pattern a -> Pattern a
press :: 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. @pressBy 0.5@ is the same as @press@, while @pressBy (1/3)@ shifts each event by a third of its arc.
pressBy :: Pattern Time -> Pattern a -> Pattern a
pressBy :: Pattern Time -> Pattern a -> Pattern a
pressBy = (Time -> Pattern a -> Pattern a)
-> Pattern Time -> Pattern a -> Pattern a
forall t1 t2 a.
(t1 -> t2 -> Pattern a) -> Pattern t1 -> t2 -> Pattern a
tParam Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
_pressBy

_pressBy :: Time -> Pattern a -> Pattern a
_pressBy :: 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 (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@.
sew :: Pattern Bool -> Pattern a -> Pattern a -> Pattern a
sew :: Pattern Bool -> Pattern a -> Pattern a -> Pattern a
sew 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
mask Pattern Bool
pb Pattern a
a) (Pattern Bool -> Pattern a -> Pattern a
forall a. Pattern Bool -> Pattern a -> Pattern a
mask (Pattern Bool -> Pattern Bool
forall (f :: * -> *). Functor f => f Bool -> f Bool
inv Pattern Bool
pb) Pattern a
b)

-- | Uses the first (binary) pattern to switch between the following
-- two patterns. The resulting structure comes from the binary
-- pattern, not the source patterns. See also @sew@.
stitch :: Pattern Bool -> Pattern a -> Pattern a -> Pattern a
stitch :: 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 :: Pattern Bool -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
while Pattern Bool
b Pattern a -> Pattern a
f Pattern a
pat = 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 :: Integral i => i -> Time -> Pattern a -> Pattern a
stutter :: 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
ni -> i -> i
forall a. Num a => a -> a -> a
-i
1)]

echo, triple, quad, double :: Time -> Pattern a -> Pattern a
echo :: Time -> Pattern a -> Pattern a
echo   = Int -> Time -> Pattern a -> Pattern a
forall i a. Integral i => i -> Time -> Pattern a -> Pattern a
stutter (Int
2 :: Int)
triple :: Time -> Pattern a -> Pattern a
triple = Int -> Time -> Pattern a -> Pattern a
forall i a. Integral i => i -> Time -> Pattern a -> Pattern a
stutter (Int
3 :: Int)
quad :: Time -> Pattern a -> Pattern a
quad   = Int -> Time -> Pattern a -> Pattern a
forall i a. Integral i => i -> Time -> Pattern a -> Pattern a
stutter (Int
4 :: Int)
double :: Time -> Pattern a -> Pattern a
double = Time -> Pattern a -> Pattern a
forall a. Time -> Pattern a -> Pattern a
echo

{- | 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](#jux) and [every](#every),
it's possible to chain multiple transforms together with `.`, 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 (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 (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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure (-Int
2))
                   ]

juxcut' :: [t -> Pattern ValueMap] -> t -> Pattern ValueMap
juxcut' :: [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. [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 (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Pattern Int) -> Int -> Pattern Int
forall a b. (a -> b) -> a -> b
$ Int
1Int -> 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 (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
lInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
  where l :: Int
l = [t -> Pattern ValueMap] -> 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 transform. resulting patterns from each transformation will be spread via pan from left to right.

For example:

@
d1 $ jux' [iter 4, chop 16, id, rev, palindrome] $ sound "bd sn"
@

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 mid left mid right the chopped and the reversed version will appear.

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' :: [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. [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 (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
lInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
  where l :: Int
l = [t -> Pattern ValueMap] -> 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 (f :: * -> *) a. Applicative f => a -> f a
pure (Double
5Double -> 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 (f :: * -> *) a. Applicative f => a -> f a
pure (Double
1Double -> 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 (density 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
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
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
nPattern 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
nPattern Double -> Pattern Double -> Pattern Double
forall a. Fractional a => a -> a -> a
/Pattern Double
2)]

pick :: String -> Int -> String
pick :: String -> Int -> String
pick String
name Int
n = String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n

-- samples "jvbass [~ latibro] [jvbass [latibro jvbass]]" ((1%2) `rotL` slow 6 "[1 6 8 7 3]")

samples :: Applicative f => f String -> f Int -> f String
samples :: f String -> f Int -> f String
samples f String
p f Int
p' = String -> Int -> String
pick (String -> Int -> String) -> f String -> f (Int -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f String
p f (Int -> String) -> f Int -> f String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f Int
p'

samples' :: Applicative f => f String -> f Int -> f String
samples' :: f String -> f Int -> f String
samples' f String
p f Int
p' = (String -> Int -> String) -> Int -> String -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> Int -> String
pick (Int -> String -> String) -> f Int -> f (String -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Int
p' f (String -> String) -> f String -> f String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f String
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)
-}

spreadf :: [a -> Pattern b] -> a -> Pattern b
spreadf :: [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 :: Pattern a -> [Pattern a] -> Pattern a
stackwith Pattern a
p [Pattern a]
ps | [Pattern 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. (a -> b) -> [a] -> [b]
map (\(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] -> [Pattern a] -> [(Int, Pattern a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [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 (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)
@
-}
range :: Num a => Pattern a -> Pattern a -> Pattern a -> Pattern a
range :: 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
toa -> 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 :: 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
tob -> 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.  Do *not* use negative numbers or zero as arguments! -}
rangex :: (Functor f, Floating b) => b -> b -> f b -> f b
rangex :: 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 :: Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
off :: 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 :: 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 :: 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

-- | Step sequencing
step :: String -> String -> Pattern String
step :: String -> String -> Pattern String
step String
s String
cs = [Pattern String] -> Pattern String
forall a. [Pattern a] -> Pattern a
fastcat ([Pattern String] -> Pattern String)
-> [Pattern String] -> Pattern String
forall a b. (a -> b) -> a -> b
$ (Char -> Pattern String) -> String -> [Pattern String]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Pattern String
f String
cs
    where f :: Char -> Pattern String
f Char
c | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'x' = String -> Pattern String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
s
              | Char -> Bool
isDigit Char
c = String -> Pattern String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Pattern String) -> String -> Pattern String
forall a b. (a -> b) -> a -> b
$ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
c]
              | Bool
otherwise = Pattern String
forall a. Pattern a
silence

steps :: [(String, String)] -> Pattern String
steps :: [(String, String)] -> Pattern String
steps = [Pattern String] -> Pattern String
forall a. [Pattern a] -> Pattern a
stack ([Pattern String] -> Pattern String)
-> ([(String, String)] -> [Pattern String])
-> [(String, String)]
-> Pattern String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String) -> Pattern String)
-> [(String, String)] -> [Pattern String]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> String -> Pattern String)
-> (String, String) -> Pattern String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> String -> Pattern String
step)

-- | like `step`, but allows you to specify an array of strings to use for 0,1,2...
step' :: [String] -> String -> Pattern String
step' :: [String] -> String -> Pattern String
step' [String]
ss String
cs = [Pattern String] -> Pattern String
forall a. [Pattern a] -> Pattern a
fastcat ([Pattern String] -> Pattern String)
-> [Pattern String] -> Pattern String
forall a b. (a -> b) -> a -> b
$ (Char -> Pattern String) -> String -> [Pattern String]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Pattern String
f String
cs
    where f :: Char -> Pattern String
f Char
c | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'x' = String -> Pattern String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Pattern String) -> String -> Pattern String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. [a] -> a
head [String]
ss
              | Char -> Bool
isDigit Char
c = String -> Pattern String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Pattern String) -> String -> Pattern String
forall a b. (a -> b) -> a -> b
$ [String]
ss [String] -> Int -> String
forall a. [a] -> Int -> a
!! Char -> Int
digitToInt Char
c
              | Bool
otherwise = Pattern String
forall a. Pattern a
silence


ghost'' :: Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
ghost'' :: Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
ghost'' 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
aTime -> 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
aTime -> 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' :: 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
ghost'' 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 (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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure Double
1.25))) Pattern ValueMap
p

ghost :: Pattern ValueMap -> Pattern ValueMap
ghost :: Pattern ValueMap -> Pattern ValueMap
ghost = Time -> Pattern ValueMap -> Pattern ValueMap
ghost' Time
0.125

{- |
   tabby - A more literal weaving than the `weave` function, give number
   of 'threads' per cycle and two patterns, 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 :: 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
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1], [Integer] -> [Integer]
forall a. [a] -> [a]
reverse [Integer
0..Integer
nInteger -> 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
nInteger -> 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
iInteger -> Integer -> Time
forall a. Integral a => a -> a -> Ratio a
%Integer
n) ((Integer
iInteger -> 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 a.
Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
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 (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 a.
Pattern Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
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 (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True, Pattern Bool
forall a. Pattern a
silence]) Pattern a
warpP

-- | chooses between a list of patterns, using a pattern of floats (from 0-1)
select :: Pattern Double -> [Pattern a] -> Pattern a
select :: 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
tParam Double -> [Pattern a] -> Pattern a
forall a. Double -> [Pattern a] -> Pattern a
_select

_select :: Double -> [Pattern a] -> Pattern a
_select :: Double -> [Pattern a] -> Pattern a
_select Double
f [Pattern a]
ps =  [Pattern a]
ps [Pattern a] -> Int -> Pattern a
forall a. [a] -> Int -> a
!! Double -> Int
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 (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern a]
ps Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))

-- | chooses between a list of functions, using a pattern of floats (from 0-1)
selectF :: Pattern Double -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a
selectF :: 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 :: 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. [a] -> Int -> a
!! Double -> Int
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 (t :: * -> *) a. Foldable t => t a -> Int
length [Pattern a -> Pattern a]
ps))) Pattern a
p

-- | chooses between a list of functions, using a pattern of integers
pickF :: Pattern Int -> [Pattern a -> Pattern a] -> Pattern a -> Pattern a
pickF :: 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 :: 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 p f f' p'@ splits controlpattern @p'@ in two, applying
-- the function @f@ to one and @f'@ to the other. This depends on
-- whether events in it contains values matching with those in @p@.
-- For example in @contrast (n "1") (# crush 3) (# vowel "a") $ 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 :: (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 String a)
-> Pattern ValueMap
-> Pattern b
contrastBy Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
(==)

contrastBy :: (a -> Value -> Bool)
              -> (ControlPattern -> Pattern b)
              -> (ControlPattern -> Pattern b)
              -> Pattern (Map.Map String a)
              -> Pattern (Map.Map String Value)
              -> Pattern b
contrastBy :: (a -> Value -> Bool)
-> (Pattern ValueMap -> Pattern b)
-> (Pattern ValueMap -> Pattern b)
-> Pattern (Map String a)
-> Pattern ValueMap
-> Pattern b
contrastBy a -> Value -> Bool
comp Pattern ValueMap -> Pattern b
f Pattern ValueMap -> Pattern b
f' Pattern (Map String 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 String a -> Bool)
-> Pattern (Map String a)
-> Pattern ValueMap
-> Pattern (Bool, ValueMap)
forall b a.
(b -> a -> Bool) -> Pattern a -> Pattern b -> Pattern (Bool, b)
matchManyToOne ((Map String a -> ValueMap -> Bool)
-> ValueMap -> Map String a -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Map String a -> ValueMap -> Bool)
 -> ValueMap -> Map String a -> Bool)
-> (Map String a -> ValueMap -> Bool)
-> ValueMap
-> Map String a
-> Bool
forall a b. (a -> b) -> a -> b
$ (a -> Value -> Bool) -> Map String 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 String 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 :: (Pattern ValueMap -> Pattern a)
-> (Pattern ValueMap -> Pattern a)
-> Pattern (Map String (Value, Value))
-> Pattern ValueMap
-> Pattern a
contrastRange = ((Value, Value) -> Value -> Bool)
-> (Pattern ValueMap -> Pattern a)
-> (Pattern ValueMap -> Pattern a)
-> Pattern (Map String (Value, Value))
-> Pattern ValueMap
-> Pattern a
forall a b.
(a -> Value -> Bool)
-> (Pattern ValueMap -> Pattern b)
-> (Pattern ValueMap -> Pattern b)
-> Pattern (Map String 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 String
s, VS String
e) (VS String
v) = String
v String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
s Bool -> Bool -> Bool
&& String
v String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
e
            f (Value, Value)
_ Value
_ = Bool
False

-- | Like @contrast@, but one function is given, and applied to events with matching controls.
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 :: (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

fixRange :: (ControlPattern -> Pattern ValueMap)
            -> Pattern (Map.Map String (Value, Value))
            -> ControlPattern
            -> ControlPattern
fixRange :: (Pattern ValueMap -> Pattern ValueMap)
-> Pattern (Map String (Value, Value))
-> Pattern ValueMap
-> Pattern ValueMap
fixRange Pattern ValueMap -> Pattern ValueMap
f = (Pattern ValueMap -> Pattern ValueMap)
-> (Pattern ValueMap -> Pattern ValueMap)
-> Pattern (Map String (Value, Value))
-> Pattern ValueMap
-> Pattern ValueMap
forall a.
(Pattern ValueMap -> Pattern a)
-> (Pattern ValueMap -> Pattern a)
-> Pattern (Map String (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 String (Value, Value))
-> Pattern ValueMap
-> Pattern ValueMap
unfixRange = (Pattern ValueMap -> Pattern ValueMap)
-> (Pattern ValueMap -> Pattern ValueMap)
-> Pattern (Map String (Value, Value))
-> Pattern ValueMap
-> Pattern ValueMap
forall a.
(Pattern ValueMap -> Pattern a)
-> (Pattern ValueMap -> Pattern a)
-> Pattern (Map String (Value, Value))
-> Pattern ValueMap
-> Pattern a
contrastRange Pattern ValueMap -> Pattern ValueMap
forall a. a -> a
id

-- | limit values in a Pattern (or other Functor) to n equally spaced
-- divisions of 1.
quantise :: (Functor f, RealFrac b) => b -> f b -> f b
quantise :: b -> f b -> f b
quantise b
n = (b -> b) -> f b -> 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
. (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 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))

-- quantise but with floor
qfloor :: (Functor f, RealFrac b) => b -> f b -> f b
qfloor :: b -> f b -> f b
qfloor b
n = (b -> b) -> f b -> 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
. (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 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))

qceiling :: (Functor f, RealFrac b) => b -> f b -> f b
qceiling :: b -> f b -> f b
qceiling b
n = (b -> b) -> f b -> 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
. (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 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))

qround :: (Functor f, RealFrac b) => b -> f b -> f b
qround :: 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 :: 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
<$>)

-- | Serialises a pattern so there's only one event playing at any one
-- time, making it 'monophonic'. Events which start/end earlier are given priority.
mono :: Pattern a -> Pattern a
mono :: Pattern a -> Pattern a
mono 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
$ \(State Arc
a ValueMap
cm) -> [Event a] -> [Event a]
forall b. [EventF Arc b] -> [EventF Arc b]
flatten ([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
p (Arc -> ValueMap -> State
State Arc
a ValueMap
cm) where
  flatten :: [Event a] -> [Event a]
  flatten :: [Event a] -> [Event a]
flatten = (Event a -> Maybe (Event a)) -> [Event a] -> [Event a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Event a -> Maybe (Event a)
forall a. Event a -> Maybe (Event a)
constrainPart ([Event a] -> [Event a])
-> ([Event a] -> [Event a]) -> [Event a] -> [Event a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event a] -> [Event a]
forall b. [EventF Arc b] -> [EventF Arc b]
truncateOverlaps ([Event a] -> [Event a])
-> ([Event a] -> [Event a]) -> [Event a] -> [Event a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Event a -> Maybe Arc) -> [Event a] -> [Event a]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Event a -> Maybe Arc
forall a b. EventF a b -> Maybe a
whole
  truncateOverlaps :: [Event a] -> [Event a]
truncateOverlaps [] = []
  truncateOverlaps (Event a
e:[Event a]
es) = Event a
e Event a -> [Event a] -> [Event a]
forall a. a -> [a] -> [a]
: [Event a] -> [Event a]
truncateOverlaps ((Event a -> Maybe (Event a)) -> [Event a] -> [Event a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Event a -> Event a -> Maybe (Event a)
forall a a. Event a -> Event a -> Maybe (Event a)
snip Event a
e) [Event a]
es)
  -- TODO - decide what to do about analog events..
  snip :: Event a -> Event a -> Maybe (Event a)
snip Event a
a Event a
b | Arc -> Time
forall a. ArcF a -> a
start (Event a -> Arc
forall a. Event a -> Arc
wholeOrPart Event a
b) Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Arc -> Time
forall a. ArcF a -> a
stop (Event a -> Arc
forall a. Event a -> Arc
wholeOrPart Event a
a) = Event a -> Maybe (Event a)
forall a. a -> Maybe a
Just Event a
b
           | Arc -> Time
forall a. ArcF a -> a
stop (Event a -> Arc
forall a. Event a -> Arc
wholeOrPart Event a
b) Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<= Arc -> Time
forall a. ArcF a -> a
stop (Event a -> Arc
forall a. Event a -> Arc
wholeOrPart Event a
a) = Maybe (Event a)
forall a. Maybe a
Nothing
           | Bool
otherwise = Event a -> Maybe (Event a)
forall a. a -> Maybe a
Just Event a
b {whole :: Maybe Arc
whole = 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 (Arc -> Time
forall a. ArcF a -> a
stop (Arc -> Time) -> Arc -> Time
forall a b. (a -> b) -> a -> b
$ Event a -> Arc
forall a. Event a -> Arc
wholeOrPart Event a
a) (Arc -> Time
forall a. ArcF a -> a
stop (Arc -> Time) -> Arc -> Time
forall a b. (a -> b) -> a -> b
$ Event a -> Arc
forall a. Event a -> Arc
wholeOrPart Event a
b)}
  constrainPart :: Event a -> Maybe (Event a)
  constrainPart :: Event a -> Maybe (Event a)
constrainPart Event a
e = do Arc
a <- Arc -> Arc -> Maybe Arc
subArc (Event a -> Arc
forall a. Event a -> Arc
wholeOrPart Event a
e) (Event a -> Arc
forall a b. EventF a b -> a
part Event a
e)
                       Event a -> Maybe (Event a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Event a -> Maybe (Event a)) -> Event a -> Maybe (Event a)
forall a b. (a -> b) -> a -> b
$ Event a
e {part :: Arc
part = Arc
a}

-- 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 :: 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 :: Maybe a
whole = a -> Maybe a
forall a. a -> Maybe a
Just a
queryA, part :: a
part = a
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 :: Arc
arc = Arc
aStop})
            nextV :: State -> Maybe a
nextV State
st' | [Event 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. [a] -> a
head (State -> [Event a]
nextEs State
st'))
            tween' :: a -> a -> [EventF a a]
tween' a
queryA' a
v =
              [ Event :: forall a b. Context -> Maybe a -> a -> b -> EventF a b
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 :: [(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 |
  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 effected
  d1 $ note (scale "hexDorian" $ snowball (+) (slow 2 . rev) 8 "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 :: 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
pattern = [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
pattern ([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
pattern

{- @soak@ |
    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 :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
soak Int
depth Pattern a -> Pattern a
f Pattern a
pattern = [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
pattern

deconstruct :: Int -> Pattern String -> String
deconstruct :: Int -> Pattern String -> String
deconstruct Int
n Pattern String
p = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ([String] -> String) -> [[String]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> String
showStep ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ Pattern String -> [[String]]
forall a. Pattern a -> [[a]]
toList Pattern String
p
  where
    showStep :: [String] -> String
    showStep :: [String] -> String
showStep [] = String
"~"
    showStep [String
x] = String
x
    showStep [String]
xs = String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
xs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
    toList :: Pattern a -> [[a]]
    toList :: 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
1Time -> 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"`.
-}
bite :: Pattern Int -> Pattern Int -> Pattern a -> Pattern a
bite :: 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 :: 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
zoompat (Int -> Pattern a) -> Pattern Int -> Pattern (Pattern a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern Int
ipat
  where zoompat :: Int -> Pattern a
zoompat 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

{- @squeeze@ ipat pats | uses a pattern of integers to index into a list of patterns.
-}
squeeze :: Pattern Int -> [Pattern a] -> Pattern a
squeeze :: 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 :: State -> [Event ValueMap]
query = State -> [Event ValueMap]
q}
  where q :: State -> [Event ValueMap]
q State
st = (EventF Arc (Pattern ValueMap) -> [Event ValueMap])
-> [EventF Arc (Pattern ValueMap)] -> [Event ValueMap]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (State -> EventF Arc (Pattern ValueMap) -> [Event 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) -> [Event ValueMap]
f State
st (Event Context
c (Just Arc
w) Arc
p Pattern ValueMap
v) =
          (Event ValueMap -> Maybe (Event ValueMap))
-> [Event ValueMap] -> [Event ValueMap]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Context -> Arc -> Arc -> Event ValueMap -> Maybe (Event ValueMap)
forall b.
Context -> Arc -> Arc -> EventF Arc b -> Maybe (EventF Arc b)
munge Context
c Arc
w Arc
p) ([Event ValueMap] -> [Event ValueMap])
-> [Event ValueMap] -> [Event ValueMap]
forall a b. (a -> b) -> a -> b
$ Pattern ValueMap -> State -> [Event 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 (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
1Time -> 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 :: Arc
arc = 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 (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 (Pattern (Pattern ValueMap) -> Pattern ValueMap)
-> Pattern (Pattern ValueMap) -> Pattern ValueMap
forall a b. (a -> b) -> a -> b
$ Int -> Pattern ValueMap
zoompat (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 (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 zoompat :: Int -> Pattern ValueMap
zoompat 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

-- 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 :: 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
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]

_binary :: Data.Bits.Bits b => Int -> b -> Pattern Bool
_binary :: 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 = 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
tParam 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 String -> Pattern Bool
ascii Pattern String
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)
-> (String -> [Bool]) -> String -> Pattern Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> [Bool]) -> String -> [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)) (String -> Pattern Bool)
-> Pattern String -> Pattern (Pattern Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern String
p

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