Structure.hs

{-# OPTIONS_GHC -Wno-type-defaults #-}
{-# HLINT ignore "Use tuple-section" #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

module Zwirn.Core.Lib.Structure where

{-
    Structure.hs - functions manipulating the 'structure' of signals
    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 Data.List (mapAccumL)
import Music.Theory.Bjorklund (bjorklund, iseq)
import Numeric (showIntAtBase)
import Text.ParserCombinators.ReadP
import Zwirn.Core.Core
import Zwirn.Core.Lib.Core
import Zwirn.Core.Lib.Modulate
import Zwirn.Core.Time
import Zwirn.Core.Tree hiding (concat)
import Zwirn.Core.Types
import Prelude hiding (enumFromTo)

runFromTo :: (Ord a, Num a, Monad k, HasSilence k) => ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a
runFromTo xz yz = join $ en <$> xz <*> yz
  where
    en x y = fastcat $ map pure $ enumerateFromTo x y

runFromThenTo :: (Ord a, Num a, Monad k, HasSilence k) => ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a
runFromThenTo xz yz zz = join $ en <$> xz <*> yz <*> zz
  where
    en x y z = fastcat $ map pure $ enumerateFromThenTo x y z

slowrunFromTo :: (Ord a, Num a, Monad k, HasSilence k) => ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a
slowrunFromTo xz yz = join $ en <$> xz <*> yz
  where
    en x y = slowcat $ map pure $ enumerateFromTo x y

slowrunFromThenTo :: (Ord a, Num a, Monad k, HasSilence k) => ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a
slowrunFromThenTo xz yz zz = join $ en <$> xz <*> yz <*> zz
  where
    en x y z = slowcat $ map pure $ enumerateFromThenTo x y z

run :: (Monad k, HasSilence k) => ZwirnT k st i Int -> ZwirnT k st i Int
run = runFromTo (pure 0)

slowrun :: (Monad k, HasSilence k) => ZwirnT k st i Int -> ZwirnT k st i Int
slowrun = slowrunFromTo (pure 0)

sampleAndHold :: (MultiMonad k, HasSilence k) => ZwirnT k st i Int -> ZwirnT k st i a -> ZwirnT k st i a
sampleAndHold iz az = segment iz $ innerJoin $ sampleAndHold' <$> iz
  where
    sampleAndHold' i
      | i <= 0 = silence
      | otherwise = zwirn q
      where
        q t = unzwirn az (fromIntegral (floor $ tTime t * fromIntegral i) / fromIntegral i)

-- struct combines the inner time (structure) of the first argument with the values of the second one
-- this function does not 'sample and hold' like in tidal/strudel
struct :: (MultiMonad k) => ZwirnT k st i a -> ZwirnT k st i b -> ZwirnT k st i b
struct = withInner2 (liftA2Both f)
  where
    f (v1, st) (v2, _) = (Value (value v2) (time v1) (info v1), st)

segment :: (MultiMonad k, HasSilence k) => ZwirnT k st i Int -> ZwirnT k st i a -> ZwirnT k st i a
segment = struct . run

euclidOff :: (HasSilence k, Monad k) => ZwirnT k st i Int -> ZwirnT k st i Int -> ZwirnT k st i Int -> ZwirnT k st i a -> ZwirnT k st i a
euclidOff i1 i2 i3 x = (euclidOff' <$> i1 <*> i2 <*> i3) `innerApply` x
  where
    euclidOff' a b off y = timecat $ map (\i -> (fromIntegral i :: Time, y)) ts
      where
        ts = rot off $ iseq $ bjorklund (a, b)
        rot n xs = take lxs . drop ((-n) `mod` lxs) . cycle $ xs where lxs = length xs

euclid :: (HasSilence k, Monad k) => ZwirnT k st i Int -> ZwirnT k st i Int -> ZwirnT k st i a -> ZwirnT k st i a
euclid x y = euclidOff x y (pure 0)

left :: (MultiMonad k) => (ZwirnT k st i a -> ZwirnT k st i b -> ZwirnT k st i c) -> ZwirnT k st i a -> ZwirnT k st i b -> ZwirnT k st i c
left f x y = struct x $ f x y

right :: (MultiMonad k) => (ZwirnT k st i a -> ZwirnT k st i b -> ZwirnT k st i c) -> ZwirnT k st i a -> ZwirnT k st i b -> ZwirnT k st i c
right f x y = struct y $ f x y

euclidean :: (Applicative k) => ZwirnT k st i Int -> ZwirnT k st i Int -> ZwirnT k st i Int -> ZwirnT k st i String
euclidean i1 i2 i3 = euclidean' <$> i1 <*> i2 <*> i3
  where
    euclidean' off a b = map toChar $ rotateList off $ bjorklund (a, b)
    toChar True = '1'
    toChar False = '0'

-------------------------------------------
----------- chunking notation -------------
-------------------------------------------

-- see Computational Models of Rhythm and Meter by Georg Boenn
-- nested chunks via [...]
-- they will occupy one unit (i.e. one eighth by default) with their duration subdived by the amount of steps within
-- example: [i] == eight triplet, [~!] == rhythm in quintuplets etc.

type Sequence = Tree Bool

singleChunk :: Char -> [Bool]
singleChunk '~' = [False]
singleChunk '.' = [True]
singleChunk '0' = [False]
singleChunk '1' = [True]
singleChunk 'I' = [True, False]
singleChunk ':' = [True, True]
singleChunk 'v' = [False, True]
singleChunk '-' = [True, False, False]
singleChunk '<' = [False, True, False]
singleChunk 'w' = [False, False, True]
singleChunk 'X' = [True, True, False]
singleChunk '>' = [True, False, True]
singleChunk '+' = [False, True, True]
singleChunk 'i' = [True, True, True]
singleChunk 'H' = [True, False, False, False]
singleChunk '!' = [True, True, False, False]
singleChunk _ = []

pChunk :: ReadP [Sequence]
pChunk = do
  c <- get
  if c == '[' then pfail else return $ map Leaf $ singleChunk c

pChunks :: ReadP [Sequence]
pChunks = do
  _ <- char '['
  xs <- manyTill (pChunks +++ pChunk) (char ']')
  return [Branch $ concat xs]

pOuterChunks :: ReadP [Sequence]
pOuterChunks = concat <$> many1 (pChunks +++ pChunk)

runChunk :: String -> Maybe [Sequence]
runChunk s = case map fst $ filter (\(_, x) -> null x) $ readP_to_S pOuterChunks s of
  (x : _) -> Just x
  _ -> Nothing

seqToZwirn :: (HasSilence k, Monad k) => Sequence -> Int -> ZwirnT k st i Int
seqToZwirn t shif = seqToZwirnNum shif $ numberedTreeBool t
  where
    seqToZwirnNum sh (Leaf (i, True)) = pure $ i + sh
    seqToZwirnNum _ (Leaf (_, False)) = silence
    seqToZwirnNum _ (Branch []) = silence
    seqToZwirnNum sh (Branch xs) = fastcyclecat $ map (\x -> (1 / fromIntegral (length xs), seqToZwirnNum sh x)) xs

chunkWith :: (HasSilence k, MultiMonad k) => ZwirnT k st i Double -> ZwirnT k st i String -> ZwirnT k st i Int
chunkWith m s = innerJoin $ fullChunk' <$> m <*> s
  where
    fullChunk' d i = case runChunk i of
      Nothing -> silence
      Just ss -> if d == 0 then silence else fastcyclecat $ snd $ mapAccumL (\k se -> (k + countTrue se, (1 / realToFrac d, seqToZwirn se k))) 0 ss
        where
          countTrue (Leaf False) = 0
          countTrue (Leaf True) = 1
          countTrue (Branch xs) = sum (map countTrue xs)

chunk :: (HasSilence k, MultiMonad k, State k st i) => ZwirnT k st i String -> ZwirnT k st i Int
chunk = chunkWith beatsPerCycle

chunked :: (HasSilence k, MultiMonad k, State k st i) => ZwirnT k st i String -> ZwirnT k st i a -> ZwirnT k st i a
chunked = struct . chunk

binary :: (Applicative k) => ZwirnT k st i Int -> ZwirnT k st i String
binary = fmap (\i -> showIntAtBase 2 sel i "")
  where
    sel 0 = '0'
    sel _ = '1'

christoffelWord :: Int -> Int -> String
christoffelWord m n = snd $ foldl (christoffelWord' m n) (0, "") [1 .. n]
  where
    christoffelWord' :: Int -> Int -> (Int, String) -> Int -> (Int, String)
    christoffelWord' k l (prev, out) i = (y, out ++ "1" ++ bs)
      where
        y = floor $ fromIntegral i * fromIntegral k / fromIntegral l
        test = y - prev
        bs = replicate test '0'

christoffel :: (Applicative k) => ZwirnT k st i Int -> ZwirnT k st i Int -> ZwirnT k st i String
christoffel m n = christoffelWord <$> m <*> n

rotate :: (Applicative k) => ZwirnT k st i Int -> ZwirnT k st i [a] -> ZwirnT k st i [a]
rotate i xs = rotateList <$> i <*> xs

rotateList :: Int -> [a] -> [a]
rotateList n xs = take lxs . drop ((-n) `mod` lxs) . cycle $ xs
  where
    lxs = length xs

neg :: (Applicative k) => ZwirnT k st i String -> ZwirnT k st i String
neg = fmap neg'
  where
    neg' ('0' : xs) = '1' : neg' xs
    neg' ('1' : xs) = '0' : neg' xs
    neg' ('~' : xs) = '.' : neg' xs
    neg' ('.' : xs) = '~' : neg' xs
    neg' ('I' : xs) = 'v' : neg' xs
    neg' ('v' : xs) = 'I' : neg' xs
    neg' (':' : xs) = '~' : '~' : neg' xs
    neg' ('-' : xs) = '+' : neg' xs
    neg' ('+' : xs) = '-' : neg' xs
    neg' ('>' : xs) = '<' : neg' xs
    neg' ('<' : xs) = '>' : neg' xs
    neg' ('w' : xs) = 'X' : neg' xs
    neg' ('X' : xs) = 'w' : neg' xs
    neg' ('i' : xs) = '~' : '~' : '~' : neg' xs
    neg' ('H' : xs) = '~' : 'i' : neg' xs
    neg' ('!' : xs) = '~' : '+' : neg' xs
    neg' ys = ys