+ {PMFF23:Functor C2 C3 fobj23 }
+ (PMF23 :PreMonoidalFunctor PM2 PM3 PMFF23).
+
+ Definition compose_mf := PMF12 >>>> PMF23.
+
+ Definition compose_mf_i : I3 ≅ PMF23 (PMF12 I1).
+ eapply iso_comp.
+ apply (mf_i(PreMonoidalFunctor:=PMF23)).
+ apply functors_preserve_isos.
+ apply (mf_i(PreMonoidalFunctor:=PMF12)).
+ Defined.
+
+ Definition compose_mf_first a : compose_mf >>>> bin_first (compose_mf a) <~~~> bin_first a >>>> compose_mf.
+ set (mf_first(PreMonoidalFunctor:=PMF12) a) as mf_first12.
+ set (mf_first(PreMonoidalFunctor:=PMF23) (PMF12 a)) as mf_first23.
+ unfold functor_fobj in *; simpl in *.
+ unfold compose_mf.
+ eapply ni_comp.
+ apply (ni_associativity PMF12 PMF23 (- ⋉fobj23 (fobj12 a))).
+ eapply ni_comp.
+ apply (ni_respects1 PMF12 (PMF23 >>>> - ⋉fobj23 (fobj12 a)) (- ⋉fobj12 a >>>> PMF23)).
+ apply mf_first23.
+ clear mf_first23.
+
+ eapply ni_comp.
+ eapply ni_inv.
+ apply (ni_associativity PMF12 (- ⋉fobj12 a) PMF23).
+
+ apply ni_inv.
+ eapply ni_comp.
+ eapply ni_inv.
+ eapply (ni_associativity _ PMF12 PMF23).
+
+ apply ni_respects2.
+ apply ni_inv.
+ apply mf_first12.
+ Defined.
+
+ Definition compose_mf_second a : compose_mf >>>> bin_second (compose_mf a) <~~~> bin_second a >>>> compose_mf.
+ set (mf_second(PreMonoidalFunctor:=PMF12) a) as mf_second12.
+ set (mf_second(PreMonoidalFunctor:=PMF23) (PMF12 a)) as mf_second23.
+ unfold functor_fobj in *; simpl in *.
+ unfold compose_mf.
+ eapply ni_comp.
+ apply (ni_associativity PMF12 PMF23 (fobj23 (fobj12 a) ⋊-)).
+ eapply ni_comp.
+ apply (ni_respects1 PMF12 (PMF23 >>>> fobj23 (fobj12 a) ⋊-) (fobj12 a ⋊- >>>> PMF23)).
+ apply mf_second23.
+ clear mf_second23.
+
+ eapply ni_comp.
+ eapply ni_inv.
+ apply (ni_associativity PMF12 (fobj12 a ⋊ -) PMF23).
+
+ apply ni_inv.
+ eapply ni_comp.
+ eapply ni_inv.
+ eapply (ni_associativity (a ⋊-) PMF12 PMF23).
+
+ apply ni_respects2.
+ apply ni_inv.
+ apply mf_second12.
+ Defined.
+
+ (* this proof is really gross; I will write a better one some other day *)
+ Lemma mf_associativity_comp :
+ ∀a b c : C1,
+ (#((pmon_assoc (compose_mf a) (compose_mf c)) (fobj23 (fobj12 b))) >>>
+ compose_mf a ⋊ #((compose_mf_first c) b)) >>>
+ #((compose_mf_second a) (b ⊗ c)) ~~
+ (#((compose_mf_second a) b) ⋉ compose_mf c >>>
+ #((compose_mf_first c) (a ⊗ b))) >>> compose_mf \ #((pmon_assoc a c) b).
+ intros; intros.
+ unfold compose_mf_second; simpl.
+ unfold compose_mf_first; simpl.
+ unfold functor_comp; simpl.
+ unfold ni_respects1.
+ unfold functor_fobj; simpl.
+
+ set (mf_first (fobj12 c)) as m'.
+ assert (mf_first (fobj12 c)=m'). reflexivity.
+ destruct m'; simpl.
+
+ set (mf_second (fobj12 a)) as m.
+ assert (mf_second (fobj12 a)=m). reflexivity.
+ destruct m; simpl.
+
+ Implicit Arguments id [[Ob][Hom][Category][a]].
+ idtac.
+
+ symmetry.
+ etransitivity.
+ repeat setoid_rewrite <- fmor_preserves_comp.
+ repeat setoid_rewrite fmor_preserves_id.
+ repeat setoid_rewrite left_identity.
+ repeat setoid_rewrite right_identity.
+ reflexivity.
+ symmetry.
+ etransitivity.
+ repeat setoid_rewrite <- fmor_preserves_comp.
+ repeat setoid_rewrite fmor_preserves_id.
+ repeat setoid_rewrite left_identity.
+ repeat setoid_rewrite right_identity.
+ reflexivity.
+
+ assert ( (#((pmon_assoc (fobj23 (fobj12 a)) (fobj23 (fobj12 c)))
+ (fobj23 (fobj12 b))) >>>
+ fobj23 (fobj12 a)
+ ⋊ (
+ (#(ni_iso (fobj12 b)) >>> ( (PMF23 \ #((mf_first c) b) ))))) >>>
+ (
+ (#(ni_iso0 (fobj12 (b ⊗ c))) >>>
+ ((PMF23 \ #((mf_second a) (b ⊗ c)))))) ~~
+ ((
+ (#(ni_iso0 (fobj12 b)) >>> ( (PMF23 \ #((mf_second a) b) ))))
+ ⋉ fobj23 (fobj12 c) >>>
+ (
+ (#(ni_iso (fobj12 (a ⊗ b))) >>>
+ ( (PMF23 \ #((mf_first c) (a ⊗ b))))))) >>>
+ PMF23 \ (PMF12 \ #((pmon_assoc a c) b))
+ ).
+
+ repeat setoid_rewrite associativity.
+ setoid_rewrite (fmor_preserves_comp PMF23).
+ unfold functor_comp in *.
+ unfold functor_fobj in *.
+ simpl in *.
+ rename ni_commutes into ni_commutes7.
+ set (mf_assoc(PreMonoidalFunctor:=PMF12)) as q.
+ set (ni_commutes7 _ _ (#((mf_second a) b))) as q'.
+ simpl in q'.
+ repeat setoid_rewrite associativity.
+ symmetry.
+ setoid_rewrite <- (fmor_preserves_comp (-⋉ fobj23 (fobj12 c))).
+ repeat setoid_rewrite <- associativity.
+ setoid_rewrite juggle1.
+ setoid_rewrite <- q'.
+ repeat setoid_rewrite associativity.
+ setoid_rewrite fmor_preserves_comp.
+ idtac.
+ unfold functor_fobj in *.
+ simpl in *.
+ repeat setoid_rewrite <- associativity.
+ setoid_rewrite <- q.
+ clear q.
+ repeat setoid_rewrite <- fmor_preserves_comp.
+ repeat setoid_rewrite <- associativity.
+ apply comp_respects; try reflexivity.
+
+ set (mf_assoc(PreMonoidalFunctor:=PMF23) (fobj12 a) (fobj12 b) (fobj12 c)) as q.
+ unfold functor_fobj in *.
+ simpl in *.
+
+ rewrite H in q.
+ rewrite H0 in q.
+ simpl in q.
+ repeat setoid_rewrite <- associativity.
+ repeat setoid_rewrite <- associativity in q.
+ setoid_rewrite <- q.
+ clear q.
+ unfold functor_fobj; simpl.
+
+ repeat setoid_rewrite associativity.
+ apply comp_respects; try reflexivity.
+ apply comp_respects; try reflexivity.
+ auto.
+
+ repeat setoid_rewrite associativity.
+ repeat setoid_rewrite associativity in H1.
+ repeat setoid_rewrite <- fmor_preserves_comp in H1.
+ repeat setoid_rewrite associativity in H1.
+ apply H1.
+ Qed.
+ Implicit Arguments id [[Ob][Hom][Category]].
+
+ (* this proof is really gross; I will write a better one some other day *)
+ Instance PreMonoidalFunctorsCompose : PreMonoidalFunctor PM1 PM3 compose_mf :=
+ { mf_i := compose_mf_i
+ ; mf_first := compose_mf_first
+ ; mf_second := compose_mf_second }.
+
+ intros; unfold compose_mf_first; unfold compose_mf_second.
+ set (mf_first (PMF12 a)) as x in *.
+ set (mf_second (PMF12 b)) as y in *.
+ assert (x=mf_first (PMF12 a)). reflexivity.
+ assert (y=mf_second (PMF12 b)). reflexivity.
+ destruct x.
+ destruct y.
+ simpl.
+ repeat setoid_rewrite left_identity.
+ repeat setoid_rewrite right_identity.
+ set (mf_consistent (PMF12 a) (PMF12 b)) as later.
+ apply comp_respects; try reflexivity.
+ rewrite <- H in later.
+ rewrite <- H0 in later.
+ simpl in later.
+ apply later.
+ apply fmor_respects.
+ apply mf_consistent.
+
+ intros.
+ simpl.
+ apply mf_center.
+ apply mf_center.
+ auto.
+
+ intros.
+ unfold compose_mf_first; simpl.
+ set (mf_first (PMF12 b)) as m.
+ assert (mf_first (PMF12 b)=m). reflexivity.
+ destruct m.
+ simpl.
+ unfold functor_fobj; simpl.
+ repeat setoid_rewrite <- fmor_preserves_comp.
+ repeat setoid_rewrite left_identity.
+ repeat setoid_rewrite right_identity.
+
+ set (mf_cancell b) as y.
+ set (mf_cancell (fobj12 b)) as y'.
+ unfold functor_fobj in *.
+ setoid_rewrite y in y'.
+ clear y.
+ setoid_rewrite <- fmor_preserves_comp in y'.
+ setoid_rewrite <- fmor_preserves_comp in y'.
+ etransitivity.
+ apply y'.
+ clear y'.
+
+ repeat setoid_rewrite <- associativity.
+ apply comp_respects; try reflexivity.
+ apply comp_respects; try reflexivity.
+ repeat setoid_rewrite associativity.
+ apply comp_respects; try reflexivity.
+
+ set (ni_commutes _ _ #mf_i) as x.
+ unfold functor_comp in x.
+ unfold functor_fobj in x.
+ simpl in x.
+ rewrite H.
+ simpl.
+ apply x.
+
+ intros.
+ unfold compose_mf_second; simpl.
+ set (mf_second (PMF12 a)) as m.
+ assert (mf_second (PMF12 a)=m). reflexivity.
+ destruct m.
+ simpl.
+ unfold functor_fobj; simpl.
+ repeat setoid_rewrite <- fmor_preserves_comp.
+ repeat setoid_rewrite left_identity.
+ repeat setoid_rewrite right_identity.
+
+ set (mf_cancelr a) as y.
+ set (mf_cancelr (fobj12 a)) as y'.
+ unfold functor_fobj in *.
+ setoid_rewrite y in y'.
+ clear y.
+ setoid_rewrite <- fmor_preserves_comp in y'.
+ setoid_rewrite <- fmor_preserves_comp in y'.
+ etransitivity.
+ apply y'.
+ clear y'.
+
+ repeat setoid_rewrite <- associativity.
+ apply comp_respects; try reflexivity.
+ apply comp_respects; try reflexivity.
+ repeat setoid_rewrite associativity.
+ apply comp_respects; try reflexivity.
+
+ set (ni_commutes _ _ #mf_i) as x.
+ unfold functor_comp in x.
+ unfold functor_fobj in x.
+ simpl in x.
+ rewrite H.
+ simpl.
+ apply x.
+
+ apply mf_associativity_comp.
+
+ Defined.
+
+End PreMonoidalFunctorsCompose.
+