Modulate.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeApplications #-}

module Zwirn.Core.Lib.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 Data.Fixed (mod')
import Data.Foldable (Foldable (..), foldl')
import Zwirn.Core.Core
import Zwirn.Core.Lib.Core
import Zwirn.Core.Time
import Zwirn.Core.Tree
import Zwirn.Core.Types
import Prelude hiding (Foldable (..))

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 (\y t _ -> fromIntegral @Int (floor y) + t - frac y) <$> tz) `innerApply` 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 (\y t _ -> t * y) <$> tz) `innerApply` 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) `innerApply` x
  where
    timefunc y t _
      | y == 0 = 0
      | otherwise = t / y

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

ply :: (MultiMonad k) => ZwirnT k st i Time -> ZwirnT k st i a -> ZwirnT k st i a
ply tz = apply (matchApply ply' tz)
  where
    ply' = pure $ \t -> pure $ \x -> squeezeMap (fast t) x

bump :: (MultiMonad k) => ZwirnT k st i Time -> ZwirnT k st i a -> ZwirnT k st i a
bump tz = apply (matchApply bump' tz)
  where
    bump' = pure $ \t -> pure $ \x -> squeezeMap (shift t) x

-- zoom into a specific region of time, while preserving the speed
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) `innerApply` x
  where
    tup = liftA2 (,) t1 t2
    timefunc (st, en) t _
      | en > st = mod' (t * (en - st)) (en - st) + st
      | en == st = st
      | otherwise = st - mod' (t * (st - en)) (st - en)

-- loop a specific region of time, the shorter the region, the faster it gets
loop :: (Monad k) => ZwirnT k st i Time -> ZwirnT k st i Time -> ZwirnT k st i a -> ZwirnT k st i a
loop t1 t2 x = (modulateTime timefunc <$> tup) `innerApply` x
  where
    tup = liftA2 (,) t1 t2
    timefunc (st, en) t _
      | en > st = mod' t (en - st) + st
      | en == st = st
      | otherwise = st - mod' t (st - en)

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

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

ribbon :: (Monad k) => ZwirnT k st i Time -> ZwirnT k st i Time -> ZwirnT k st i a -> ZwirnT k st i a
ribbon off len = loop off (liftA2 (+) off len)

swingBy :: (Monad k) => ZwirnT k st i Time -> ZwirnT k st i Time -> ZwirnT k st i a -> ZwirnT k st i a
swingBy t1 t2 x = (modulateTime timefunc <$> tup) `innerApply` x
  where
    tup = liftA2 (,) t1 t2
    timefunc (sh, segs) t _
      | odd (floor $ frac t * segs * 2 :: Int) = t - (sh / (segs * 2))
      | segs == 0 = 0
      | otherwise = t

----------------------------------------------
------------------ cats ----------------------
----------------------------------------------

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
        cy = floor t
        phase = frac scaledPhase + fromIntegral @Int cy

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, slow (pure $ 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 [] _ = silence
    cyclecatrec [(_, p)] _ = p
    cyclecatrec (x : ys) !tot = cat x (tot - fst x, cyclecatrec ys (tot - fst x))

cat :: (HasSilence k) => (Time, ZwirnT k st i a) -> (Time, ZwirnT k st i a) -> ZwirnT k st i a
cat (t1, p1) (t2, p2) = if total == 0 then silence else zwirn q
  where
    total = t1 + t2
    q t = unzwirn item phase
      where
        cy = t / total
        first = frac cy < t1 / total
        item = if first then p1 else p2
        phase = if first then t - fromIntegral @Int (floor cy) * t2 else t - (fromIntegral @Int (floor cy) + 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

catpat :: (MultiMonad k, HasSilence k) => (ZwirnT k st i Time, ZwirnT k st i a) -> (ZwirnT k st i Time, ZwirnT k st i a) -> ZwirnT k st i a
catpat (t1z, p1) (t2z, p2) = innerJoin $ liftA2 (\t1 t2 -> cat (t1, p1) (t2, p2)) t1z t2z

cyclecatpat :: (MultiMonad k, HasSilence k) => [(ZwirnT k st i Time, ZwirnT k st i a)] -> ZwirnT k st i a
cyclecatpat [] = silence
cyclecatpat xs = cyclecatrec xs (foldl' (liftA2 (+)) (pure 0) $ map fst xs)
  where
    cyclecatrec [] _ = silence
    cyclecatrec [(_, p)] _ = p
    cyclecatrec (x : ys) !tot = catpat x (newTot, cyclecatrec ys newTot)
      where
        newTot = liftA2 (-) tot (fst x)

fastcyclecatpat :: (MultiMonad k, HasSilence k) => [(ZwirnT k st i Time, ZwirnT k st i a)] -> ZwirnT k st i a
fastcyclecatpat xs = cyclecatpat $ map (\(t, x) -> (t, slow t x)) xs