Core.hs

{-# OPTIONS_GHC -Wno-orphans #-}

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 Data.Bifunctor
import Zwirn.Core.Time
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)

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)

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

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}

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

enumerateFromByTo :: (Ord a, Num a) => a -> a -> a -> [a]
enumerateFromByTo x y z
  | y <= 0 = []
  | x == z = []
  | 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)
  | otherwise = enumerateFromByTo x (x - y)

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