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