Modulate.hs

{-# LANGUAGE BangPatterns #-}

module Zwirn.Core.Modulate where

{-
    Modulate.hs - functions modulating time
    Copyright (C) 2025, Martin Gius

    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 Control.Applicative
import Control.Monad (join)
import Control.Monad.Identity
import Data.Bifunctor
import Data.Fixed (mod')
import Data.Functor (void)
import Music.Theory.Bjorklund (bjorklund, iseq)
import Zwirn.Core.Core
import Zwirn.Core.Time
import Zwirn.Core.Tree
import Zwirn.Core.Types

modulateTime :: (a -> Time -> st -> Time) -> a -> ZwirnT k st i b -> ZwirnT k st i b
modulateTime f x b = zwirn (\t st -> unzwirn b (f x t st) st)

rev :: ZwirnT k st i a -> ZwirnT k st i a
rev = modulateTime (\_ t _ -> -t) ()

revBy :: (Monad k) => ZwirnT k st i Time -> ZwirnT k st i a -> ZwirnT k st i a
revBy tz x = modulateTime (\x t _ -> fromIntegral (floor x) + t - frac x) <$> tz <$$> x

sini :: ZwirnT k st i a -> ZwirnT k st i a
sini = modulateTime (\_ t _ -> sin (2 * pi * t)) ()

fast :: (Monad k) => ZwirnT k st i Time -> ZwirnT k st i a -> ZwirnT k st i a
fast tz x = modulateTime (\x t _ -> t * x) <$> tz <$$> x

slow :: (Monad k) => ZwirnT k st i Time -> ZwirnT k st i a -> ZwirnT k st i a
slow tz x = modulateTime timefunc <$> tz <$$> x
  where
    timefunc x t _
      | x == 0 = 0
      | otherwise = t / x

shift :: (Monad k) => ZwirnT k st i Time -> ZwirnT k st i a -> ZwirnT k st i a
shift tz x = modulateTime (\x t _ -> t - x) <$> tz <$$> x

ply :: (MultiMonad k) => ZwirnT k st i Time -> ZwirnT k st i a -> ZwirnT k st i a
ply tz = squeezeMap (fast tz)

zoom :: (Monad k) => ZwirnT k st i Time -> ZwirnT k st i Time -> ZwirnT k st i a -> ZwirnT k st i a
zoom t1 t2 x = modulateTime timefunc <$> tup <$$> x
  where
    tup = liftA2 (,) t1 t2
    timefunc (st, en) t _
      | en > st = mod' t (en - st) + st
      | en == st = 0
      | en < st = st - mod' t (st - en)

timeloop :: (Monad k) => ZwirnT k st i Time -> ZwirnT k st i a -> ZwirnT k st i a
timeloop = zoom (pure 0)

loopfirst :: (Monad k) => ZwirnT k st i a -> ZwirnT k st i a
loopfirst = timeloop (pure 1)

fastcat :: (HasSilence k) => [ZwirnT k st i a] -> ZwirnT k st i a
fastcat [] = silence
fastcat obj = zwirn q
  where
    q t = unzwirn item phase
      where
        metre = fromIntegral $ length obj
        scaledPhase = t * metre
        item = nth scaledPhase obj
        cyc = floor t
        phase = frac scaledPhase + fromIntegral cyc

slowcat :: (HasSilence k, Monad k) => [ZwirnT k st i a] -> ZwirnT k st i a
slowcat zs = slow (pure $ fromIntegral $ length zs) $ fastcat zs

-- | each (t,p) indicates the amount of time t for pattern p relative
-- | to the other lengths in the list, squeezed within one cycle
timecat :: (HasSilence k, Monad k) => [(Time, ZwirnT k st i a)] -> ZwirnT k st i a
timecat tps = if total == 0 then silence else cyclecat normalised
  where
    total = sum $ map fst tps
    normalised = map (\(t, p) -> (t / total, p)) tps

-- | each (t,p) indicates the amount of time t the pattern p is queried for
-- | the patterns in the list will be queried in order by their respective amounts
-- | Example: cyclecat [(1,pure 10), (2, slow 2 $ pure 20)] == < 10 20 ~ >
-- | Note: also works with rational numbers
cyclecat :: (HasSilence k) => [(Time, ZwirnT k st i a)] -> ZwirnT k st i a
cyclecat [] = silence
cyclecat xs = cyclecatrec xs (sum $ map fst xs)
  where
    -- len = sum $ map fst xs
    cyclecatrec [(_, p)] _ = p
    cyclecatrec (x : xs) !tot = cat x (tot - fst x, cyclecatrec xs (tot - fst x))

cat :: (HasSilence k) => (Time, ZwirnT k st i a) -> (Time, ZwirnT k st i a) -> ZwirnT k st i a
cat (Time 0 _, _) (Time 0 _, _) = silence
cat (t1, p1) (t2, p2) = zwirn q
  where
    q t = unzwirn item phase
      where
        total = t1 + t2
        cyc = t / total
        first = frac cyc < t1 / total
        item = if first then p1 else p2
        phase = if first then t - fromIntegral (floor cyc) * t2 else t - (fromIntegral (floor cyc) + 1) * t1

fastcyclecat :: (HasSilence k, Monad k) => [(Time, ZwirnT k st i a)] -> ZwirnT k st i a
fastcyclecat xs = cyclecat $ map (\(t, x) -> (t, slow (pure t) x)) xs