module Yaya.Fold.Common where
import Control.Arrow
import Control.Monad
import Control.Monad.Trans.Free
import Data.Foldable
import Data.Functor
import Data.Functor.Classes
import Data.Functor.Day
import Data.Functor.Identity
import Data.Semigroup
import Numeric.Natural
import Yaya.Pattern
lowerMonoid :: Monoid m => (a -> m) -> XNor a m -> m
lowerMonoid f = \case
Neither -> mempty
Both a b -> mappend (f a) b
lowerSemigroup :: Semigroup m => (a -> m) -> AndMaybe a m -> m
lowerSemigroup f = \case
Only a -> f a
Indeed a b -> f a <> b
lowerMonad :: Monad m => (forall a. f a -> m a) -> FreeF f a (m a) -> m a
lowerMonad f = \case
Pure a -> pure a
Free fm -> join (f fm)
equal :: (Functor f, Foldable f, Eq1 f) => Day f f Bool -> Bool
equal (Day f1 f2 fn) =
liftEq (==) (void f1) (void f2)
&& and (zipWith fn (toList f1) (toList f2))
height :: Foldable f => f Integer -> Integer
height = (+ 1) . foldr max (-1)
size :: Foldable f => f Natural -> Natural
size = foldr (+) 1
toRight :: Identity b -> Either a b
toRight = Right . runIdentity
while :: (a -> Maybe a) -> a -> Either a a
while f a = maybe (Left a) Right $ f a
fromEither :: Either a a -> a
fromEither = \case
Left a -> a
Right a -> a
never :: a -> Identity a
never = Identity
le :: Day Maybe Maybe Bool -> Bool
le = \case
Day Nothing _ _ -> True
Day (Just a) (Just b) f -> f a b
Day (Just _) Nothing _ -> False
takeAnother :: Day Maybe ((,) a) b -> XNor a b
takeAnother = \case
Day Nothing _ _ -> Neither
Day (Just x) (h, t) f -> Both h (f x t)
takeAvailable :: Day Maybe (XNor a) b -> XNor a b
takeAvailable = \case
Day Nothing _ _ -> Neither
Day (Just x) t f -> fmap (f x) t
truncate' :: Functor f => Day Maybe f a -> FreeF f () a
truncate' = \case
Day Nothing fa _ -> Pure ()
Day (Just n) fa f -> Free (fmap (f n) fa)
split :: a -> (a, a)
split x = (x, x)
unarySequence :: (a -> b) -> a -> (a, b)
unarySequence f a = (a, f a)
binarySequence :: (a -> b -> c) -> (a, b) -> (a, (b, c))
binarySequence f (a, b) = (a, (b, f a b))
ternarySequence :: (a -> b -> c -> d) -> (a, b, c) -> (a, (b, c, d))
ternarySequence f (a, b, c) = (a, (b, c, f a b c))
lucasSequence' :: Integral i => i -> i -> (i, i) -> (i, (i, i))
lucasSequence' p q = binarySequence (\n2 n1 -> p * n1 - q * n2)