content: {-# LANGUAGE Safe #-}
  
  -- | Common algebras that are useful when folding.
  module Yaya.Fold.Common
    ( binarySequence,
      definedOrInput,
      compareDay,
      diagonal,
      equal,
      equalDay,
      fromEither,
      height,
      le,
      lowerMonad,
      lowerMonoid,
      lowerSemigroup,
      lucasSequence',
      maybeTakeNext,
      never,
      replaceNeither,
      showsPrecF,
      size,
      takeAnother,
      takeAvailable,
      takeNext,
      ternarySequence,
      toRight,
      truncate',
      unarySequence,
      xnor,
    )
  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, fold)
  import "base" Data.Function (($), (&))
  import "base" Data.Functor (Functor (fmap), void)
  import "base" Data.Functor.Classes (Eq1 (liftEq), Show1 (liftShowsPrec))
  import "base" Data.Functor.Identity (Identity (Identity, runIdentity))
  import "base" Data.Int (Int)
  import "base" Data.List (zipWith)
  import "base" Data.Monoid (Monoid (mempty))
  import "base" Data.Ord (Ord (max), Ordering)
  import "base" Data.Semigroup (Semigroup ((<>)))
  import "base" GHC.Show (showList__)
  import "base" Numeric.Natural (Natural)
  import "base" Text.Show (ShowS)
  import "free" Control.Monad.Trans.Free (FreeF (Free, Pure))
  import "kan-extensions" Data.Functor.Day (Day (Day))
  import "this" Yaya.Pattern
    ( AndMaybe,
      Either (Left, Right),
      Maybe (Just, Nothing),
      Pair ((:!:)),
      XNor (Both, Neither),
      andMaybe,
      either,
      maybe,
      xnor,
    )
  import Prelude (Integer, Num ((*), (+), (-)))
  
  -- | Converts the free monoid (a list) into some other `Monoid`.
  lowerMonoid :: (Monoid m) => (a -> m) -> XNor a m -> m
  lowerMonoid = xnor mempty . ((<>) .)
  
  -- | Converts the free semigroup (a non-empty list) into some other `Semigroup`.
  lowerSemigroup :: (Semigroup m) => (a -> m) -> AndMaybe a m -> m
  lowerSemigroup f = andMaybe f ((<>) . f)
  
  -- | 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 f = \case
    Pure a -> pure a
    Free fm -> join (f fm)
  
  -- | Provides equality over arbitrary pattern functors.
  --
  --   @since 0.6.1.0
  equalDay ::
    (Functor f, Foldable f) => (f () -> f () -> Bool) -> Day f f Bool -> Bool
  equalDay eqF (Day f1 f2 fn) =
    eqF (void f1) (void f2)
      && and (zipWith fn (toList f1) (toList f2))
  
  -- | Provides equality over arbitrary pattern functors.
  equal :: (Functor f, Foldable f, Eq1 f) => Day f f Bool -> Bool
  equal = equalDay $ liftEq (==)
  
  -- | Provides ordering over arbitrary pattern functors.
  --
  --   @since 0.6.1.0
  compareDay ::
    (Functor f, Foldable f) =>
    (f () -> f () -> Ordering) ->
    Day f f Ordering ->
    Ordering
  compareDay compareF (Day f1 f2 fn) =
    compareF (void f1) (void f2)
      <> fold (zipWith fn (toList f1) (toList f2))
  
  -- | Provides show over arbitrary pattern functors.
  --
  --   @since 0.6.1.0
  showsPrecF :: (Show1 f) => Int -> f (Int -> ShowS) -> ShowS
  showsPrecF = liftShowsPrec (&) (showList__ ($ 0))
  
  -- TODO: Redefine this using `Natural`
  
  -- | When folded, returns the height of the data structure.
  height :: (Foldable f) => f Integer -> Integer
  height = (+ 1) . foldr max (-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.,
  --          @`Data.List.length` xs `+` 1 `==` `Yaya.Fold.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 = foldr (+) 1
  
  -- | Converts a provably infinite structure into a `Yaya.Zoo.Partial` one (that
  --   will never terminate).
  toRight :: Identity b -> Either a b
  toRight = Right . runIdentity
  
  -- | Captures the input value if the application was undefined.
  definedOrInput :: (a -> Maybe b) -> a -> Either a b
  definedOrInput f a = maybe (Left a) Right $ f a
  
  -- | Collapses a `Yaya.Zoo.Partial` structure to a value (probably requiring
  --   unsafe instances).
  fromEither :: Either a a -> a
  fromEither = either id id
  
  -- | Generates an infinite structure from an arbitrary seed.
  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
  
  replaceNeither :: XNor a b -> XNor a b -> XNor a b
  replaceNeither replacement = \case
    Neither -> replacement
    next -> next
  
  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
  
  takeNext :: Day Maybe ((,) a) a -> a
  takeNext = \case
    Day Nothing (h, _) _ -> h
    Day (Just x) (_, t) f -> f x t
  
  maybeTakeNext :: Day Maybe (XNor a) (Maybe a) -> Maybe a
  maybeTakeNext = \case
    Day Nothing (Both h _) _ -> Just h
    Day (Just x) (Both _ t) f -> f x t
    Day _ Neither _ -> Nothing
  
  truncate' :: (Functor f) => Day Maybe f a -> FreeF f () a
  truncate' = \case
    Day Nothing _ _ -> Pure ()
    Day (Just n) fa f -> Free (fmap (f n) 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 x = x :!: 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 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' :: (Num n) => n -> n -> (n, n) -> (n, (n, n))
  lucasSequence' p q = binarySequence (\n2 n1 -> p * n1 - q * n2)
  