-- | Common algebras that are useful when folding.
module Yaya.Fold.Common where

import Control.Monad
import Control.Monad.Trans.Free
import Data.Foldable
import Data.Functor.Classes
import Data.Functor.Day
import Data.Functor.Identity
import Numeric.Natural
import Yaya.Pattern

-- | Converts the free monoid (a list) into some other `Monoid`.
lowerMonoid :: Monoid m => (a -> m) -> XNor a m -> m
lowerMonoid :: (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 -> m -> m -> m
forall a. Monoid a => a -> a -> a
mappend (a -> m
f a
a) m
b

-- | Converts the free semigroup (a non-empty list) into some other `Semigroup`.
lowerSemigroup :: Semigroup m => (a -> m) -> AndMaybe a m -> m
lowerSemigroup :: (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

-- | Converts the free monad into some other `Monad`.
lowerMonad :: Monad m => (forall x. f x -> m x) -> FreeF f a (m a) -> m a
lowerMonad :: (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 (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)

-- | Provides equality over arbitrary pattern functors.
equal :: (Functor f, Foldable f, Eq1 f) => Day f f Bool -> Bool
equal :: Day f f Bool -> Bool
equal (Day f b
f1 f c
f2 b -> c -> Bool
fn) =
  (() -> () -> Bool) -> f () -> f () -> 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 (t :: * -> *) a. Foldable t => t a -> [a]
toList f b
f1) (f c -> [c]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f c
f2))

-- TODO: Redefine this using `Natural`

-- | When folded, returns the height of the data structure.
height :: Foldable f => f Integer -> Integer
height :: 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
. (Integer -> Integer -> Integer) -> Integer -> f Integer -> Integer
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)

-- NB: It seems like this could be some more general notion of this, like
--        size :: (Foldable f, Semiring a) => f a -> a
--        size = foldr (+) one

-- | When folded, returns the number of nodes in the data structure.
--
--  __NB__: This is /not/ the same as the length when applied to a list. I.e.,
--          @`length` xs + 1 == `cata` `size` xs@, because this is counting the
--          nodes of the structure (how many `Neither`s and `Both`s), not how
--          many elements (which would be equivalent to only counting `Both`s).
size :: Foldable f => f Natural -> Natural
size :: f Natural -> Natural
size = (Natural -> Natural -> Natural) -> Natural -> f Natural -> Natural
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

-- | Converts a provably infinite structure into a `Yaya.Zoo.Partial` one (that
--   will never terminate).
toRight :: Identity b -> Either a b
toRight :: 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
. Identity b -> b
forall a. Identity a -> a
runIdentity

-- | Captures the input value if the application was undefined.
definedOrInput :: (a -> Maybe b) -> a -> Either a b
definedOrInput :: (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

-- | Collapses a `Yaya.Zoo.Partial` structure to a value (probably requiring
--   unsafe instances).
fromEither :: Either a a -> a
fromEither :: 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
id a -> a
forall a. a -> a
id

-- | Generates an infinite structure from an arbitrary seed.
never :: a -> Identity a
never :: 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

takeAnother :: Day Maybe ((,) a) b -> XNor a b
takeAnother :: 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 :: 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 (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 :: 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 :: 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' :: 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> c -> a
f b
n) f c
fa)

-- | Converts a single value into a tuple with the same value on both sides.
--   > x &&& y = (x *** y) . diagonal
diagonal :: a -> (a, a)
diagonal :: a -> (a, a)
diagonal a
x = (a
x, a
x)

-- * sequence generators

--
--   These functions are defined with different type parameters in order to
--   constrain the implementation, but to be used as coalgebras, all of the
--   parameters need to be specialized to the same type.

unarySequence :: (a -> b) -> a -> (a, b)
unarySequence :: (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 :: (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 :: (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' :: Integral i => i -> i -> (i, i) -> (i, (i, i))
lucasSequence' :: i -> i -> (i, i) -> (i, (i, i))
lucasSequence' i
p i
q = (i -> i -> i) -> (i, i) -> (i, (i, i))
forall a b c. (a -> b -> c) -> (a, b) -> (a, (b, c))
binarySequence (\i
n2 i
n1 -> i
p i -> i -> i
forall a. Num a => a -> a -> a
* i
n1 i -> i -> i
forall a. Num a => a -> a -> a
- i
q i -> i -> i
forall a. Num a => a -> a -> a
* i
n2)