-
-newtype Polynomial g t x y = Polynomial { unPoly :: g (GArrowTensor g x t) y }
-
-instance GArrowSTKC g => Control.Category.Category (Polynomial g t) where
- id = Polynomial { unPoly = ga_second ga_drop >>> ga_cancelr }
- (.) g f = Polynomial { unPoly = ga_second ga_copy >>> ga_unassoc >>> ga_first (unPoly f) >>> (unPoly g) }
-
-instance (GArrowSTKC g, (GArrowTensor g) ~ (**), (GArrowUnit g) ~ u) => GArrow (Polynomial g t) (**) u where
- ga_first f = Polynomial { unPoly = ga_assoc >>> ga_second ga_swap >>> ga_unassoc >>> ga_first (unPoly f) }
- ga_second f = Polynomial { unPoly = ga_assoc >>> ga_second (unPoly f) }
- ga_cancell = Polynomial { unPoly = ga_second ga_drop >>> ga_cancelr >>> ga_cancell }
- ga_cancelr = Polynomial { unPoly = ga_second ga_drop >>> ga_cancelr >>> ga_cancelr }
- ga_uncancell = Polynomial { unPoly = ga_second ga_drop >>> ga_cancelr >>> ga_uncancell }
- ga_uncancelr = Polynomial { unPoly = ga_second ga_drop >>> ga_cancelr >>> ga_uncancelr }
- ga_assoc = Polynomial { unPoly = ga_second ga_drop >>> ga_cancelr >>> ga_assoc }
- ga_unassoc = Polynomial { unPoly = ga_second ga_drop >>> ga_cancelr >>> ga_unassoc }
-
-type instance GArrowUnit (Polynomial g t) = GArrowUnit g
-
-type instance GArrowTensor (Polynomial g t) = GArrowTensor g
-
-instance (GArrowSTKC g, (GArrowTensor g) ~ (**), (GArrowUnit g) ~ u) => GArrowDrop (Polynomial g t) (**) u
+import Prelude hiding ((.), id)
+
+data GArrow g (**) u => Polynomial g (**) u t x y
+ = L (g (t**x) y) -- uses t, wants it as the left arg
+ | R (g (x**t) y) -- uses t, wants it as the right arg
+ | B (g (t**x) y) (g (x**t) y) -- uses t, doesn't care which arg
+ | N (g x y) -- doesn't use t
+
+instance (GArrowCopy g (**) u, GArrowSwap g (**) u) => Category (Polynomial g (**) u t) where
+ id = N id
+ (N g) . (N f) = N $ g . f
+ (N g) . (L f) = L $ g . f
+ (N g) . (R f) = R $ g . f
+ (N g) . (B f f') = B (f >>> g) (f' >>> g)
+ (L g) . (N f) = L $ g . ga_second f
+ (R g) . (N f) = R $ g . ga_first f
+ (B g g') . (N f) = B (ga_second f >>> g) (ga_first f >>> g')
+ (L g) . (L f) = L $ ga_first ga_copy >>> ga_assoc >>> ga_second f >>> g
+ (L g) . (B f f') = L $ ga_first ga_copy >>> ga_assoc >>> ga_second f >>> g
+ (R g) . (R f) = R $ ga_second ga_copy >>> ga_unassoc >>> ga_first f >>> g
+ (B g g') . (R f) = R $ ga_second ga_copy >>> ga_unassoc >>> ga_first f >>> g'
+ (B g g') . (L f) = L $ ga_first ga_copy >>> ga_assoc >>> ga_second f >>> g
+ (R g) . (B f f') = R $ ga_second ga_copy >>> ga_unassoc >>> ga_first f' >>> g
+ (R g) . (L f) = L $ ga_first ga_copy >>> ga_assoc >>> ga_second f >>> ga_swap >>> g
+ (L g) . (R f) = R $ ga_second ga_copy >>> ga_unassoc >>> ga_first f >>> ga_swap >>> g
+ (B g g') . (B f f') = B (ga_first ga_copy >>> ga_assoc >>> ga_second f >>> g)
+ (ga_second ga_copy >>> ga_unassoc >>> ga_first f' >>> g')
+
+instance (GArrowCopy g (**) u, GArrowSwap g (**) u) => GArrow (Polynomial g (**) u t) (**) u where
+ ga_first (N f) = N $ ga_first f
+ ga_first (L f) = L $ ga_unassoc >>> ga_first f
+ ga_first (R f) = B (ga_unassoc >>> ga_first (ga_swap >>> f))
+ (ga_assoc >>> ga_second ga_swap >>> ga_unassoc >>> ga_first f)
+ ga_first (B f _) = L $ ga_unassoc >>> ga_first f
+ ga_second (N g) = N $ ga_second g
+ ga_second (L f) = B (ga_unassoc >>> ga_first ga_swap >>> ga_assoc >>> ga_second f)
+ (ga_assoc >>> ga_second (ga_swap >>> f))
+ ga_second (R g) = R $ ga_assoc >>> ga_second g
+ ga_second (B _ g) = R $ ga_assoc >>> ga_second g
+ ga_cancell = N ga_cancell
+ ga_cancelr = N ga_cancelr
+ ga_uncancell = N ga_uncancell
+ ga_uncancelr = N ga_uncancelr
+ ga_assoc = N ga_assoc
+ ga_unassoc = N ga_unassoc
+
+instance (GArrowSwap g (**) u, GArrowCopy g (**) u, GArrowDrop g (**) u) => GArrowCopy (Polynomial g (**) u t) (**) u