Core.hs

{-# OPTIONS_GHC -Wno-orphans #-}

module Zwirn.Core.Lib.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.Monad (join)
import Zwirn.Core.Core as C
import Zwirn.Core.Query
import Zwirn.Core.Time
import Zwirn.Core.Types

-- | indicates the current time
now :: (Applicative k) => ZwirnT k st i Time
now = C.now

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

trig :: (Functor k) => ZwirnT k st i a -> ZwirnT k st i Bool
trig = withValue (\(Value _ t i) -> Value (breakpointCondition 0.005 t) t i)

setInnerTime :: (Applicative k) => ZwirnT k st i Double -> ZwirnT k st i a -> ZwirnT k st i a
setInnerTime = withInner2 (liftA2 (\(vt, _) (va, st) -> (va {time = Time (realToFrac $ value vt) 1}, st)))

getInnerTime :: (Functor k) => ZwirnT k st i a -> ZwirnT k st i Double
getInnerTime = withValue (\v -> v {value = realToFrac $ tTime $ time v})

getSpeed :: (Functor k) => ZwirnT k st i a -> ZwirnT k st i Double
getSpeed = withValue (\v -> v {value = realToFrac $ tDiff $ time v})

apply :: (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
apply = zipSqueezeApply

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

zipSqueezeApply :: (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
zipSqueezeApply fs x = zwirn q
  where
    q t st = innerJoin $ func <$> unzwirn fs t st
      where
        func f = (\v -> unzwirn (value v x) (time v) st) $ fst f

matchApply :: (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
matchApply fs x = innerJoin $ apply fs . pure <$> x

iterate :: (MultiMonad k, HasSilence k) => ZwirnT k st i Int -> ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i a) -> ZwirnT k st i a -> ZwirnT k st i a
iterate nz fz xz = iterate' =<< nz
  where
    iterate' n = if n < 0 then silence else is !! n
      where
        is = Prelude.iterate (apply fz) xz

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