module Pandora.Paradigm.Primary.Functor.Wye where

import Pandora.Core.Functor (type (~>))
import Pandora.Pattern.Category ((#), ($))
import Pandora.Pattern.Functor.Covariant (Covariant ((<$>)))
import Pandora.Pattern.Functor.Semimonoidal (Semimonoidal (mult))
import Pandora.Pattern.Object.Semigroup (Semigroup ((+)))
import Pandora.Pattern.Object.Monoid (Monoid (zero))
import Pandora.Paradigm.Primary.Algebraic.Exponential (type (<--))
import Pandora.Paradigm.Primary.Algebraic.Product ((:*:) ((:*:)))
import Pandora.Pattern.Morphism.Flip (Flip (Flip))
import Pandora.Paradigm.Structure.Ability.Monotonic (Monotonic (reduce))

data Wye a = End | Left a | Right a | Both a a

instance Covariant (->) (->) Wye where
	a -> b
_ <$> :: (a -> b) -> Wye a -> Wye b
<$> Wye a
End = Wye b
forall a. Wye a
End
	a -> b
f <$> Left a
x = b -> Wye b
forall a. a -> Wye a
Left (b -> Wye b) -> b -> Wye b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# a -> b
f a
x
	a -> b
f <$> Right a
y = b -> Wye b
forall a. a -> Wye a
Right (b -> Wye b) -> b -> Wye b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# a -> b
f a
y
	a -> b
f <$> Both a
x a
y = b -> b -> Wye b
forall a. a -> a -> Wye a
Both (b -> b -> Wye b) -> b -> b -> Wye b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# a -> b
f a
x (b -> Wye b) -> b -> Wye b
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# a -> b
f a
y

instance Semimonoidal (<--) (:*:) (:*:) Wye where
	mult :: (Wye a :*: Wye b) <-- Wye (a :*: b)
mult = (Wye (a :*: b) -> Wye a :*: Wye b)
-> (Wye a :*: Wye b) <-- Wye (a :*: b)
forall (v :: * -> * -> *) a e. v e a -> Flip v a e
Flip ((Wye (a :*: b) -> Wye a :*: Wye b)
 -> (Wye a :*: Wye b) <-- Wye (a :*: b))
-> (Wye (a :*: b) -> Wye a :*: Wye b)
-> (Wye a :*: Wye b) <-- Wye (a :*: b)
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
$ \case
		Wye (a :*: b)
End -> Wye a
forall a. Wye a
End Wye a -> Wye b -> Wye a :*: Wye b
forall s a. s -> a -> s :*: a
:*: Wye b
forall a. Wye a
End
		Left (a
x :*: b
y) -> a -> Wye a
forall a. a -> Wye a
Left a
x Wye a -> Wye b -> Wye a :*: Wye b
forall s a. s -> a -> s :*: a
:*: b -> Wye b
forall a. a -> Wye a
Left b
y
		Right (a
x :*: b
y) -> a -> Wye a
forall a. a -> Wye a
Right a
x Wye a -> Wye b -> Wye a :*: Wye b
forall s a. s -> a -> s :*: a
:*: b -> Wye b
forall a. a -> Wye a
Right b
y
		Both (a
x :*: b
y) (a
x' :*: b
y') -> a -> a -> Wye a
forall a. a -> a -> Wye a
Both a
x a
x' Wye a -> Wye b -> Wye a :*: Wye b
forall s a. s -> a -> s :*: a
:*: b -> b -> Wye b
forall a. a -> a -> Wye a
Both b
y b
y'
	
instance Monotonic a (Wye a) where
	reduce :: (a -> r -> r) -> r -> Wye a -> r
reduce a -> r -> r
f r
r (Left a
x) = a -> r -> r
f a
x r
r
	reduce a -> r -> r
f r
r (Right a
x) = a -> r -> r
f a
x r
r
	reduce a -> r -> r
f r
r (Both a
x a
y) = a -> r -> r
f a
y (a -> r -> r
f a
x r
r)
	reduce a -> r -> r
_ r
r Wye a
End = r
r

instance Semigroup a => Semigroup (Wye a) where
	Wye a
End + :: Wye a -> Wye a -> Wye a
+ Wye a
x = Wye a
x
	Wye a
x + Wye a
End = Wye a
x
	Left a
x + Left a
x' = a -> Wye a
forall a. a -> Wye a
Left (a -> Wye a) -> a -> Wye a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
+ a
x'
	Left a
x + Right a
y = a -> a -> Wye a
forall a. a -> a -> Wye a
Both a
x a
y
	Left a
x + Both a
x' a
y = a -> a -> Wye a
forall a. a -> a -> Wye a
Both (a -> a -> Wye a) -> a -> a -> Wye a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
+ a
x' (a -> Wye a) -> a -> Wye a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# a
y
	Right a
y + Left a
x = a -> a -> Wye a
forall a. a -> a -> Wye a
Both a
x a
y
	Right a
y + Right a
y' = a -> Wye a
forall a. a -> Wye a
Right (a -> Wye a) -> a -> Wye a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# a
y a -> a -> a
forall a. Semigroup a => a -> a -> a
+ a
y'
	Right a
y + Both a
x a
y' = a -> a -> Wye a
forall a. a -> a -> Wye a
Both a
x (a -> Wye a) -> a -> Wye a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# a
y a -> a -> a
forall a. Semigroup a => a -> a -> a
+ a
y'
	Both a
x a
y + Left a
x' = a -> a -> Wye a
forall a. a -> a -> Wye a
Both (a -> a -> Wye a) -> a -> a -> Wye a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
+ a
x' (a -> Wye a) -> a -> Wye a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# a
y
	Both a
x a
y + Right a
y' = a -> a -> Wye a
forall a. a -> a -> Wye a
Both (a -> a -> Wye a) -> a -> a -> Wye a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# a
x (a -> Wye a) -> a -> Wye a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# a
y a -> a -> a
forall a. Semigroup a => a -> a -> a
+ a
y'
	Both a
x a
y + Both a
x' a
y' = a -> a -> Wye a
forall a. a -> a -> Wye a
Both (a -> a -> Wye a) -> a -> a -> Wye a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
+ a
x' (a -> Wye a) -> a -> Wye a
forall (m :: * -> * -> *) a b. Category m => m (m a b) (m a b)
# a
y a -> a -> a
forall a. Semigroup a => a -> a -> a
+ a
y'

instance Semigroup a => Monoid (Wye a) where
	zero :: Wye a
zero = Wye a
forall a. Wye a
End

wye :: r -> (a -> r) -> (a -> r) -> (a -> a -> r) -> Wye a -> r
wye :: r -> (a -> r) -> (a -> r) -> (a -> a -> r) -> Wye a -> r
wye r
r a -> r
_ a -> r
_ a -> a -> r
_ Wye a
End = r
r
wye r
_ a -> r
f a -> r
_ a -> a -> r
_ (Left a
x) = a -> r
f a
x
wye r
_ a -> r
_ a -> r
g a -> a -> r
_ (Right a
y) = a -> r
g a
y
wye r
_ a -> r
_ a -> r
_ a -> a -> r
h (Both a
x a
y) = a -> a -> r
h a
x a
y

swop :: Wye ~> Wye
swop :: Wye a -> Wye a
swop Wye a
End = Wye a
forall a. Wye a
End
swop (Both a
l a
r) = a -> a -> Wye a
forall a. a -> a -> Wye a
Both a
r a
l
swop (Left a
l) = a -> Wye a
forall a. a -> Wye a
Right a
l
swop (Right a
r) = a -> Wye a
forall a. a -> Wye a
Left a
r