Core.hs

module Zwirn.Core.Core where

{-
    Core.hs - core functions and instances
    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.Time
import Zwirn.Core.Tree
import Zwirn.Core.Types

-- | indicates the current time
now :: (Applicative k) => ZwirnT k st i Time
now = zwirn $ \t st -> pure (Value t t [], st)

-- | indicates the current cycle
cyc :: (Applicative k) => ZwirnT k st i Int
cyc = fmap floor now

-- higher level helper functions

withInner :: (k (Value i a, st) -> k (Value i b, st)) -> ZwirnT k st i a -> ZwirnT k st i b
withInner f x = zwirn $ \t st -> f $ unzwirn x t st

withInnerAndTime :: (Time -> k (Value i a, st) -> k (Value i b, st)) -> ZwirnT k st i a -> ZwirnT k st i b
withInnerAndTime f x = zwirn $ \t st -> f t (unzwirn x t st)

withInnerTimeState :: (Time -> st -> k (Value i a, st) -> k (Value i b, st)) -> ZwirnT k st i a -> ZwirnT k st i b
withInnerTimeState f x = zwirn $ \t st -> f t st (unzwirn x t st)

withInner2 :: (k (Value i a, st) -> k (Value i b, st) -> k (Value i c, st)) -> ZwirnT k st i a -> ZwirnT k st i b -> ZwirnT k st i c
withInner2 f x y = zwirn $ \t st -> f (unzwirn x t st) (unzwirn y t st)

withValueState :: (Functor k) => ((Value i a, st) -> (Value i b, st)) -> ZwirnT k st i a -> ZwirnT k st i b
withValueState f = withInner (fmap f)

withValue :: (Functor k) => (Value i a -> Value i b) -> ZwirnT k st i a -> ZwirnT k st i b
withValue f = withValueState (first f)

withA :: (Functor k) => (a -> a) -> ZwirnT k st i a -> ZwirnT k st i a
withA f = withValue (\v -> v {value = f $ value v})

withTime :: (Functor k) => (Time -> Time) -> ZwirnT k st i a -> ZwirnT k st i a
withTime f = withValue (\v -> v {time = f $ time v})

withInfo :: (Functor k) => (i -> i) -> ZwirnT k st i a -> ZwirnT k st i a
withInfo f = withValue (\v -> v {info = f <$> info v})

withInfos :: (Functor k) => ([i] -> [i]) -> ZwirnT k st i a -> ZwirnT k st i a
withInfos f = withValue (\v -> v {info = f $ info v})

addInfo :: (Functor k) => i -> ZwirnT k st i a -> ZwirnT k st i a
addInfo i = withInfos (const [i])

removeInfo :: (Functor k) => ZwirnT k st i a -> ZwirnT k st i a
removeInfo = withInfos (const [])

withState :: (Functor k) => (st -> st) -> ZwirnT k st i a -> ZwirnT k st i a
withState f = withValueState (second f)

fromSignal :: (Applicative k) => (Time -> Time) -> ZwirnT k st i Time
fromSignal f = f <$> now

getInner :: (Functor k) => ZwirnT k st i a -> ZwirnT k st i Time
getInner = withValue (\v -> v {value = time v})

-- instances

-- | just lifts, only operates on the values
instance (Semigroup a, Applicative k) => Semigroup (ZwirnT k st i a) where
  (<>) = liftA2 (<>)

instance (Monoid a, Applicative k) => Monoid (ZwirnT k st i a) where
  mempty = pure mempty

instance (Functor k) => Functor (ZwirnT k st i) where
  fmap f = withInner (fmap $ first (fmap f))

instance (Applicative k) => Applicative (ZwirnT k st i) where
  pure x = zwirn $ \t st -> pure (Value x t [], st)
  liftA2 f = withInner2 (liftA2 (\(v1, st1) (v2, _) -> (liftA2 f v1 v2, st1)))

instance (MultiApplicative k) => MultiApplicative (ZwirnT k st i) where
  liftA2Left f = withInner2 (liftA2Left (\(v1, st1) (v2, _) -> (liftA2Left f v1 v2, st1)))
  liftA2Right f = withInner2 (liftA2Right (\(v1, st1) (v2, _) -> (liftA2Right f v1 v2, st1)))

instance (Monad k) => Monad (ZwirnT k st i) where
  (>>=) x f = innerJoin $ fmap f x
    where
      innerJoin pp = zwirn q
        where
          q t st = (\(z, st') -> first (mergeInfo (info z)) <$> unzwirn (value z) t st') =<< outer
            where
              outer = unzwirn pp t st
              mergeInfo i v = v {info = info v ++ i}

instance (MultiMonad k) => MultiMonad (ZwirnT k st i) where
  outerJoin pp = zwirn q
    where
      q t st = outerJoin $ (\(z, st') -> first (\v -> v {time = time z, info = info v ++ info z}) <$> unzwirn (value z) t st') <$> outer
        where
          outer = unzwirn pp t st

  squeezeJoin pp = zwirn q
    where
      q t st = squeezeJoin $ (\(z, st') -> first (mergeInfo (info z)) <$> unzwirn (value z) (time z) st') <$> outer
        where
          outer = unzwirn pp t st
          mergeInfo i v = v {info = info v ++ i}

outerApply :: (MultiMonad m) => m (m a -> m b) -> m a -> m b
outerApply f x = outerJoin $ f <*> pure x

innerApply :: (Monad m) => m (m a -> m b) -> m a -> m b
innerApply f x = join $ f <*> pure x

squeezeApply :: (MultiMonad m) => m (m a -> m b) -> m a -> m b
squeezeApply f x = squeezeJoin $ f <*> pure x

zipApply :: (MultiMonad k) => ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i b) -> ZwirnT k st i a -> ZwirnT k st i b
zipApply fs x = zwirn q
  where
    q t st = innerJoin $ (\c -> unzwirn c t st) . ($ x) . value . fst <$> unzwirn fs t st

squeezeMap :: (MultiMonad m) => (m a -> m b) -> m a -> m b
squeezeMap f x = squeezeJoin $ fmap (f . pure) x

mapZ :: (MultiMonad m) => m (m a -> m b) -> m a -> m b
mapZ fp xp = squeezeJoin $ fmap (squeezeApply fp . pure) xp

infixl 4 <$$>

(<$$>) :: (Monad m) => m (m a -> m b) -> m a -> m b
(<$$>) = innerApply

enumerateFromByTo :: (Ord a, Num a) => a -> a -> a -> [a]
enumerateFromByTo x y z
  | y <= 0 = []
  | x < z = if z < x + y then [x] else x : enumerateFromByTo (x + y) y z
  | otherwise = if z > x - y then [x] else x : enumerateFromByTo (x - y) y z

enumerateFromThenTo :: (Ord a, Num a) => a -> a -> a -> [a]
enumerateFromThenTo x y
  | x < y = enumerateFromByTo x (y - x)
  | x > y = enumerateFromByTo x (x - y)

enumerateFromTo :: (Ord a, Num a) => a -> a -> [a]
enumerateFromTo x = enumerateFromByTo x 1