-- |
-- Module      : Harmonic.Interface.Tidal.Utils
-- Description : TidalCycles helper functions for octave transposition and time rotation
--
-- Shorthand utilities used across live-coding scripts: octave transposition
-- via 'oct', and time rotation operators 'pullBy'\/'pushBy' that wrap
-- TidalCycles' early\/late operators.

module Harmonic.Interface.Tidal.Utils (
    -- * Transposition
    oct,

    -- * Time rotation
    pullBy, pushBy,

    -- * Humanisation
    humanise,

    -- * Onset repair
    onset,

    -- * Note-length constants
    hemidemisemiquaver, demisemiquaver, semiquaver, quaver, crotchet, minim,

    -- * Swing
    swing8, swing16,

    -- * Selection
    over, (-->),

    -- * Random gating
    binaryrange,

    -- * Sidechain
    pump,
    -- * Monophony
    mono', retrig,
) where

import Data.List (sortOn)
import Data.Maybe (mapMaybe)
import Sound.Tidal.Context

-- | Transpose by whole octaves. @oct 1@ is up an octave, @oct (-1)@ down.
-- The shift is a pattern, so it can move across the cycle: @|+ oct "[0 1]*2"@.
--
-- Add onto a pattern:
--
-- @, cello T (0,1) k vl grid Bass |+ oct (-1)@
oct :: Pattern Note -> Pattern ValueMap
oct :: Pattern Note -> Pattern ValueMap
oct Pattern Note
k = Pattern Note -> Pattern ValueMap
note (Pattern Note
12 Pattern Note -> Pattern Note -> Pattern Note
forall a. Num a => a -> a -> a
* Pattern Note
k)

-- | Rotate a pattern earlier ('pullBy') or later ('pushBy') in time.
-- Function forms of the TidalCycles @\<~@ and @~>@ operators, so they compose
-- in a modifier chain rather than needing parentheses. The amount is a
-- pattern, so the rotation can itself vary across the cycle.
--
-- @, pushBy (1\/8) $ harp T (0,1) k vl flow Alto@
pullBy :: Pattern Time -> Pattern a -> Pattern a
pullBy :: forall a. Pattern Time -> Pattern a -> Pattern a
pullBy = Pattern Time -> Pattern a -> Pattern a
forall a. Pattern Time -> Pattern a -> Pattern a
(<~)

-- | Rotate a pattern later in time. See 'pullBy'.
pushBy :: Pattern Time -> Pattern a -> Pattern a
pushBy :: forall a. Pattern Time -> Pattern a -> Pattern a
pushBy = Pattern Time -> Pattern a -> Pattern a
forall a. Pattern Time -> Pattern a -> Pattern a
(~>)

-- | Random per-event velocity jitter, for a less mechanical feel. The argument
-- scales the spread: @humanise 1@ varies @amp@ by up to ±0.09. The value
-- is centred on ZERO — combine with @|+@ (\"|+ humanise 0.2\"), never
-- @#@, which would replace the amp instead of jittering it.
humanise :: Double -> Pattern ValueMap
humanise :: Double -> Pattern ValueMap
humanise Double
x = String -> Pattern Double -> Pattern ValueMap
pF String
"amp" (Pattern Double
-> Pattern Double -> Pattern Double -> Pattern Double
forall a. Num a => Pattern a -> Pattern a -> Pattern a -> Pattern a
range (Double -> Pattern Double
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (-Double
0.09 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x)) (Double -> Pattern Double
forall a. a -> Pattern a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double
0.09 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
x)) Pattern Double
forall a. Fractional a => Pattern a
rand)

-- | Ensure every event is an onset by aligning whole start with part start,
-- but only at cycle boundaries. Prevents TidalCycles' onset detection from
-- filtering events in cat constructions where inner patterns have period > 1
-- cycle, without causing MIDI flood from sub-cycle queries.
onset :: Pattern a -> Pattern a
onset :: forall a. Pattern a -> Pattern a
onset Pattern a
pat = Pattern a
pat {query = q, pureValue = Nothing}
  where
    q :: State -> [EventF (ArcF Time) a]
q State
st = (EventF (ArcF Time) a -> EventF (ArcF Time) a)
-> [EventF (ArcF Time) a] -> [EventF (ArcF Time) a]
forall a b. (a -> b) -> [a] -> [b]
map EventF (ArcF Time) a -> EventF (ArcF Time) a
forall {b}. EventF (ArcF Time) b -> EventF (ArcF Time) b
align (Pattern a -> State -> [EventF (ArcF Time) a]
forall a. Pattern a -> State -> [Event a]
query Pattern a
pat State
st)
    align :: EventF (ArcF Time) b -> EventF (ArcF Time) b
align EventF (ArcF Time) b
ev = case EventF (ArcF Time) b -> Maybe (ArcF Time)
forall a b. EventF a b -> Maybe a
whole EventF (ArcF Time) b
ev of
      Maybe (ArcF Time)
Nothing -> EventF (ArcF Time) b
ev
      Just (Arc Time
_ Time
we) ->
        let ps :: Time
ps = ArcF Time -> Time
forall a. ArcF a -> a
start (EventF (ArcF Time) b -> ArcF Time
forall a b. EventF a b -> a
part EventF (ArcF Time) b
ev)
        in if Time
ps Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time -> Time
sam Time
ps
           then EventF (ArcF Time) b
ev {whole = Just (Arc ps (min we (nextSam ps)))}
           else EventF (ArcF Time) b
ev


-- | Note-length constants, as fractions of a cycle: @1\/64@, @1\/32@, @1\/16@,
-- @1\/8@, @1\/4@ and @1\/2@ respectively. Useful as arguments to 'pullBy' and
-- 'pushBy', where a named length reads better than a bare fraction.
hemidemisemiquaver, demisemiquaver, semiquaver, quaver, crotchet, minim :: Time
hemidemisemiquaver :: Time
hemidemisemiquaver = Time
1Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/Time
64
demisemiquaver :: Time
demisemiquaver = Time
1Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/Time
32
semiquaver :: Time
semiquaver = Time
1Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/Time
16
quaver :: Time
quaver = Time
1Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/Time
8
crotchet :: Time
crotchet = Time
1Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/Time
4
minim :: Time
minim = Time
1Time -> Time -> Time
forall a. Fractional a => a -> a -> a
/Time
2

-- | Swing by musical PROPORTION: @0.5@ is straight, @0.667@ triplet. Places
-- the swung note at exactly that proportion of its subdivision.
--
-- One cycle is one beat here, so 'swing8' swings eighth-notes (the \"&\") and
-- 'swing16' swings sixteenths (the \"e\"\/\"a\"). Jazz eighth-feel —
-- spang-a-lang, offbeat eighths — takes 'swing8'; a sixteenth shuffle (funk,
-- UK garage, house, phonk, fusion) takes 'swing16'.
--
-- @f = swing8 0.6@
swing8, swing16 :: Pattern Time -> Pattern a -> Pattern a
swing8 :: forall a. Pattern Time -> Pattern a -> Pattern a
swing8  Pattern Time
x = Pattern Time -> Pattern Time -> Pattern a -> Pattern a
forall a. Pattern Time -> Pattern Time -> Pattern a -> Pattern a
swingBy (Pattern Time
x Pattern Time -> Pattern Time -> Pattern Time
forall a. Num a => a -> a -> a
- Pattern Time
0.5) Pattern Time
1
swing16 :: forall a. Pattern Time -> Pattern a -> Pattern a
swing16 Pattern Time
x = Pattern Time -> Pattern Time -> Pattern a -> Pattern a
forall a. Pattern Time -> Pattern Time -> Pattern a -> Pattern a
swingBy (Pattern Time
x Pattern Time -> Pattern Time -> Pattern Time
forall a. Num a => a -> a -> a
- Pattern Time
0.5) Pattern Time
2

-- | Step through a list under a 0-1 control signal: the signal's range is
-- divided evenly among the elements, so a knob sweeps through them in order.
-- An empty list is silence.
--
-- @, over qlink1 [flow, grid, lite]@
over :: Pattern Double -> [a] -> Pattern a
over :: forall a. Pattern Double -> [a] -> Pattern a
over Pattern Double
_ [] = Pattern a
forall a. Pattern a
silence
over Pattern Double
ctrl [a]
xs =
  let count :: Int
count = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs
      step :: Double
step  = Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
count
  in (Double -> a) -> Pattern Double -> Pattern a
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Double
x -> [a]
xs [a] -> Int -> a
forall a. HasCallStack => [a] -> Int -> a
!! Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) (Double
x Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
step)))) Pattern Double
ctrl

-- | Operator form of 'over'.
(-->) :: Pattern Double -> [a] -> Pattern a
--> :: forall a. Pattern Double -> [a] -> Pattern a
(-->) = Pattern Double -> [a] -> Pattern a
forall a. Pattern Double -> [a] -> Pattern a
over

-- | A boolean gate whose density wanders between two step counts, via
-- 'binary' over a random integer in @[lo, hi)@.
binaryrange :: Pattern Int -> Pattern Int -> Pattern Bool
binaryrange :: Pattern Int -> Pattern Int -> Pattern Bool
binaryrange Pattern Int
lo Pattern Int
hi = Pattern Int -> Pattern Bool
binary (Pattern Int -> Pattern Bool) -> Pattern Int -> Pattern Bool
forall a b. (a -> b) -> a -> b
$ Pattern Int
lo Pattern Int -> Pattern Int -> Pattern Int
forall a. Num a => Pattern a -> Pattern a -> Pattern a
|+ Pattern Int -> Pattern Int
forall a. Num a => Pattern Int -> Pattern a
irand (Pattern Int
hi Pattern Int -> Pattern Int -> Pattern Int
forall a. Num a => a -> a -> a
- Pattern Int
lo)

-- | A ducking gain envelope — a ghost sidechain. Every onset of the struct
-- pattern drops the gain to @1 - depth@, which then recovers to @1@ over the
-- release @rls@. A cycle is a beat here (@cps = bpm\/60@), so @rls@ reads
-- directly in beats: @1@ is one beat, @0.25@ a quarter of one.
--
-- @depth@ is @0@ for no duck, @1@ to duck to silence, and is a pattern, so it
-- can ride an LFO or the form.
--
-- The result is a 'Pattern Double' meant to drive a gain control. It belongs
-- BESIDE the notes as its own element in a stack, never applied to them:
--
-- @, s1pump \"1 0 0 0\" 0.6 0.75 # o@
--
-- Applying it to a note pattern with @|*@, @*|@ or @#@ splits every note once
-- per overlapping envelope step — a held note re-triggers sixteen times, and
-- drums double-trigger. A hand-written gain pattern coarser than, and aligned
-- to, the note grid (@|* vel \"0.45 1 0.8 1\"@) is the way to duck note
-- velocities.
--
-- An @rls@ longer than the gap to the next onset interleaves two envelopes: the
-- older tail\'s recovered values arrive after the new duck and cancel it.
-- Nothing clamps this.
pump :: Pattern Bool -> Pattern Double -> Double -> Pattern Double
pump :: Pattern Bool -> Pattern Double -> Double -> Pattern Double
pump Pattern Bool
st Pattern Double
depth Double
rls =
    [Pattern Double] -> Pattern Double
forall a. [Pattern a] -> Pattern a
stack [ Time -> Pattern Double -> Pattern Double
forall a. Time -> Pattern a -> Pattern a
rotR (Double -> Time
forall a. Real a => a -> Time
toRational (Double
rls 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 -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
steps))
                 (Pattern Bool -> Pattern Double -> Pattern Double
forall a. Pattern Bool -> Pattern a -> Pattern a
struct Pattern Bool
st ((Double -> Double) -> Pattern Double -> Pattern Double
forall a b. (a -> b) -> Pattern a -> Pattern b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Double -> Double
forall {a}. Floating a => Int -> a -> a
gainAt Int
i) Pattern Double
depth))
          | Int
i <- [Int
0 .. Int
steps] ]
  where
    -- 16 steps is a smooth ramp at roughly 31 CC/s per ducked beat at 118bpm,
    -- against a DIN budget of about 1000.
    steps :: Int
steps = Int
16 :: Int
    gainAt :: Int -> a -> a
gainAt Int
i a
dp
      | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
steps = a
1                        -- land exactly recovered
      | Bool
otherwise  = a
1 a -> a -> a
forall a. Num a => a -> a -> a
- a
dp a -> a -> a
forall a. Num a => a -> a -> a
* a -> a
forall a. Floating a => a -> a
exp (-a
4.5 a -> a -> a
forall a. Num a => a -> a -> a
* Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i a -> a -> a
forall a. Fractional a => a -> a -> a
/ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
steps)

-- | Monophonic with latest-note priority: each event's whole is truncated at
-- the next onset in the pattern, so a new note always starts on time and stops
-- the one before it — a string being re-fingered, not a queue. Tidal's own
-- 'mono' is the opposite (first-note priority: a later overlapping event is
-- delayed or dropped). Simultaneous onsets keep only the first. Legato scales
-- the truncated whole, so @# legato 1@ rings exactly to the next note, @< 1@
-- leaves a gap, and cranking legato above 1 is unnecessary. Continuous
-- (whole-less) events pass through untouched.
mono' :: Pattern a -> Pattern a
mono' :: forall a. Pattern a -> Pattern a
mono' 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 = f, steps = Nothing, pureValue = Nothing }
  where
    look :: Time
look = Time
8 :: Time
    onsetOf :: Event a -> Time
onsetOf = ArcF Time -> Time
forall a. ArcF a -> a
start (ArcF Time -> Time) -> (Event a -> ArcF Time) -> Event a -> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event a -> ArcF Time
forall a. Event a -> ArcF Time
wholeOrPart
    f :: State -> [EventF (ArcF Time) a]
f State
st =
      let a :: ArcF Time
a    = State -> ArcF Time
arc State
st
          c0 :: Time
c0   = Time -> Time
sam (ArcF Time -> Time
forall a. ArcF a -> a
start ArcF Time
a)
          wide :: [EventF (ArcF Time) a]
wide = Pattern a -> State -> [EventF (ArcF Time) a]
forall a. Pattern a -> State -> [Event a]
query Pattern a
pat State
st { arc = Arc (c0 - look) (c0 + look + 1) }
          -- Every discrete event in the window, ordered by onset, one per onset.
          uniq :: [EventF (ArcF Time) a]
uniq = [EventF (ArcF Time) a] -> [EventF (ArcF Time) a]
forall {a}. [Event a] -> [Event a]
dedupe ((EventF (ArcF Time) a -> Time)
-> [EventF (ArcF Time) a] -> [EventF (ArcF Time) a]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn EventF (ArcF Time) a -> Time
forall {a}. Event a -> Time
onsetOf [ EventF (ArcF Time) a
e | EventF (ArcF Time) a
e <- [EventF (ArcF Time) a]
wide, EventF (ArcF Time) a -> Maybe (ArcF Time)
forall a b. EventF a b -> Maybe a
whole EventF (ArcF Time) a
e Maybe (ArcF Time) -> Maybe (ArcF Time) -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe (ArcF Time)
forall a. Maybe a
Nothing ])
          onsets :: [Time]
onsets = (EventF (ArcF Time) a -> Time) -> [EventF (ArcF Time) a] -> [Time]
forall a b. (a -> b) -> [a] -> [b]
map EventF (ArcF Time) a -> Time
forall {a}. Event a -> Time
onsetOf [EventF (ArcF Time) a]
uniq
          nextAfter :: Time -> Maybe Time
nextAfter Time
s0 = case (Time -> Bool) -> [Time] -> [Time]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<= Time
s0) [Time]
onsets of
                           (Time
x:[Time]
_) -> Time -> Maybe Time
forall a. a -> Maybe a
Just Time
x
                           []    -> Maybe Time
forall a. Maybe a
Nothing
          build :: Event b -> Maybe (Event b)
build Event b
ev =
            let w :: ArcF Time
w  = Event b -> ArcF Time
forall a. Event a -> ArcF Time
wholeOrPart Event b
ev
                s0 :: Time
s0 = ArcF Time -> Time
forall a. ArcF a -> a
start ArcF Time
w
                w' :: ArcF Time
w' = Time -> Time -> ArcF Time
forall a. a -> a -> ArcF a
Arc Time
s0 (Time -> (Time -> Time) -> Maybe Time -> Time
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ArcF Time -> Time
forall a. ArcF a -> a
stop ArcF Time
w) (Time -> Time -> Time
forall a. Ord a => a -> a -> a
min (ArcF Time -> Time
forall a. ArcF a -> a
stop ArcF Time
w)) (Time -> Maybe Time
nextAfter Time
s0))
            in (\ArcF Time
pt -> Event b
ev { whole = Just w', part = pt }) (ArcF Time -> Event b) -> Maybe (ArcF Time) -> Maybe (Event b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArcF Time -> ArcF Time -> Maybe (ArcF Time)
subArc ArcF Time
a ArcF Time
w'
          analog :: [EventF (ArcF Time) a]
analog = [ EventF (ArcF Time) a
e | EventF (ArcF Time) a
e <- Pattern a -> State -> [EventF (ArcF Time) a]
forall a. Pattern a -> State -> [Event a]
query Pattern a
pat State
st, EventF (ArcF Time) a -> Maybe (ArcF Time)
forall a b. EventF a b -> Maybe a
whole EventF (ArcF Time) a
e Maybe (ArcF Time) -> Maybe (ArcF Time) -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe (ArcF Time)
forall a. Maybe a
Nothing ]
      in (EventF (ArcF Time) a -> Maybe (EventF (ArcF Time) a))
-> [EventF (ArcF Time) a] -> [EventF (ArcF Time) a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe EventF (ArcF Time) a -> Maybe (EventF (ArcF Time) a)
forall {b}. Event b -> Maybe (Event b)
build [EventF (ArcF Time) a]
uniq [EventF (ArcF Time) a]
-> [EventF (ArcF Time) a] -> [EventF (ArcF Time) a]
forall a. [a] -> [a] -> [a]
++ [EventF (ArcF Time) a]
analog
    dedupe :: [Event a] -> [Event a]
dedupe [] = []
    dedupe (Event a
e:[Event a]
es) = Event a
e Event a -> [Event a] -> [Event a]
forall a. a -> [a] -> [a]
: [Event a] -> [Event a]
dedupe ((Event a -> Bool) -> [Event a] -> [Event a]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Event a -> Time
forall {a}. Event a -> Time
onsetOf Event a
e) (Time -> Bool) -> (Event a -> Time) -> Event a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event a -> Time
forall {a}. Event a -> Time
onsetOf) [Event a]
es)

-- | Alias for 'mono'': a new note re-triggers the voice.
retrig :: Pattern a -> Pattern a
retrig :: forall a. Pattern a -> Pattern a
retrig = Pattern a -> Pattern a
forall a. Pattern a -> Pattern a
mono'