{-# LANGUAGE Safe #-}
module Yaya.Fold.Common
( binarySequence,
definedOrInput,
diagonal,
equal,
fromEither,
height,
le,
lowerMonad,
lowerMonoid,
lowerSemigroup,
lucasSequence',
maybeTakeNext,
never,
replaceNeither,
size,
takeAnother,
takeAvailable,
takeNext,
ternarySequence,
toRight,
truncate',
unarySequence,
)
where
import "base" Control.Applicative (Applicative (pure))
import "base" Control.Category (Category (id, (.)))
import "base" Control.Monad (Monad, join)
import "base" Data.Bool (Bool (False, True), (&&))
import "base" Data.Eq (Eq ((==)))
import "base" Data.Foldable (Foldable (foldr, toList), and)
import "base" Data.Function (($))
import "base" Data.Functor (Functor (fmap), void)
import "base" Data.Functor.Classes (Eq1 (liftEq))
import "base" Data.Functor.Identity (Identity (Identity, runIdentity))
import "base" Data.List (zipWith)
import "base" Data.Monoid (Monoid (mempty))
import "base" Data.Ord (Ord (max))
import "base" Data.Semigroup (Semigroup ((<>)))
import "base" Numeric.Natural (Natural)
import "free" Control.Monad.Trans.Free (FreeF (Free, Pure))
import "kan-extensions" Data.Functor.Day (Day (Day))
import "this" Yaya.Pattern
( AndMaybe (Indeed, Only),
Either (Left, Right),
Maybe (Just, Nothing),
Pair ((:!:)),
XNor (Both, Neither),
either,
maybe,
)
import Prelude (Integer, Num ((*), (+), (-)))
lowerMonoid :: (Monoid m) => (a -> m) -> XNor a m -> m
lowerMonoid :: forall m a. Monoid m => (a -> m) -> XNor a m -> m
lowerMonoid a -> m
f = \case
XNor a m
Neither -> m
forall a. Monoid a => a
mempty
Both a
a m
b -> a -> m
f a
a m -> m -> m
forall a. Semigroup a => a -> a -> a
<> m
b
lowerSemigroup :: (Semigroup m) => (a -> m) -> AndMaybe a m -> m
lowerSemigroup :: forall m a. Semigroup m => (a -> m) -> AndMaybe a m -> m
lowerSemigroup a -> m
f = \case
Only a
a -> a -> m
f a
a
Indeed a
a m
b -> a -> m
f a
a m -> m -> m
forall a. Semigroup a => a -> a -> a
<> m
b
lowerMonad :: (Monad m) => (forall x. f x -> m x) -> FreeF f a (m a) -> m a
lowerMonad :: forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
(forall x. f x -> m x) -> FreeF f a (m a) -> m a
lowerMonad forall x. f x -> m x
f = \case
Pure a
a -> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
Free f (m a)
fm -> m (m a) -> m a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (f (m a) -> m (m a)
forall x. f x -> m x
f f (m a)
fm)
equal :: (Functor f, Foldable f, Eq1 f) => Day f f Bool -> Bool
equal :: forall (f :: * -> *).
(Functor f, Foldable f, Eq1 f) =>
Day f f Bool -> Bool
equal (Day f b
f1 f c
f2 b -> c -> Bool
fn) =
(() -> () -> Bool) -> f () -> f () -> Bool
forall a b. (a -> b -> Bool) -> f a -> f b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq () -> () -> Bool
forall a. Eq a => a -> a -> Bool
(==) (f b -> f ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void f b
f1) (f c -> f ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void f c
f2)
Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((b -> c -> Bool) -> [b] -> [c] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith b -> c -> Bool
fn (f b -> [b]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f b
f1) (f c -> [c]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f c
f2))
height :: (Foldable f) => f Integer -> Integer
height :: forall (f :: * -> *). Foldable f => f Integer -> Integer
height = (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) (Integer -> Integer)
-> (f Integer -> Integer) -> f Integer -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Integer -> Integer -> Integer) -> Integer -> f Integer -> Integer
forall a b. (a -> b -> b) -> b -> f a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max (Integer
-1)
size :: (Foldable f) => f Natural -> Natural
size :: forall (f :: * -> *). Foldable f => f Natural -> Natural
size = (Natural -> Natural -> Natural) -> Natural -> f Natural -> Natural
forall a b. (a -> b -> b) -> b -> f a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
(+) Natural
1
toRight :: Identity b -> Either a b
toRight :: forall b a. Identity b -> Either a b
toRight = b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b) -> (Identity b -> b) -> Identity b -> Either a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Identity b -> b
forall a. Identity a -> a
runIdentity
definedOrInput :: (a -> Maybe b) -> a -> Either a b
definedOrInput :: forall a b. (a -> Maybe b) -> a -> Either a b
definedOrInput a -> Maybe b
f a
a = Either a b -> (b -> Either a b) -> Maybe b -> Either a b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a -> Either a b
forall a b. a -> Either a b
Left a
a) b -> Either a b
forall a b. b -> Either a b
Right (Maybe b -> Either a b) -> Maybe b -> Either a b
forall a b. (a -> b) -> a -> b
$ a -> Maybe b
f a
a
fromEither :: Either a a -> a
fromEither :: forall a. Either a a -> a
fromEither = (a -> a) -> (a -> a) -> Either a a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> a
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id a -> a
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
never :: a -> Identity a
never :: forall a. a -> Identity a
never = a -> Identity a
forall a. a -> Identity a
Identity
le :: Day Maybe Maybe Bool -> Bool
le :: Day Maybe Maybe Bool -> Bool
le = \case
Day Maybe b
Nothing Maybe c
_ b -> c -> Bool
_ -> Bool
True
Day (Just b
a) (Just c
b) b -> c -> Bool
f -> b -> c -> Bool
f b
a c
b
Day (Just b
_) Maybe c
Nothing b -> c -> Bool
_ -> Bool
False
replaceNeither :: XNor a b -> XNor a b -> XNor a b
replaceNeither :: forall a b. XNor a b -> XNor a b -> XNor a b
replaceNeither XNor a b
replacement = \case
XNor a b
Neither -> XNor a b
replacement
XNor a b
next -> XNor a b
next
takeAnother :: Day Maybe ((,) a) b -> XNor a b
takeAnother :: forall a b. Day Maybe ((,) a) b -> XNor a b
takeAnother = \case
Day Maybe b
Nothing (a, c)
_ b -> c -> b
_ -> XNor a b
forall a b. XNor a b
Neither
Day (Just b
x) (a
h, c
t) b -> c -> b
f -> a -> b -> XNor a b
forall a b. a -> b -> XNor a b
Both a
h (b -> c -> b
f b
x c
t)
takeAvailable :: Day Maybe (XNor a) b -> XNor a b
takeAvailable :: forall a b. Day Maybe (XNor a) b -> XNor a b
takeAvailable = \case
Day Maybe b
Nothing XNor a c
_ b -> c -> b
_ -> XNor a b
forall a b. XNor a b
Neither
Day (Just b
x) XNor a c
t b -> c -> b
f -> (c -> b) -> XNor a c -> XNor a b
forall a b. (a -> b) -> XNor a a -> XNor a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> c -> b
f b
x) XNor a c
t
takeNext :: Day Maybe ((,) a) a -> a
takeNext :: forall a. Day Maybe ((,) a) a -> a
takeNext = \case
Day Maybe b
Nothing (a
h, c
_) b -> c -> a
_ -> a
h
Day (Just b
x) (a
_, c
t) b -> c -> a
f -> b -> c -> a
f b
x c
t
maybeTakeNext :: Day Maybe (XNor a) (Maybe a) -> Maybe a
maybeTakeNext :: forall a. Day Maybe (XNor a) (Maybe a) -> Maybe a
maybeTakeNext = \case
Day Maybe b
Nothing (Both a
h c
_) b -> c -> Maybe a
_ -> a -> Maybe a
forall a. a -> Maybe a
Just a
h
Day (Just b
x) (Both a
_ c
t) b -> c -> Maybe a
f -> b -> c -> Maybe a
f b
x c
t
Day Maybe b
_ XNor a c
Neither b -> c -> Maybe a
_ -> Maybe a
forall a. Maybe a
Nothing
truncate' :: (Functor f) => Day Maybe f a -> FreeF f () a
truncate' :: forall (f :: * -> *) a. Functor f => Day Maybe f a -> FreeF f () a
truncate' = \case
Day Maybe b
Nothing f c
_ b -> c -> a
_ -> () -> FreeF f () a
forall (f :: * -> *) a b. a -> FreeF f a b
Pure ()
Day (Just b
n) f c
fa b -> c -> a
f -> f a -> FreeF f () a
forall (f :: * -> *) a b. f b -> FreeF f a b
Free ((c -> a) -> f c -> f a
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> c -> a
f b
n) f c
fa)
diagonal :: a -> Pair a a
diagonal :: forall a. a -> Pair a a
diagonal a
x = a
x a -> a -> Pair a a
forall a b. a -> b -> Pair a b
:!: a
x
unarySequence :: (a -> b) -> a -> (a, b)
unarySequence :: forall a b. (a -> b) -> a -> (a, b)
unarySequence a -> b
f a
a = (a
a, a -> b
f a
a)
binarySequence :: (a -> b -> c) -> (a, b) -> (a, (b, c))
binarySequence :: forall a b c. (a -> b -> c) -> (a, b) -> (a, (b, c))
binarySequence a -> b -> c
f (a
a, b
b) = (a
a, (b
b, a -> b -> c
f a
a b
b))
ternarySequence :: (a -> b -> c -> d) -> (a, b, c) -> (a, (b, c, d))
ternarySequence :: forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> (a, (b, c, d))
ternarySequence a -> b -> c -> d
f (a
a, b
b, c
c) = (a
a, (b
b, c
c, a -> b -> c -> d
f a
a b
b c
c))
lucasSequence' :: (Num n) => n -> n -> (n, n) -> (n, (n, n))
lucasSequence' :: forall n. Num n => n -> n -> (n, n) -> (n, (n, n))
lucasSequence' n
p n
q = (n -> n -> n) -> (n, n) -> (n, (n, n))
forall a b c. (a -> b -> c) -> (a, b) -> (a, (b, c))
binarySequence (\n
n2 n
n1 -> n
p n -> n -> n
forall a. Num a => a -> a -> a
* n
n1 n -> n -> n
forall a. Num a => a -> a -> a
- n
q n -> n -> n
forall a. Num a => a -> a -> a
* n
n2)