{-# LANGUAGE Safe #-}

-- | Common algebras that are useful when folding.
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 ((*), (+), (-)))

-- | Converts the free monoid (a list) into some other `Monoid`.
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

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

-- | 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 (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)

-- | Provides equality over arbitrary pattern functors.
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))

-- TODO: Redefine this using `Natural`

-- | When folded, returns the height of the data structure.
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)

-- 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 :: 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

-- | Converts a provably infinite structure into a `Yaya.Zoo.Partial` one (that
--   will never terminate).
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

-- | Captures the input value if the application was undefined.
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

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

-- | Generates an infinite structure from an arbitrary seed.
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)

-- | Converts a single value into a tuple with the same value on both sides.
--   > x &&& y = (x *** y) . diagonal
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

-- * 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 :: 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)