(** Links signatures to lax morphisms in suitable actegories, by exploiting the already established link with action-based strength (in the non-whiskered setting)

Author: Ralph Matthes 2022

 *)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.Monoidal.AlternativeDefinitions.MonoidalCategoriesTensored.
Require Import UniMath.Bicategories.MonoidalCategories.PointedFunctorsMonoidal.
Require Import UniMath.Bicategories.MonoidalCategories.Actions.
Require Import UniMath.Bicategories.MonoidalCategories.ConstructionOfActions.
Require Import UniMath.Bicategories.MonoidalCategories.ActionOfEndomorphismsInBicat.
Require Import UniMath.Bicategories.MonoidalCategories.ActionBasedStrength.
Require Import UniMath.Bicategories.MonoidalCategories.MonoidalFromBicategory.
Require Import UniMath.Bicategories.MonoidalCategories.ActionBasedStrongFunctorCategory.
Require Import UniMath.Bicategories.Core.Bicat.
Require Import UniMath.Bicategories.Core.Examples.BicatOfCats.
Require Import UniMath.CategoryTheory.Monoidal.Examples.EndofunctorsMonoidalElementary.
Require Import UniMath.CategoryTheory.Actegories.Examples.ActionOfEndomorphismsInCATElementary.

Require Import UniMath.SubstitutionSystems.Signatures.

Require Import UniMath.SubstitutionSystems.ActionBasedStrengthOnHomsInBicat.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal.
Require Import UniMath.CategoryTheory.Actegories.Actegories.
Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories.
Require Import UniMath.CategoryTheory.Actegories.ConstructionOfActegories.
Require Import UniMath.CategoryTheory.coslicecat.
Require Import UniMath.CategoryTheory.Monoidal.Examples.MonoidalPointedObjects.
Require Import UniMath.Bicategories.MonoidalCategories.PointedFunctorsWhiskeredMonoidal.
Require Import UniMath.Bicategories.MonoidalCategories.ActionOfEndomorphismsInBicatWhiskered.
Require Import UniMath.Bicategories.MonoidalCategories.BicatOfActegories.

Import Bicat.Notations.
Import MonoidalNotations.

Local Open Scope cat.

Section A.

 Context (C D D' : category).

 Local Definition Mon_endo' : MonoidalCategoriesTensored.monoidal_cat
   := swapping_of_monoidal_cat (monoidal_cat_of_pointedfunctors C).
 Local Definition domain_action : Actions.action Mon_endo' (hom(C:=bicat_of_cats) C D')
    := ActionBasedStrengthOnHomsInBicat.ab_strength_domain_action(C:=bicat_of_cats) C D' (ActionBasedStrengthOnHomsInBicat.forget C).
 Local Definition target_action : Actions.action Mon_endo' (hom(C:=bicat_of_cats) C D)
    := ActionBasedStrengthOnHomsInBicat.ab_strength_target_action(C:=bicat_of_cats) C D (ActionBasedStrengthOnHomsInBicat.forget C).

 Lemma weqSignatureABStrength : Signature C D D' ≃ actionbased_strong_functor Mon_endo' (ActionBasedStrengthOnHomsInBicat.domain_action C D') (ActionBasedStrengthOnHomsInBicat.target_action C D).
 Proof.
   use weq_iso.
   - apply ab_strong_functor_from_signature.
   - apply signature_from_strong_functor.
   - apply roundtrip1_ob_as_equality.
   - apply roundtrip2_ob_as_equality.
 Defined.

(* Local Definition endo : category := [C,C]. would not be okay for convertibility *)
 Local Definition endofrombicat : category := ActionOfEndomorphismsInBicatWhiskered.endocat(C:=bicat_of_cats) C.
 Local Definition Mon_endo : monoidal endofrombicat := ActionOfEndomorphismsInBicatWhiskered.Mon_endo(C:=bicat_of_cats) C.
 Local Definition ptdendo : category := coslice_cat_total endofrombicat I_{Mon_endo}.
 Local Definition Mon_ptdendo : monoidal ptdendo
   := monoidal_pointed_objects Mon_endo.

 Local Definition actegoryPtdEndosOnFunctors (E : category) : actegory Mon_ptdendo [C,E]
   := lifted_actegory Mon_endo (actegoryfromprecomp C E) Mon_ptdendo
        (forget_monoidal_pointed_objects_monoidal Mon_endo).

 (* not possible without some transparent proofs
 Local Lemma actegoryPtdEndosOnFunctors_as_actegory_with_canonical_pointed_action :
   actegoryPtdEndosOnFunctors C = actegory_with_canonical_pointed_action Mon_endo.
 Proof.
   unfold actegoryPtdEndosOnFunctors.
   unfold actegoryfromprecomp.
   rewrite actegory_from_precomp_as_self_action.
   apply idpath.
 Qed.
*)

 Local Lemma action_in_actegoryPtdEndosOnFunctors_as_actegory_with_canonical_pointed_action :
   actegory_action Mon_ptdendo (actegoryPtdEndosOnFunctors C) =
     actegory_action Mon_ptdendo (actegory_with_canonical_pointed_action Mon_endo).
 Proof.
   use total2_paths_f.
   2: { apply WhiskeredBifunctors.isaprop_is_bifunctor. }
   cbn.
   apply idpath.
 Qed. (* slow *)

 (*
 Local Lemma lax_lineators_from_lifted_precomp_and_lifted_self_action_agree (F : functor [C, C] [C, C]) :
   lineator_lax Mon_ptdendo (actegoryPtdEndosOnFunctors C) (actegoryPtdEndosOnFunctors C) F ≃
     lineator_lax Mon_ptdendo (actegory_with_canonical_pointed_action Mon_endo)
       (actegory_with_canonical_pointed_action Mon_endo) F.
 Proof.
   use weqfibtototal. (* not seen to terminate *)
 *)

 Section AA.

 Context (H : [C, D'] ⟶ [C, D]).

 Lemma functor_comp_id_lax_specialized (F F' : C ⟶ D') (α: F ⟹ F') (β: F' ⟹ F)
   : nat_trans_comp α β  = nat_trans_id F -> nat_trans_comp (#H α) (#H β) =  nat_trans_id (pr1 (H F)).
 Proof.
   intro e.
   intermediate_path (#H (nat_trans_id F)).
   - rewrite <- e.
     change ( (# H α) · (# H β) = # H ((α:[C,D']⟦ F, F' ⟧) · (β:[C,D']⟦ F', F ⟧)) ).
     apply (! functor_comp _ _ _).
   - apply functor_id_id.
     apply idpath.
 Qed.

 Lemma weqABStrengthLaxMorphismActegories :
   actionbased_strength Mon_endo' (ActionBasedStrengthOnHomsInBicat.domain_action C D')
                                  (ActionBasedStrengthOnHomsInBicat.target_action C D) H
   ≃ lineator_lax Mon_ptdendo (actegoryPtdEndosOnFunctors D') (actegoryPtdEndosOnFunctors D) H.
 Proof.
   unfold actionbased_strength.
   unfold actionbased_strength_nat.
   unfold nat_trans.
   eapply weqcomp.
   { apply weqtotal2asstor. }
(*
   set (P := is_nat_trans (actionbased_strength_dom Mon_endo' (ActionBasedStrengthOnHomsInBicat.target_action C D) H)
               (actionbased_strength_codom Mon_endo' (ActionBasedStrengthOnHomsInBicat.domain_action C D') H)).
   set (Q := fun (ζ: actionbased_strength_nat Mon_endo' (ActionBasedStrengthOnHomsInBicat.domain_action C D')
         (ActionBasedStrengthOnHomsInBicat.target_action C D) H) => actionbased_strength_triangle_eq Mon_endo' (ActionBasedStrengthOnHomsInBicat.domain_action C D')
     (ActionBasedStrengthOnHomsInBicat.target_action C D) H ζ
   × actionbased_strength_pentagon_eq Mon_endo' (ActionBasedStrengthOnHomsInBicat.domain_action C D')
   (ActionBasedStrengthOnHomsInBicat.target_action C D) H ζ).
   (* a test for speeding up - not very successful (one would then use [Q'] in place of [Q] in the invocation of [weqtotal2asstor]):
      set (Q' := fun ζ: ∑ t: nat_trans_data (actionbased_strength_dom Mon_endo' (ActionBasedStrengthOnHomsInBicat.target_action C D) H)
                            (actionbased_strength_codom Mon_endo' (ActionBasedStrengthOnHomsInBicat.domain_action C D') H),
                    is_nat_trans (actionbased_strength_dom Mon_endo' (ActionBasedStrengthOnHomsInBicat.target_action C D) H)
             (actionbased_strength_codom Mon_endo' (ActionBasedStrengthOnHomsInBicat.domain_action C D') H) t  => Q ζ). *)
   exact (weqtotal2asstor P Q).
*)
   cbn.
   unfold actionbased_strength_triangle_eq, actionbased_strength_pentagon_eq.
   cbn.
   unfold lineator_lax.
   use weqbandf.
   - use weq_iso.
     + intros α v f. exact (α (f,,v)).
     + intros β fv. induction fv as [f v]. exact (β v f).
     + intro α. cbn. apply idpath.
     + intro β. cbn. apply idpath.
   - intro γ. cbn.
     use weqimplimpl.
     4: { apply isaprop_lineator_laxlaws. }
     3: { apply isapropdirprod ; [| apply isapropdirprod]; repeat (apply impred; intro); apply isaset_nat_trans; apply D. }
     + intro Hyps.
       induction Hyps as [Hypnat [Hyptriangle Hyppentagon]].
       red in Hypnat; cbn in Hypnat.
       repeat split.
       * intros v f1 f2 β.
         cbn.
         apply (nat_trans_eq D).
         intro x.
         cbn.
         assert (Hypnatinst := toforallpaths _ _ _ (maponpaths pr1 (Hypnat (f1,,v) (f2,,v)
                                                                      (β,,identity(C:=PointedFunctors.category_Ptd C) v))) x).
         cbn in Hypnatinst.
         rewrite (functor_id (H f1)) in Hypnatinst.
         rewrite post_whisker_identity in Hypnatinst.
         rewrite id_left in Hypnatinst.
         etrans.
         { exact Hypnatinst. }
         apply maponpaths.
         apply (maponpaths (fun z => pr1(# H z) x)).
         apply (@id_left [C,D'] _ _ ((pre_whisker (pr11 v)) β: functor_composite (pr1 v) f1 ⟹ functor_composite (pr1 v) f2)).
       * intros v1 v2 f α.
         cbn.
         apply (nat_trans_eq D).
         intro x.
         cbn.
         assert (Hypnatinst0 := Hypnat (f,,v1) (f,,v2)).
         transparent assert (αbetter : (PointedFunctors.category_Ptd C ⟦v1,v2⟧)).
         { use tpair.
           - exact (pr1 α).
           - intro c. unfold PointedFunctors.ptd_pt. apply (toforallpaths _ _ _ (maponpaths pr1 (pr2 α)) c).
         }
         assert (Hypnatinst := toforallpaths _ _ _ (maponpaths pr1
                             (Hypnat (f,,v1) (f,,v2) (catbinprodmor (identity(C:=functor_category C D') f) αbetter))) x).
         cbn in Hypnatinst.
         rewrite (functor_id (H)) in Hypnatinst.
         rewrite pre_whisker_identity in Hypnatinst.
         rewrite id_right in Hypnatinst.
         etrans.
         { exact Hypnatinst. }
         apply maponpaths.
         apply (maponpaths (fun z => pr1(# H z) x)).
         apply (@id_right [C,D'] _ _ ((post_whisker (pr1 α)) f: functor_composite (pr1 v1) f ⟹ functor_composite (pr1 v2) f)).
       * clear Hyptriangle.
         intros v w f.
         cbn.
         repeat rewrite post_whisker_identity.
         apply (nat_trans_eq D).
         intro x.
         cbn.
         assert (Hyppentagoninst0 := Hyppentagon f w v).
         clear Hyppentagon.
         repeat rewrite post_whisker_identity in Hyppentagoninst0.
         repeat rewrite pre_whisker_identity in Hyppentagoninst0.
         assert (Hyppentagoninst := toforallpaths _ _ _ (maponpaths pr1 Hyppentagoninst0) x).
         clear Hyppentagoninst0.
         cbn in Hyppentagoninst.
         rewrite id_right.
         rewrite id_left.
         do 4 rewrite id_left in Hyppentagoninst.
         unfold PointedFunctorsComposition.ptd_compose in Hyppentagoninst.
         cbn in Hyppentagoninst.
         unfold post_whisker_in_funcat, pre_whisker_in_funcat, PointedFunctors.ptd_pt in Hyppentagoninst.
         (* "morally", hypothesis and goal are the same. *)
         (* match goal with |[ H1 : _  = _ · ?f |- _ = _   ] => set (Hf := f) end. *)
         set (aux1 := pr1 (#H (identity(C:=[C,D']) (functor_composite (pr1 v) ((pr1 w) · f)) ·
                                 (identity _ · identity(C:=[C,D']) (functor_compose (pr1 v) (pr1 w) ∙ f)))) x).
         (* assert (auxH : Hf = aux1).
         { apply idpath. } *)
         match goal with |[ H1 : _  = _ · ?f |- _ = _   ] => change f with aux1 in H1 end.
         unfold aux1 in Hyppentagoninst.
         clear aux1.
         rewrite (functor_comp H) in Hyppentagoninst.
         rewrite id_left in Hyppentagoninst.
         rewrite (functor_id H) in Hyppentagoninst.
         rewrite id_left in Hyppentagoninst.
         (* match goal with | [ |- ?l _ · _ = _ ] => set (Hl := l) end. *)
         set (aux2 := nat_trans_data_from_nat_trans_funclass (γ (f,,functor_compose (pr1 v) (pr1 w),,
               identity(C:=[C,C]) _ · nat_trans_comp (post_whisker_in_funcat C C C (PointedFunctors.ptd_pt C v)
                        (functor_identity C)) (pre_whisker_in_funcat C C C (pr1 v) (PointedFunctors.ptd_pt C w))))).
         (* assert (auxH : Hl = aux2).
         { apply idpath. } *)
         match goal with | [ |- ?l _ · _ = _ ] => change l with aux2 end.
         unfold aux2.
         rewrite id_left.
         clear aux2.
         etrans.
         { apply cancel_postcomposition.
           exact Hyppentagoninst. }
         clear Hyppentagoninst.
         repeat rewrite assoc'.
         apply maponpaths.
         etrans.
         2: { apply id_right. }
         apply maponpaths.
         (* only # H applied to identities remains *)
         match goal with | [ |- _ ?l1 _ · _ ?l2 _ = _] => set (Hl1 := l1); set (Hl2 := l2)  end.
         assert (aux5: Hl1 · Hl2 = identity _).
         { apply functor_comp_id.
           apply (nat_trans_eq D').
           intro x'.
           cbn.
           rewrite id_left.
           apply id_left. }
         exact (toforallpaths _ _ _ (maponpaths pr1 aux5) x).
       * clear Hyppentagon.
         intro f.
         cbn.
         do 2 rewrite post_whisker_identity.
         unfold total_unit.
         apply (nat_trans_eq D).
         intro x.
         cbn.
         rewrite id_left.
         assert (Hyptriangleinst0 := Hyptriangle f).
         clear Hyptriangle.
         repeat rewrite pre_whisker_identity in Hyptriangleinst0.
         assert (Hyptriangleinst := toforallpaths _ _ _ (maponpaths pr1 Hyptriangleinst0) x).
         clear Hyptriangleinst0.
         cbn in  Hyptriangleinst.
         rewrite (functor_id (H f)) in Hyptriangleinst.
         do 2 rewrite id_left in Hyptriangleinst.
         etrans.
         2: { exact Hyptriangleinst. }
         clear Hyptriangleinst.
         apply maponpaths.
         (* match goal with | [ |- ?l _ = _ ] => set (Hl := l) end. *)
         set (aux3 := nat_trans_data_from_nat_trans_funclass
                        (# H ((identity (functor_compose (functor_identity C) f)) · (identity f)))).
         (* assert (Hl = aux3).
         { apply idpath. } *)
         match goal with | [ |- ?l _ = _ ] => change l with aux3 end.
         unfold aux3; clear aux3.
         rewrite id_left. rewrite functor_id.
         (* only # H applied to identities remains *)
         (* match goal with | [ |- _ = _ ?r _ ] => set (Hr := r) end. *)
         set (argtoH := nat_trans_comp
             (nat_trans_comp
                (post_whisker
                   (nat_z_iso_to_trans_inv
                      (make_nat_z_iso (functor_identity C) (functor_identity C) (nat_trans_id (functor_identity_data C))
                         (is_nat_z_iso_nat_trans_id (functor_identity C)))) f)
                (nat_trans_id (functor_composite_data (functor_identity_data C) (pr1 f)))) (nat_trans_id (pr1 f))).
         (* assert (G1: Hr = # H argtoH).
         { apply idpath. } *)
         match goal with | [ |- _ = _ ?r _ ] => change r with (# H argtoH) end.
         assert (G2: # H argtoH = identity(C:=[C,D]) (H (functor_identity C ∙ f))).
         { apply functor_id_id.
           apply nat_trans_eq_alt; intro c.
           cbn.
           do 2 rewrite id_right.
           apply functor_id.
         }
         rewrite G2.
         apply idpath.
     + (* the other direction that is very similar in spirit (but the two naturality laws give the composite one) *)
       intro Hyps. induction Hyps as [Hypnatleft [Hypnatright [Hypactor Hypunitor]]].
       repeat split.
       * red. intros f1v1 f2v2 βα. induction f1v1 as [f1 v1]; induction f2v2 as [f2 v2]; induction βα as [β α].
         cbn.
         red in Hypnatleft.
         assert (Hypnatleftinst := Hypnatleft v2 f1 f2 β).
         clear Hypnatleft.
         cbn in Hypnatleftinst.
         transparent assert (αbetter : (ptdendo ⟦v1,v2⟧)).
         { use tpair.
           - exact (pr1 α).
           - cbn. apply (nat_trans_eq C). intro c. cbn. apply (pr2 α).
         }
         assert (Hypnatrightinst := Hypnatright v1 v2 f1 αbetter).
         clear Hypnatright.
         cbn in Hypnatrightinst.
         change (((post_whisker_in_funcat _ _ _ (pr1 α) (H f1)) · (pre_whisker_in_funcat _ _ _ (pr1 v2) (# H β))) · (γ (f2,, v2)) =
                   nat_trans_comp (γ (f1,, v1)) (# H ((post_whisker_in_funcat _ _ _ (pr1 α) f1) · (pre_whisker_in_funcat _ _ _ (pr1 v2) β)))).
         rewrite assoc'.
         rewrite functor_comp.
         etrans.
         { apply maponpaths. exact Hypnatleftinst. }
         clear Hypnatleftinst.
         apply (nat_trans_eq D); intro x.
         cbn.
         repeat rewrite assoc.
         apply cancel_postcomposition.
         exact (toforallpaths _ _ _ (maponpaths pr1 Hypnatrightinst) x).
       * clear Hypnatleft Hypnatright Hypactor.
         intro f.
         do 2 rewrite pre_whisker_identity.
         apply (nat_trans_eq D); intro x. cbn.
         rewrite (functor_id (H f)).
         do 2 rewrite id_left.
         assert (Hypunitorinst0 := Hypunitor f).
         cbn in Hypunitorinst0.
         do 2 rewrite post_whisker_identity in Hypunitorinst0.
         assert (Hypunitorinst := toforallpaths _ _ _ (maponpaths pr1 Hypunitorinst0) x).
         clear Hypunitorinst0.
         cbn in Hypunitorinst.
         rewrite id_right in Hypunitorinst.
         unfold total_unit in Hypunitorinst.
         etrans.
         2: { exact Hypunitorinst. }
         clear Hypunitorinst.
         apply maponpaths.
         (* only # H applied to identities remains *)
         (* match goal with | [ |- _ = _ ?r _ ] => set (Hr := r) end. *)
         set (aux3 := # H ((identity (functor_compose (functor_identity C) f)) · (identity(C:=[C,D']) f))).
         match goal with | [ |- _ = _ ?r _ ] => change r with aux3 end.
         unfold aux3; clear aux3.
         rewrite id_left.
         rewrite functor_id.
         set (argtoH := nat_trans_comp
             (nat_trans_comp
                (post_whisker
                   (nat_z_iso_to_trans_inv
                      (make_nat_z_iso (functor_identity C) (functor_identity C) (nat_trans_id (functor_identity_data C))
                         (is_nat_z_iso_nat_trans_id (functor_identity C)))) f)
                (nat_trans_id (functor_composite_data (functor_identity_data C) (pr1 f)))) (nat_trans_id (pr1 f))).
         match goal with | [ |- _ ?l _ = _ ] => change l with (# H argtoH) end.
         assert (G2': # H argtoH = identity(C:=[C,D]) (H (functor_identity C ∙ f))).
         { apply functor_id_id.
           apply nat_trans_eq_alt; intro c.
           cbn.
           do 2 rewrite id_right.
           apply functor_id.
         }
         rewrite G2'.
         apply idpath.
       * (* the pentagon law as last remaining proof obligation *)
         clear Hypnatleft Hypnatright Hypunitor.
         intros f w v.
         assert (Hypactorinst0 := Hypactor v w f).
         cbn in Hypactorinst0.
         repeat rewrite post_whisker_identity in Hypactorinst0.
         do 3 rewrite post_whisker_identity.
         do 2 rewrite pre_whisker_identity.
         apply (nat_trans_eq D); intro x. cbn.
         repeat rewrite id_left.
         assert (Hypactorinst := toforallpaths _ _ _ (maponpaths pr1 Hypactorinst0) x).
         clear Hypactorinst0. cbn in Hypactorinst.
         do 2 rewrite id_left in Hypactorinst.
         etrans.
         2: { apply cancel_postcomposition.
              exact Hypactorinst. }
         clear Hypactorinst.
         rewrite assoc'.
         etrans.
         { apply pathsinv0, id_right. }
         (* match goal with | [ |- _ = ?r _ · _ ] => set (Hr := r) end. *)
         set (aux6 := nat_trans_data_from_nat_trans_funclass (γ (f,,functor_compose (pr1 v) (pr1 w),,
               identity(C:=[C,C]) _ · nat_trans_comp (post_whisker_in_funcat C C C (PointedFunctors.ptd_pt C v)
                        (functor_identity C)) (pre_whisker_in_funcat C C C (pr1 v) (PointedFunctors.ptd_pt C w))))).
         (* assert (auxH : Hr = aux6).
         { apply idpath. } *)
         match goal with | [ |- _ = ?r _ · _ ] => change r with aux6 end.
         unfold aux6. clear aux6.
         rewrite id_left.
         apply maponpaths.
         (* only # H applied to identities remains *)
         (* match goal with |[ |- _  = _ · ?f ] => set (Hf := f) end. *)
         set (aux5' := pr1 (#H (identity(C:=[C,D']) (functor_composite (pr1 v) (functor_composite (pr1 w) f)) ·
                                  (identity (C:=[C,D'])(functor_composite (functor_composite (pr1 v) (pr1 w)) f) ·
                                     identity(C:=[C,D']) (functor_compose (pr1 v) (pr1 w) ∙ f)))) x).
         (* assert (auxH : Hf = aux5').
         { apply idpath. } *)
         match goal with |[ |- _  = _ · ?f ] => change f with aux5' end.
         unfold aux5'. clear aux5'.
         rewrite (functor_comp H).
         rewrite id_left.
         rewrite (functor_id H).
         rewrite id_left.
         apply pathsinv0.
         match goal with | [ |- _ ?l1 _ · _ ?l2 _ = _] => set (Hl1 := l1); set (Hl2 := l2) end.
         (* It looked like being stuck. One cannot proceed as in the opposite direction stating aux7: Hl1 · Hl2 = identity _ because this does not type-check.
            But one can state: *)
         assert (aux7: nat_trans_comp Hl1 Hl2 = nat_trans_id _).
         2: { exact (toforallpaths _ _ _ (maponpaths pr1 aux7) x). }
         (* but how can we prove it? Is there something like functor_comp_id available?
            Yes, specialized for the situation with endofunctor categories as domain a codomain *)
         apply functor_comp_id_lax_specialized.
         apply nat_trans_eq_alt.
         intro x'.
         cbn.
         rewrite id_left.
         apply id_left.
 Defined.

End AA.

 Lemma weqSignatureLaxMorphismActegories :
   Signature C D D' ≃ hom(C:=actbicat Mon_ptdendo) ([C, D'],,actegoryPtdEndosOnFunctors D') ([C, D],,actegoryPtdEndosOnFunctors D).
 Proof.
   apply (weqcomp weqSignatureABStrength).
   apply weqfibtototal.
   intro H.
   apply weqABStrengthLaxMorphismActegories.
 Defined.

 Lemma weqSignatureLaxMorphismActegories_alt :
   Signature C D D' ≃ hom(C:=actbicat Mon_ptdendo) (hom(C:=bicat_of_cats) C D',,actegoryPtdEndosOnFunctors D') (hom(C:=bicat_of_cats) C D,,actegoryPtdEndosOnFunctors D).
 Proof.
   apply (weqcomp weqSignatureLaxMorphismActegories).
   apply weqfibtototal.
   intro H.
   exact (idweq _).
 Defined. (* slow *)

 (* a direct proof without going through weqSignatureLaxMorphismActegories:
 Lemma weqSignatureLaxMorphismActegories_alt_alt :
   Signature C D D' ≃ hom(C:=actbicat Mon_ptdendo) (hom(C:=bicat_of_cats) C D',,actegoryPtdEndosOnFunctors D') (hom(C:=bicat_of_cats) C D,,actegoryPtdEndosOnFunctors D).
 Proof.
   apply (weqcomp weqSignatureABStrength).
   apply weqfibtototal.
   intro H.
   apply weqABStrengthLaxMorphismActegories. (* very slow *)
 Defined. (* very slow *)
*)

End A.

Section HomogeneousCase.

 Context (C : category).
 (** this part can be resurrected with some transparent proofs, or hopefully by moving to pointed tensorial strength that is not instantiated from bicategories *)
 (*
 Corollary weqSignatureLaxMorphismActegoriesHomogeneous :
   Signature C C C ≃ ∑ H : endofrombicat C ⟶ endofrombicat C, pointedtensorialstrength (Mon_endo C) H.
 Proof.
   eapply weqcomp.
   { apply weqSignatureLaxMorphismActegories_alt. }
   cbn.
   apply weqfibtototal.
   intro H.
   unfold pointedtensorialstrength.
   rewrite (actegoryPtdEndosOnFunctors_as_actegory_with_canonical_pointed_action C).
   apply idweq.
 Defined.

 Corollary weqSignatureLaxMorphismActegoriesHomogeneous_alt :
   Signature C C C ≃ ∑ H : [C, C] ⟶ [C, C], pointedtensorialstrength (Mon_endo C) H.
 Proof.
   cbn.
   apply (weqcomp weqSignatureLaxMorphismActegoriesHomogeneous).
   apply weqfibtototal.
   intro H.
   apply idweq.
 Defined.
  *)

End HomogeneousCase.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B C Oprime Aprime Bprime Cprime Eprimeprime Bprimeprime : Universe, ((wd_ O E /\ (wd_ Oprime Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ A E /\ (wd_ Eprimeprime O /\ (wd_ O Oprime /\ (wd_ A Aprime /\ (wd_ Eprimeprime A /\ (wd_ E Eprimeprime /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ Oprime Eprimeprime /\ (wd_ E Oprime /\ (wd_ Oprime Aprime /\ (wd_ C Cprime /\ (wd_ B Bprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ Oprime Eprime Aprime /\ (col_ Oprime Eprime Bprime /\ (col_ Oprime Eprime Cprime /\ (col_ O Eprimeprime Bprimeprime /\ (col_ O Eprimeprime Eprimeprime /\ (col_ O Eprimeprime Oprime /\ (col_ O Eprimeprime Aprime /\ (col_ O A A /\ (col_ O A Aprime /\ col_ Eprimeprime A Aprime)))))))))))))))))))))))))))))) -> col_ Aprime O E)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj16eqsynthconj4 : forall  (lv0 : natural), (@eq natural (Succ lv0) (plus (Succ Zero) lv0)).
Admitted.
QuickChick conj16eqsynthconj4.


Require Import Verse.
Require Import Verse.Arch.C.
Require Import Verse.Types.Internal.
Require Import Semantics.

Import StandardSemantics.
Open Scope semantic_scope.

Import NArith.
Require Import Vector.
Import VectorNotations.

Set Implicit Arguments.

Section TestFunction.

  Variable variable : VariableT.

  Arguments variable [k] _.
  (* The parameters of the function *)
  Variable arr     : variable (Array 5 bigE Word16).
  Variable A B     : variable Byte.

  Definition parameters := [Var arr; Var A; Var B].

  (* The local variables *)
  Variable num      : variable Word16.

  Definition locals := [Var num].

  (* The temp register *)
  Variable tmp       : variable Word16.

  Definition registers := [Var tmp].
  Definition regAssignment := (- cr uint16_t "temp" -).
  Definition someInstruction i (_ : i < 5) : code variable.
    Import Nat.
    verse [ arr[- i -] ::=^ arr[- (i + 1) mod 5 -] ]%list.
  Defined.

  Definition testFunction : code variable.
    verse
      [ num ::= tmp + Ox "abcd";

        ASSERT num HAD n ; tmp HAS t IN n = (t RotR 2) XOR n;

        ASSERT A HAS a; num HAD n ; tmp HAD t IN (n = t) /\ (t = n);

        A   ::= A + B;
        num ::= tmp - num ;

        ASSERT num HAD n ; tmp HAS t IN n = t;
        ASSERT num HAS n IN (n = n);

        ASSERT num HAD n' ; num HAS n IN (n = n')%N;

        ASSERT num HAD n' ; num HAS n IN (n = n')%N;

        ASSERT A HAS a IN (2 = 3)%N;

        arr[-1-] ::= num;
        num      ::= tmp      * arr[-1-];

        ASSERT num HAD n ; tmp HAS t ; A HAS a IN (and (n = t) (n = n))%N;

        num      ::= arr[-1-] / tmp ;

        (* binary update *)
        num ::=+ tmp;
        num ::=- arr[-1-];
        num ::=* Ox "1234";
        num ::=/ tmp;

        ASSERT num HAD n ; tmp HAD t ; num HAS n' IN
               (and (n' = t) (n' = n))%N;

        CLOBBER arr
      ]%list.
  Defined.

End TestFunction.

Import StandardTactics.
(*
Inductive var : VariableT :=
| arr : var (Array 5 bigE Word16)
| A : var Byte
| B : var Byte
| num : var Word16
| tmp : var Word16
.

Definition var_eqb {k} {ty : type k} (v1 v2 : var ty) : bool :=
  match v1, v2 with
  | arr, arr => true
  | A, A     => true
  | B, B
  | num, num
  | tmp, tmp => true
  | _, _     => false
  end.
 *)

Definition toProve : Prop.
  extractSAT testFunction.
Defined.

(* A potential proof template *)

Definition proof : toProve.
  time (
  unfold toProve;
  unfold genSAT;
  unfold SAT;
  breakStore;
  lazy -[RotRW RotLW ShiftRW ShiftLW XorW AndW OrW NegW
              fromNibbles
              numBinOp numUnaryOp numBigargExop numOverflowBinop
              Nat.add Nat.sub Nat.mul Nat.div
              N.add N.sub N.mul N.div N.div_eucl N.modulo
              Ox nth replace]).
Abort.

Import Compile.

Definition testcode : Doc + {Compile.CompileError}.
  Compile.function "testFunction" parameters locals registers.
  assignRegisters regAssignment.
  statements testFunction.
Defined.

Compute (tryLayout testcode).

(*

Require Import Verse.Extraction.Ocaml.

Definition main : unit := print_code testcode.

Recursive Extraction main.

 *)


(**********************************************************************

 The enriched univalent Kleisli category

 We construct an enrichment of the univalent Kleisli category. Note
 that since this category is defined as a subcategory of the
 Eilenberg-Moore category, we assume that the monoidal category over
 which we enrich, has equalizers.

 Contents
 1. Enrichment of the free algebra functor
 2. Enrichment of the univalent Kleisli category
 3. Functor to the Kleisli category
 4. Functor between the two different versions of the Kleisli category
 5. The functor is fully faithful

 **********************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Subcategory.Core.
Require Import UniMath.CategoryTheory.Subcategory.Full.
Require Import UniMath.CategoryTheory.categories.Dialgebras.
Require Import UniMath.CategoryTheory.categories.EilenbergMoore.
Require Import UniMath.CategoryTheory.categories.KleisliCategory.
Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment.
Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor.
Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation.
Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentMonad.
Require Import UniMath.CategoryTheory.EnrichedCats.Examples.DialgebraEnriched.
Require Import UniMath.CategoryTheory.EnrichedCats.Examples.EilenbergMooreEnriched.
Require Import UniMath.CategoryTheory.EnrichedCats.Examples.FullSubEnriched.
Require Import UniMath.CategoryTheory.EnrichedCats.Examples.ImageEnriched.
Require Import UniMath.CategoryTheory.EnrichedCats.Examples.KleisliEnriched.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.Monads.KleisliCategory.
Require Import UniMath.CategoryTheory.limits.equalizers.

Local Open Scope cat.
Local Open Scope moncat.

Section EnrichedKleisli.
  Context {V : monoidal_cat}
          (HV : Equalizers V)
          {C : category}
          {E : enrichment C V}
          {M : Monad C}
          (EM : monad_enrichment E M).

  (**
   1. Enrichment of the free algebra functor
   *)
  Definition free_alg_enrichment_mor
             (x y : C)
    : E ⦃ x, y ⦄
      -->
      eilenberg_moore_enrichment HV EM ⦃ free_alg_em M x, free_alg_em M y ⦄.
  Proof.
    use EqualizerIn.
    - exact (EM x y).
    - abstract
        (cbn ;
         unfold dialgebra_enrichment_mor_left ;
         unfold dialgebra_enrichment_mor_right ;
         cbn ;
         rewrite id_left ;
         rewrite !assoc ;
         etrans ;
         [ do 2 apply maponpaths_2 ;
           apply tensor_rinvunitor
         | ] ;
         rewrite !assoc' ;
         etrans ;
         [ apply maponpaths ;
           rewrite !assoc ;
           apply maponpaths_2 ;
           exact (!(tensor_split' _ _))
         | ] ;
         rewrite !assoc ;
         refine (mu_of_monad_enrichment EM x y @ _) ;
         apply maponpaths_2 ;
         cbn ;
         refine (!_) ;
         etrans ;
         [ apply maponpaths_2 ;
           apply tensor_linvunitor
         | ] ;
         rewrite !assoc' ;
         apply maponpaths ;
         refine (!_) ;
         apply tensor_split).
  Defined.

  Definition free_alg_enrichment_mor_incl
             (x y : C)
    : free_alg_enrichment_mor x y
      · dialgebra_enrichment_mor_incl V HV EM (functor_id_enrichment E) (μ M x) (μ M y)
      =
      EM x y.
  Proof.
    apply EqualizerCommutes.
  Qed.

  Definition free_alg_enrichment_laws
    : is_functor_enrichment free_alg_enrichment_mor.
  Proof.
    repeat split.
    - intro x.
      use (dialgebra_enrichment_mor_eq_of_mor
             V HV
             EM (functor_id_enrichment E)).
      rewrite !assoc'.
      rewrite free_alg_enrichment_mor_incl.
      refine (!_).
      etrans.
      {
        apply dialgebra_enrichment_id_incl.
      }
      refine (!_).
      apply functor_enrichment_id.
    - intros x y z.
      use (dialgebra_enrichment_mor_eq_of_mor
             V HV
             EM (functor_id_enrichment E)).
      rewrite !assoc'.
      rewrite free_alg_enrichment_mor_incl.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        apply dialgebra_enrichment_comp_incl.
      }
      unfold dialgebra_enrichment_comp_mor.
      cbn.
      rewrite !assoc.
      etrans.
      {
        apply maponpaths_2.
        refine (!_).
        apply tensor_comp_mor.
      }
      rewrite !free_alg_enrichment_mor_incl.
      refine (!_).
      apply functor_enrichment_comp.
    - intros x y f.
      use (dialgebra_enrichment_mor_eq_of_mor
             V HV
             EM (functor_id_enrichment E)).
      rewrite !assoc'.
      rewrite free_alg_enrichment_mor_incl.
      etrans.
      {
        apply dialgebra_enrichment_from_arr_incl.
      }
      apply functor_enrichment_from_arr.
  Qed.

  Definition free_alg_enrichment
    : functor_enrichment
        (free_alg_em M)
        E
        (eilenberg_moore_enrichment HV EM).
  Proof.
    simple refine (_ ,, _).
    - exact free_alg_enrichment_mor.
    - exact free_alg_enrichment_laws.
  Defined.

  (**
    2. Enrichment of the univalent Kleisli category
   *)
  Definition Kleisli_cat_enrichment
    : enrichment (kleisli_cat M) V.
  Proof.
    use image_enrichment.
    exact (eilenberg_moore_enrichment HV EM).
  Defined.

  (**
   3. Functor to the Kleisli category
   *)
  Definition kleisli_incl_enrichment
    : functor_enrichment
        (kleisli_incl M)
        E
        Kleisli_cat_enrichment.
  Proof.
    use image_proj_enrichment.
    exact free_alg_enrichment.
  Defined.

  (**
   4. Functor between the two different versions of the Kleisli category
   *)
  Definition functor_to_kleisli_cat_enrichment_mor
             (x y : C)
    : E ⦃ x, M y ⦄ --> E ⦃ M x, M y ⦄
    := mon_linvunitor _
       · enriched_from_arr E (μ M y) #⊗ EM x (M y)
       · enriched_comp E (M x) (M(M y)) (M y).

  Definition functor_to_kleisli_cat_enrichment_eq
             (x y : C)
    : functor_to_kleisli_cat_enrichment_mor x y
      · @dialgebra_enrichment_mor_left
           V C C
           M (functor_identity C)
           E E
           (functor_id_enrichment E)
           (M x) (M y)
           (μ M x) (μ M y)
      =
      functor_to_kleisli_cat_enrichment_mor x y
      · @dialgebra_enrichment_mor_right
           V C C
           M (functor_identity C)
           E E
           EM
           (M x) (M y)
           (μ M x) (μ M y).
  Proof.
    unfold dialgebra_enrichment_mor_left.
    unfold dialgebra_enrichment_mor_right.
    unfold functor_to_kleisli_cat_enrichment_mor.
    cbn.
    rewrite !id_left.
    rewrite !assoc'.
    refine (!_).
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !assoc.
      do 3 apply maponpaths_2.
      apply (functor_enrichment_comp EM).
    }
    rewrite !assoc'.
    etrans.
    {
      do 3 apply maponpaths.
      rewrite !assoc.
      etrans.
      {
        do 2 apply maponpaths_2.
        apply tensor_linvunitor.
      }
      rewrite !assoc'.
      apply maponpaths.
      etrans.
      {
        rewrite !assoc.
        apply maponpaths_2.
        etrans.
        {
          refine (!_).
          apply tensor_split.
        }
        apply tensor_split'.
      }
      rewrite !assoc'.
      apply maponpaths.
      apply enrichment_assoc'.
    }
    rewrite !assoc'.
    refine (!_).
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !assoc.
      etrans.
      {
        do 2 apply maponpaths_2.
        apply tensor_rinvunitor.
      }
      rewrite !assoc'.
      apply maponpaths.
      etrans.
      {
        rewrite !assoc.
        apply maponpaths_2.
        etrans.
        {
          refine (!_).
          apply tensor_split'.
        }
        apply tensor_split.
      }
      rewrite !assoc'.
      apply maponpaths.
      apply enrichment_assoc.
    }
    apply maponpaths.
    etrans.
    {
      etrans.
      {
        apply maponpaths_2.
        apply tensor_split'.
      }
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      etrans.
      {
        do 4 apply maponpaths_2.
        apply tensor_rinvunitor.
      }
      rewrite !assoc'.
      etrans.
      {
        apply maponpaths.
        rewrite !assoc.
        do 2 apply maponpaths_2.
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            do 2 apply maponpaths_2.
            refine (!_).
            apply tensor_id_id.
          }
          apply tensor_lassociator.
        }
        rewrite !assoc.
        apply maponpaths_2.
        apply tensor_lassociator.
      }
      rewrite !assoc.
      etrans.
      {
        do 4 apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          refine (!_).
          apply mon_rinvunitor_triangle.
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          apply mon_rassociator_lassociator.
        }
        apply id_right.
      }
      apply maponpaths_2.
      etrans.
      {
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          refine (!_).
          apply tensor_comp_id_l.
        }
        refine (!_).
        apply tensor_comp_id_l.
      }
      refine (!_).
      apply tensor_comp_id_l.
    }
    etrans.
    {
      apply maponpaths.
      apply maponpaths_2.
      apply maponpaths.
      rewrite !assoc'.
      etrans.
      {
        apply maponpaths.
        rewrite !assoc.
        apply maponpaths_2.
        refine (!_).
        apply tensor_comp_mor.
      }
      rewrite id_left, id_right.
      rewrite !assoc.
      exact (mu_of_monad_enrichment EM x (M y)).
    }
    cbn.
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths_2.
        apply tensor_comp_id_l.
      }
      rewrite !assoc'.
      apply maponpaths.
      apply enrichment_assoc'.
    }
    rewrite !assoc.
    apply maponpaths_2.
    etrans.
    {
      apply maponpaths_2.
      rewrite !assoc'.
      apply maponpaths.
      apply maponpaths_2.
      apply tensor_comp_id_l.
    }
    etrans.
    {
      rewrite !assoc.
      do 3 apply maponpaths_2.
      refine (!(tensor_split' _ _) @ _).
      apply tensor_split.
    }
    refine (!_).
    etrans.
    {
      do 3 apply maponpaths_2.
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply mon_linvunitor_triangle.
      }
      rewrite !assoc.
      apply maponpaths_2.
      etrans.
      {
        apply maponpaths_2.
        exact (!(tensor_comp_mor _ _ _ _)).
      }
      refine (!(tensor_comp_mor _ _ _ _) @ _).
      rewrite id_right.
      etrans.
      {
        apply maponpaths_2.
        apply tensor_linvunitor.
      }
      apply tensor_comp_mor.
    }
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        rewrite !assoc.
        do 2 apply maponpaths_2.
        etrans.
        {
          do 2 apply maponpaths.
          refine (!_).
          apply tensor_id_id.
        }
        refine (!_).
        apply tensor_lassociator.
      }
      rewrite !assoc'.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          apply mon_lassociator_rassociator.
        }
        apply id_left.
      }
      etrans.
      {
        apply maponpaths.
        refine (!(tensor_comp_mor _ _ _ _) @ _).
        rewrite id_left.
        apply idpath.
      }
      refine (!(tensor_comp_mor _ _ _ _) @ _).
      rewrite id_right.
      apply maponpaths_2.
      rewrite !assoc.
      apply maponpaths_2.
      refine (!(tensor_split _ _) @ _).
      apply idpath.
    }
    assert (enriched_from_arr E (μ M y) #⊗ (enriched_from_arr E (μ M y) · EM (M (M y)) (M y))
            · enriched_comp E (M (M (M y))) (M (M y)) (M y)
            =
            enriched_from_arr E (μ M y) #⊗ enriched_from_arr E (μ M (M y))
            · enriched_comp E (M (M (M y))) (M (M y)) (M y))
      as p.
    {
      pose (maponpaths
              (λ z, mon_lunitor _ · enriched_from_arr E z)
              (@Monad_law3 _ M y))
        as p.
      cbn in p.
      rewrite !enriched_from_arr_comp in p.
      rewrite (functor_enrichment_from_arr EM) in p.
      rewrite !assoc in p.
      refine (_ @ p @ _).
      - refine (!(id_left _) @ _).
        rewrite !assoc.
        do 2 apply maponpaths_2.
        refine (!_).
        apply mon_lunitor_linvunitor.
      - refine (_ @ id_left _).
        rewrite !assoc.
        do 2 apply maponpaths_2.
        apply mon_lunitor_linvunitor.
    }
    etrans.
    {
      apply maponpaths.
      apply maponpaths_2.
      exact p.
    }
    clear p.
    etrans.
    {
      apply maponpaths.
      apply tensor_comp_r_id_r.
    }
    rewrite !assoc.
    apply maponpaths_2.
    refine (!_).
    rewrite !assoc'.
    etrans.
    {
      do 2 apply maponpaths.
      apply tensor_rassociator.
    }
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths_2.
        apply maponpaths.
        refine (!_).
        apply tensor_id_id.
      }
      rewrite !assoc.
      etrans.
      {
        apply maponpaths_2.
        apply tensor_rassociator.
      }
      rewrite !assoc'.
      apply maponpaths.
      refine (!(tensor_comp_mor _ _ _ _) @ _).
      rewrite id_left.
      etrans.
      {
        apply maponpaths_2.
        exact (!(tensor_split' _ _)).
      }
      apply tensor_comp_l_id_l.
    }
    rewrite !assoc.
    apply maponpaths_2.
    etrans.
    {
      apply maponpaths_2.
      etrans.
      {
        apply maponpaths_2.
        apply mon_inv_triangle.
      }
      rewrite !assoc'.
      etrans.
      {
        apply maponpaths.
        apply mon_lassociator_rassociator.
      }
      apply id_right.
    }
    etrans.
    {
      refine (!_).
      apply tensor_split'.
    }
    apply maponpaths_2.
    apply mon_rinvunitor_I_mon_linvunitor_I.
  Qed.

  Definition functor_to_kleisli_cat_enrichment_data
             (x y : C)
    :  E ⦃ x, M y ⦄
       -->
       dialgebra_enrichment_mor V HV EM (functor_id_enrichment E) (μ M x) (μ M y).
  Proof.
    use EqualizerIn.
    - exact (functor_to_kleisli_cat_enrichment_mor x y).
    - exact (functor_to_kleisli_cat_enrichment_eq x y).
  Defined.

  Definition functor_to_kleisli_cat_enrichment_data_incl
             (x y : C)
    : functor_to_kleisli_cat_enrichment_data x y
      · dialgebra_enrichment_mor_incl _ _ _ _ _ _
      =
      functor_to_kleisli_cat_enrichment_mor x y.
  Proof.
    apply EqualizerCommutes.
  Qed.

  Definition functor_to_kleisli_cat_enrichment_is_enrichment
    : @is_functor_enrichment
        _ _ _
        (functor_to_kleisli_cat M)
        (Kleisli_cat_monad_enrichment EM)
        Kleisli_cat_enrichment
        functor_to_kleisli_cat_enrichment_data.
  Proof.
    repeat split.
    - intros x ; cbn.
      use (dialgebra_enrichment_mor_eq_of_mor
             V HV
             EM (functor_id_enrichment E)).
      refine (!_).
      refine (dialgebra_enrichment_id_incl _ _ _ _ _ @ _).
      refine (!_).
      rewrite !assoc'.
      etrans.
      {
        apply maponpaths.
        apply functor_to_kleisli_cat_enrichment_data_incl.
      }
      unfold functor_to_kleisli_cat_enrichment_mor.
      rewrite <- enriched_from_arr_id.
      rewrite <- (@Monad_law2 _ M x).
      rewrite enriched_from_arr_comp ; cbn.
      rewrite !assoc.
      apply maponpaths_2.
      etrans.
      {
        apply maponpaths_2.
        apply tensor_linvunitor.
      }
      rewrite !assoc'.
      apply maponpaths.
      refine (!(tensor_comp_mor _ _ _ _) @ _).
      rewrite id_left.
      apply maponpaths.
      rewrite <- (functor_enrichment_from_arr EM).
      apply idpath.
    - (**
       The proof for this goal is in essence that for all

         f : x --> M y
         g : y --> M z

       we have

       (#M f · μ M y) · (#M g · μ M z)
       =
       #M f · (μ M y · (#M g · μ M z))
       =
       #M f · ((μ M y · #M g) · μ M z)
       =
       #M f · ((#M (#M g) · μ M z) · μ M z)
       =
       #M f · (#M (#M g) · (μ M z · μ M z))
       =
       (#M f · #M (#M g)) · (μ M z · μ M z))
       =
       #M (f · #M g) · (μ M z · μ M z)
       =
       #M(f · #M g) · (#M (μ M z) · μ M z)
       =
       (#M(f · #M g) · #M (μ M z)) · μ M z
       =
       #M((f · #M g) · μ M z) · μ M z
       *)
      intros x y z ; cbn.
      use (dialgebra_enrichment_mor_eq_of_mor
             V HV
             EM (functor_id_enrichment E)).
      rewrite !assoc'.
      etrans.
      {
        do 5 apply maponpaths.
        apply functor_to_kleisli_cat_enrichment_data_incl.
      }
      refine (!_).
      etrans.
      {
        apply maponpaths.
        apply dialgebra_enrichment_comp_incl.
      }
      unfold dialgebra_enrichment_comp_mor.
      rewrite !assoc.
      etrans.
      {
        apply maponpaths_2.
        refine (!(tensor_comp_mor _ _ _ _) @ _).
        etrans.
        {
          apply maponpaths.
          apply functor_to_kleisli_cat_enrichment_data_incl.
        }
        apply maponpaths_2.
        apply functor_to_kleisli_cat_enrichment_data_incl.
      }
      unfold functor_to_kleisli_cat_enrichment_mor.
      rewrite !assoc'.
      etrans.
      {
        etrans.
        {
          apply maponpaths_2.
          rewrite !assoc.
          apply tensor_comp_l_id_r.
        }
        rewrite !assoc'.
        apply maponpaths.
        apply enrichment_assoc'.
      }
      rewrite !assoc'.
      etrans.
      {
        rewrite !assoc.
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          rewrite tensor_comp_mor.
          rewrite !assoc'.
          apply maponpaths.
          apply tensor_rassociator.
        }
        rewrite !assoc'.
        do 2 apply maponpaths.
        etrans.
        {
          apply maponpaths_2.
          apply tensor_split.
        }
        rewrite !assoc'.
        apply maponpaths.
        refine (!(tensor_comp_id_r _ _) @ _).
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          apply tensor_split.
        }
        rewrite !assoc'.
        apply maponpaths.
        apply enrichment_assoc.
      }
      cbn.
      etrans.
      {
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        apply maponpaths_2.
        rewrite !assoc'.
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          rewrite !assoc.
          do 3 apply maponpaths_2.
          etrans.
          {
            do 2 apply maponpaths_2.
            refine (!_).
            apply tensor_id_id.
          }
          apply tensor_lassociator.
        }
        etrans.
        {
          apply maponpaths.
          rewrite !assoc'.
          apply tensor_comp_id_r.
        }
        rewrite !assoc.
        apply maponpaths_2.
        refine (!(tensor_comp_mor _ _ _ _) @ _).
        rewrite id_right.
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          etrans.
          {
            refine (!_).
            apply tensor_id_id.
          }
          apply maponpaths_2.
          refine (!_).
          apply tensor_id_id.
        }
        apply tensor_lassociator.
      }
      etrans.
      {
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          apply maponpaths.
          apply tensor_split'.
        }
        rewrite !assoc.
        apply tensor_split.
      }
      rewrite !assoc'.
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          apply maponpaths_2.
          rewrite !assoc.
          apply tensor_comp_id_r.
        }
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          do 3 apply maponpaths_2.
          etrans.
          {
            apply maponpaths_2.
            apply maponpaths.
            refine (!_).
            apply tensor_id_id.
          }
          apply tensor_rassociator.
        }
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          refine (!(tensor_comp_mor _ _ _ _) @ _).
          rewrite id_left.
          rewrite !assoc.
          etrans.
          {
            do 2 apply maponpaths_2.
            apply tensor_lassociator.
          }
          rewrite !assoc'.
          apply tensor_split'.
        }
        etrans.
        {
          do 2 apply maponpaths_2.
          apply tensor_comp_r_id_l.
        }
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          apply maponpaths.
          apply tensor_comp_id_r.
        }
        rewrite !assoc.
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          refine (!(tensor_comp_mor _ _ _ _) @ _).
          rewrite id_left, id_right.
          apply idpath.
        }
        refine (!(tensor_comp_mor _ _ _ _) @ _).
        rewrite id_right.
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths.
          refine (!_).
          apply tensor_comp_id_l.
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          refine (!_).
          apply tensor_comp_id_l.
        }
        etrans.
        {
          refine (!_).
          apply tensor_comp_id_l.
        }
        apply maponpaths.
        etrans.
        {
          etrans.
          {
            apply maponpaths.
            rewrite !assoc.
            apply maponpaths_2.
            exact (!(tensor_split' _ _)).
          }
          rewrite !assoc.
          apply maponpaths_2.
          exact (!(tensor_split' _ _)).
        }
        pose (maponpaths
                (λ z, mon_runitor _ · z)
                (mu_of_monad_enrichment EM y (M z))) as p.
        cbn in p.
        refine (_ @ p).
        refine (!_).
        rewrite !assoc.
        etrans.
        {
          do 2 apply maponpaths_2.
          apply mon_runitor_rinvunitor.
        }
        rewrite id_left.
        apply idpath.
      }
      rewrite !assoc'.
      etrans.
      {
        do 4 apply maponpaths.
        rewrite !assoc.
        apply maponpaths_2.
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths_2.
          rewrite !assoc.
          etrans.
          {
            apply maponpaths_2.
            apply tensor_comp_id_l.
          }
          apply tensor_split.
        }
        rewrite !assoc'.
        apply maponpaths.
        refine (!(tensor_comp_id_r _ _) @ _).
        rewrite !assoc'.
        apply maponpaths_2.
        apply maponpaths.
        apply enrichment_assoc'.
      }
      rewrite !assoc'.
      etrans.
      {
        do 5 apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          apply tensor_comp_id_r.
        }
        rewrite !assoc'.
        apply maponpaths.
        apply enrichment_assoc.
      }
      etrans.
      {
        do 4 apply maponpaths.
        rewrite !assoc.
        apply maponpaths_2.
        etrans.
        {
          do 2 apply maponpaths_2.
          refine (!(tensor_comp_mor _ _ _ _) @ _).
          rewrite id_right.
          rewrite id_left.
          rewrite !assoc'.
          etrans.
          {
            do 2 apply maponpaths_2.
            apply maponpaths.
            rewrite assoc.
            apply maponpaths.
            apply tensor_comp_l_id_r.
          }
          etrans.
          {
            apply maponpaths_2.
            rewrite !assoc.
            etrans.
            {
              apply maponpaths_2.
              etrans.
              {
                apply maponpaths_2.
                apply tensor_comp_id_l.
              }
              rewrite !assoc'.
              apply maponpaths.
              apply tensor_rassociator.
            }
            rewrite !assoc'.
            do 2 apply maponpaths.
            etrans.
            {
              do 2 apply maponpaths_2.
              apply tensor_id_id.
            }
            refine (!(tensor_split _ _) @ _).
            apply tensor_split'.
          }
          rewrite !assoc.
          refine (tensor_comp_r_id_l _ _ _ @ _).
          apply idpath.
        }
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          apply tensor_lassociator.
        }
        rewrite !assoc'.
        apply maponpaths.
        refine ((!tensor_comp_id_l _ _) @ _).
        apply maponpaths.
        exact (!(functor_enrichment_comp EM x (M y) (M(M z)))).
      }
      refine (!_).
      etrans.
      {
        do 4 apply maponpaths.
        rewrite !assoc.
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          apply tensor_linvunitor.
        }
        rewrite assoc'.
        apply maponpaths.
        refine (!(tensor_comp_mor _ _ _ _) @ _).
        rewrite id_left.
        apply maponpaths.
        exact (functor_enrichment_comp EM x (M(M z)) (M z)).
      }
      etrans.
      {
        do 4 apply maponpaths.
        rewrite !assoc'.
        apply maponpaths.
        etrans.
        {
          apply maponpaths_2.
          apply tensor_comp_l_id_r.
        }
        rewrite !assoc'.
        apply maponpaths.
        apply enrichment_assoc'.
      }
      rewrite !assoc.
      apply maponpaths_2.
      etrans.
      {
        rewrite !assoc'.
        do 5 apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          apply tensor_rassociator.
        }
        rewrite !assoc'.
        apply maponpaths.
        refine (!(tensor_comp_mor _ _ _ _) @ _).
        rewrite id_right.
        etrans.
        {
          apply tensor_comp_r_id_l.
        }
        apply maponpaths.
        apply tensor_split'.
      }
      refine (!_).
      etrans.
      {
        apply maponpaths.
        apply tensor_comp_id_l.
      }
      rewrite !assoc.
      apply maponpaths_2.
      refine (!_).
      etrans.
      {
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          do 5 apply maponpaths_2.
          apply tensor_linvunitor.
        }
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          do 4 apply maponpaths_2.
          refine (!(tensor_split _ _) @ _).
          apply tensor_split'.
        }
        rewrite !assoc'.
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          rewrite !assoc.
          do 2 apply maponpaths_2.
          etrans.
          {
            apply maponpaths_2.
            refine (!_).
            apply mon_linvunitor_triangle.
          }
          rewrite !assoc'.
          etrans.
          {
            apply maponpaths.
            apply mon_lassociator_rassociator.
          }
          apply id_right.
        }
        rewrite !assoc.
        etrans.
        {
          do 2 apply maponpaths_2.
          refine (!(tensor_split _ _) @ _).
          apply tensor_split'.
        }
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          refine (!(tensor_split _ _) @ _).
          apply tensor_split'.
        }
        rewrite !assoc'.
        apply maponpaths.
        refine (!(tensor_split _ _) @ _).
        apply tensor_split'.
      }
      rewrite !assoc.
      apply maponpaths_2.
      refine (!_).
      rewrite !assoc'.
      etrans.
      {
        do 2 apply maponpaths.
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            apply maponpaths.
            apply maponpaths_2.
            etrans.
            {
              do 2 apply maponpaths_2.
              apply tensor_comp_id_l.
            }
            rewrite !assoc'.
            apply tensor_comp_id_r.
          }
          rewrite !assoc.
          do 2 apply maponpaths_2.
          refine (!(tensor_comp_id_r _ _) @ _).
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths.
            refine (!_).
            apply mon_runitor_triangle.
          }
          rewrite !assoc.
          etrans.
          {
            apply maponpaths_2.
            apply mon_lassociator_rassociator.
          }
          apply id_left.
        }
        rewrite !assoc.
        do 2 apply maponpaths_2.
        etrans.
        {
          apply maponpaths.
          apply mon_triangle.
        }
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          apply mon_rassociator_lassociator.
        }
        apply id_left.
      }
      etrans.
      {
        apply maponpaths.
        rewrite !assoc.
        do 2 apply maponpaths_2.
        refine (!(tensor_split' _ _) @ _).
        apply tensor_split.
      }
      etrans.
      {
        rewrite !assoc.
        do 2 apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          refine (!(tensor_comp_id_l _ _) @ _).
          etrans.
          {
            apply maponpaths.
            apply mon_linvunitor_lunitor.
          }
          apply tensor_id_id.
        }
        apply id_left.
      }
      rewrite !assoc'.
      etrans.
      {
        apply maponpaths_2.
        apply tensor_comp_id_r.
      }
      refine (!_).
      etrans.
      {
        apply maponpaths.
        apply maponpaths_2.
        refine (!_).
        apply mon_linvunitor_triangle.
      }
      etrans.
      {
        rewrite !assoc.
        do 5 apply maponpaths_2.
        refine (!(tensor_comp_id_r _ _) @ _).
        etrans.
        {
          apply maponpaths_2.
          apply tensor_linvunitor.
        }
        apply tensor_comp_id_r.
      }
      rewrite !assoc'.
      apply maponpaths.
      refine (!_).
      etrans.
      {
        rewrite !assoc.
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths.
          rewrite !assoc'.
          apply tensor_comp_id_r.
        }
        rewrite !assoc.
        apply maponpaths_2.
        refine (!(tensor_comp_id_r _ _) @ _).
        apply maponpaths_2.
        refine (!(tensor_split' _ _) @ _).
        refine (tensor_split _ _ @ _).
        apply maponpaths_2.
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          apply tensor_split.
        }
        rewrite !assoc.
        apply maponpaths_2.
        refine (!_).
        apply tensor_linvunitor.
      }
      etrans.
      {
        do 4 apply maponpaths_2.
        rewrite !assoc'.
        apply tensor_comp_id_l.
      }
      etrans.
      {
        do 2 apply maponpaths_2.
        rewrite !assoc'.
        apply tensor_comp_id_r.
      }
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      assert (enriched_from_arr E (μ M z) #⊗ enriched_from_arr E (# M (μ M z))
              · enriched_comp E (M (M (M z))) (M (M z)) (M z)
              =
              enriched_from_arr E (μ M z) #⊗ enriched_from_arr E (μ M (M z))
              · enriched_comp E (M (M (M z))) (M (M z)) (M z))
        as p.
      {
        pose (p := maponpaths
                     (λ z, mon_lunitor _ · enriched_from_arr E z)
                     (@Monad_law3 _ M z)).
        cbn in p.
        rewrite !enriched_from_arr_comp in p.
        refine (_ @ p @ _).
        - rewrite !assoc.
          apply maponpaths_2.
          refine (!(id_left _) @ _).
          apply maponpaths_2.
          refine (!_).
          apply mon_lunitor_linvunitor.
        - rewrite !assoc.
          apply maponpaths_2.
          refine (_ @ id_left _).
          apply maponpaths_2.
          apply mon_lunitor_linvunitor.
      }
      etrans.
      {
        apply maponpaths_2.
        refine (!(tensor_comp_id_r _ _) @ _).
        apply maponpaths_2.
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          rewrite !assoc.
          etrans.
          {
            apply maponpaths_2.
            etrans.
            {
              apply maponpaths_2.
              apply maponpaths.
              refine (!_).
              apply tensor_id_id.
            }
            apply tensor_rassociator.
          }
          rewrite !assoc'.
          apply maponpaths.
          exact (!(tensor_comp_id_r _ _)).
        }
        etrans.
        {
          apply maponpaths_2.
          apply tensor_comp_id_l.
        }
        rewrite !assoc'.
        apply maponpaths.
        etrans.
        {
          rewrite !assoc.
          apply maponpaths_2.
          apply tensor_rassociator.
        }
        rewrite !assoc'.
        apply maponpaths.
        refine (!(tensor_comp_id_r _ _) @ _).
        apply maponpaths_2.
        etrans.
        {
          rewrite !assoc.
          apply maponpaths_2.
          exact (!(tensor_split _ _)).
        }
        exact (!p).
      }
      clear p.
      refine (!_).
      etrans.
      {
        rewrite !assoc'.
        etrans.
        {
          do 3 apply maponpaths.
          exact (!(tensor_comp_id_r _ _)).
        }
        etrans.
        {
          do 2 apply maponpaths.
          exact (!(tensor_comp_id_r _ _)).
        }
        etrans.
        {
          apply maponpaths.
          exact (!(tensor_comp_id_r _ _)).
        }
        etrans.
        {
          do 2 apply maponpaths.
          exact (!(tensor_id_id _ _)).
        }
        refine (!_).
        apply tensor_lassociator.
      }
      rewrite !assoc.
      do 2 apply maponpaths_2.
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          apply mon_inv_triangle.
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          apply mon_lassociator_rassociator.
        }
        apply id_right.
      }
      refine (!(tensor_comp_id_r _ _) @ _).
      apply maponpaths_2.
      rewrite !assoc.
      apply maponpaths_2.
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        apply tensor_linvunitor.
      }
      rewrite !assoc'.
      etrans.
      {
        apply maponpaths_2.
        apply mon_linvunitor_I_mon_rinvunitor_I.
      }
      apply maponpaths.
      refine (!(tensor_comp_mor _ _ _ _) @ _).
      rewrite id_left.
      apply maponpaths.
      refine (!_).
      apply (functor_enrichment_from_arr EM).
    - intros x y f ; cbn.
      use (dialgebra_enrichment_mor_eq_of_mor
             V HV
             EM (functor_id_enrichment E)).
      unfold bind.
      refine (dialgebra_enrichment_from_arr_incl _ _ _ _ _ _ @ _).
      rewrite !assoc'.
      refine (!_).
      etrans ;
        [ apply maponpaths ;
          apply functor_to_kleisli_cat_enrichment_data_incl
        | ].
      unfold functor_to_kleisli_cat_enrichment_mor.
      rewrite !assoc'.
      etrans.
      {
        apply maponpaths_2.
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          apply (@Monad_law2 _ M y).

        }
        apply id_right.
      }
      rewrite enriched_from_arr_comp.
      rewrite !assoc.
      apply maponpaths_2.
      etrans.
      {
        apply maponpaths_2.
        apply tensor_linvunitor.
      }
      rewrite !assoc'.
      apply maponpaths.
      refine (!(tensor_comp_mor _ _ _ _) @ _).
      rewrite id_left.
      apply maponpaths.
      rewrite (functor_enrichment_from_arr EM).
      apply idpath.
  Qed.

  Definition functor_to_kleisli_cat_enrichment
    : functor_enrichment
        (functor_to_kleisli_cat M)
        (Kleisli_cat_monad_enrichment EM)
        Kleisli_cat_enrichment.
  Proof.
    simple refine (_ ,, _).
    - exact functor_to_kleisli_cat_enrichment_data.
    - exact functor_to_kleisli_cat_enrichment_is_enrichment.
  Defined.

  (**
   5. The functor is fully faithful
   *)
  Section FullyFaithfulToKleisli.
    Context (x y : C).

    Definition functor_to_kleisli_cat_enrichment_inv
      : Kleisli_cat_enrichment ⦃ functor_to_kleisli_cat M x, functor_to_kleisli_cat M y ⦄
        -->
        Kleisli_cat_monad_enrichment EM ⦃ x, y ⦄
      := dialgebra_enrichment_mor_incl _ _ _ _ _ _
         · mon_rinvunitor _
         · (identity _ #⊗ enriched_from_arr E (η M x))
         · enriched_comp E x (M x) (M y).

    Local Lemma functor_to_kleisli_cat_enrichment_inv_right
      : functor_to_kleisli_cat_enrichment_data x y
        · functor_to_kleisli_cat_enrichment_inv
        =
        identity _.
    Proof.
      unfold functor_to_kleisli_cat_enrichment_inv.
      cbn.
      rewrite !assoc.
      etrans.
      {
        do 3 apply maponpaths_2.
        apply functor_to_kleisli_cat_enrichment_data_incl.
      }
      unfold functor_to_kleisli_cat_enrichment_mor.
      (*
       We show that for all

         f : x --> M y

       we have

         η M x · (#M f · μ M y)
         =
         f
       *)
      rewrite !assoc'.
      (*
       η M x · (#M f · μ M y)
       =
       (η M x · #M f) · μ M y
       *)
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          do 2 apply maponpaths_2.
          apply tensor_rinvunitor.
        }
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          refine (!(tensor_split' _ _) @ _).
          apply tensor_split.
        }
        rewrite !assoc'.
        apply maponpaths.
        apply enrichment_assoc.
      }
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !assoc.
        do 2 apply maponpaths_2.
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            do 2 apply maponpaths_2.
            exact (!(tensor_id_id _ _)).
          }
          apply tensor_lassociator.
        }
        rewrite !assoc.
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          refine (!_).
          apply mon_rinvunitor_triangle.
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          apply mon_rassociator_lassociator.
        }
        apply id_right.
      }
      rewrite !assoc'.
      etrans.
      {
        apply maponpaths.
        apply maponpaths_2.
        apply tensor_split'.
      }
      rewrite !assoc'.
      (*
       (η M x · #M f) · μ M y
       =
       (f · η M y) · μ M y
       *)
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !assoc.
        apply maponpaths_2.
        rewrite !assoc'.
        etrans.
        {
          do 2 apply maponpaths.
          exact (!(tensor_comp_id_l _ _)).
        }
        etrans.
        {
          apply maponpaths.
          exact (!(tensor_comp_id_l _ _)).
        }
        refine (!(tensor_comp_id_l _ _) @ _).
        apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          do 2 apply maponpaths_2.
          apply tensor_rinvunitor.
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          rewrite !assoc.
          apply maponpaths_2.
          exact (!(tensor_split' _ _)).
        }
        rewrite !assoc.
        exact (unit_of_monad_enrichment EM x (M y)).
      }
      cbn.
      (*
       (f · η M y) · μ M y
       =
       f · (η M y · μ M y)
       *)
      etrans.
      {
        do 2 apply maponpaths.
        etrans.
        {
          apply maponpaths_2.
          apply tensor_comp_id_l.
        }
        rewrite !assoc'.
        apply maponpaths.
        apply enrichment_assoc'.
      }
      (*
       f · (η M y · μ M y)
       =
       f · id
       *)
      etrans.
      {
        apply maponpaths.
        rewrite !assoc.
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          rewrite !assoc'.
          etrans.
          {
            apply maponpaths.
            etrans.
            {
              apply maponpaths_2.
              apply tensor_comp_id_l.
            }
            rewrite !assoc'.
            etrans.
            {
              apply maponpaths.
              apply tensor_rassociator.
            }
            rewrite !assoc.
            apply maponpaths_2.
            etrans.
            {
              apply maponpaths_2.
              apply mon_inv_triangle.
            }
            rewrite !assoc'.
            etrans.
            {
              apply maponpaths.
              apply mon_lassociator_rassociator.
            }
            apply id_right.
          }
          etrans.
          {
            apply maponpaths.
            exact (!(tensor_comp_id_r _ _)).
          }
          refine (!(tensor_comp_id_r _ _) @ _).
          apply maponpaths_2.
          rewrite !assoc.
          etrans.
          {
            apply maponpaths_2.
            apply tensor_rinvunitor.
          }
          rewrite mon_rinvunitor_I_mon_linvunitor_I.
          rewrite !assoc'.
          apply maponpaths.
          exact (!(tensor_split' _ _)).
        }
        refine (!(tensor_comp_id_r _ _) @ _).
        apply maponpaths_2.
        pose (p := maponpaths (enriched_from_arr E) (@Monad_law1 _ M y)).
        rewrite enriched_from_arr_id in p.
        rewrite enriched_from_arr_comp in p.
        cbn in p.
        exact p.
      }
      (*
       f · id = f
       *)
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply enrichment_id_left.
      }
      apply mon_linvunitor_lunitor.
    Qed.

    Local Lemma functor_to_kleisli_cat_enrichment_inv_left
      : functor_to_kleisli_cat_enrichment_inv
        · functor_to_kleisli_cat_enrichment_data x y
        =
        identity _.
    Proof.
      use (dialgebra_enrichment_mor_eq_of_mor
             V HV
             EM (functor_id_enrichment E)).
      rewrite id_left.
      etrans.
      {
        rewrite !assoc'.
        apply maponpaths.
        apply functor_to_kleisli_cat_enrichment_data_incl.
      }
      unfold functor_to_kleisli_cat_enrichment_mor.
      unfold functor_to_kleisli_cat_enrichment_inv.
      cbn.
      rewrite !assoc'.
      pose (dialgebra_enrichment_mor_incl_eq
              V HV
              EM (functor_id_enrichment E)
              (μ M x) (μ M y))
        as p.
      unfold dialgebra_enrichment_mor_right in p.
      cbn in p.
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          do 2 apply maponpaths.
          rewrite !assoc.
          do 2 apply maponpaths_2.
          apply tensor_linvunitor.
        }
        rewrite !assoc'.
        etrans.
        {
          do 3 apply maponpaths.
          rewrite !assoc.
          apply maponpaths_2.
          refine (!(tensor_comp_mor _ _ _ _) @ _).
          rewrite id_left.
          apply maponpaths.
          apply (functor_enrichment_comp EM).
        }
        etrans.
        {
          do 2 apply maponpaths.
          etrans.
          {
            apply maponpaths_2.
            refine (!_).
            apply mon_linvunitor_triangle.
          }
          rewrite !assoc'.
          apply maponpaths.
          rewrite !assoc.
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths.
            apply tensor_comp_l_id_r.
          }
          rewrite !assoc.
          apply maponpaths_2.
          refine (!_).
          apply tensor_lassociator.
        }
        rewrite !assoc'.
        etrans.
        {
          do 4 apply maponpaths.
          etrans.
          {
            apply maponpaths.
            apply enrichment_assoc'.
          }
          rewrite !assoc.
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths_2.
            apply mon_lassociator_rassociator.
          }
          apply id_left.
        }
        rewrite !assoc.
        apply maponpaths_2.
        rewrite !assoc'.
        etrans.
        {
          do 3 apply maponpaths.
          exact (!(tensor_comp_mor _ _ _ _)).
        }
        rewrite id_right.
        etrans.
        {
          do 2 apply maponpaths.
          exact (!(tensor_comp_mor _ _ _ _)).
        }
        rewrite id_left.
        etrans.
        {
          apply maponpaths.
          exact (!(tensor_comp_mor _ _ _ _)).
        }
        rewrite id_left.
        etrans.
        {
          apply maponpaths.
          apply tensor_split'.
        }
        rewrite !assoc.
        apply maponpaths_2.
        refine (!_).
        apply tensor_rinvunitor.
      }
      rewrite !assoc.
      etrans.
      {
        do 3 apply maponpaths_2.
        refine (_ @ !p).
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        apply maponpaths_2.
        refine (!_).
        etrans.
        {
          apply maponpaths_2.
          apply tensor_linvunitor.
        }
        rewrite !assoc'.
        apply maponpaths.
        refine (!_).
        apply tensor_split.
      }
      refine (_ @ id_right _).
      rewrite !assoc'.
      apply maponpaths.
      clear p.
      unfold dialgebra_enrichment_mor_left ; cbn.
      (*
       For all

         f : M x --> M y

       we have

         #M (η M x) · (μ M x · f)
         =
         f
       *)
      rewrite id_left.
      rewrite !assoc'.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          do 2 apply maponpaths_2.
          apply tensor_rinvunitor.
        }
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          refine (!(tensor_split' _ _) @ _).
          apply tensor_split.
        }
        rewrite !assoc'.
        apply maponpaths.
        apply enrichment_assoc.
      }
      pose (p := maponpaths (enriched_from_arr E) (@Monad_law2 _ M x)).
      rewrite enriched_from_arr_id in p.
      rewrite enriched_from_arr_comp in p.
      rewrite (functor_enrichment_from_arr EM) in p.
      cbn in p.
      etrans.
      {
        do 3 apply maponpaths.
        rewrite !assoc.
        do 2 apply maponpaths_2.
        etrans.
        {
          do 2 apply maponpaths_2.
          exact (!(tensor_id_id _ _)).
        }
        apply tensor_lassociator.
      }
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !assoc.
        do 3 apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          refine (!_).
          apply mon_rinvunitor_triangle.
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          apply mon_rassociator_lassociator.
        }
        apply id_right.
      }
      etrans.
      {
        apply maponpaths.
        rewrite !assoc.
        apply maponpaths_2.
        etrans.
        {
          do 2 apply maponpaths_2.
          exact (!(tensor_comp_id_l _ _)).
        }
        etrans.
        {
          apply maponpaths_2.
          exact (!(tensor_comp_id_l _ _)).
        }
        refine (!(tensor_comp_id_l _ _) @ _).
        apply maponpaths.
        etrans.
        {
          do 2 apply maponpaths_2.
          apply tensor_rinvunitor.
        }
        rewrite mon_rinvunitor_I_mon_linvunitor_I.
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          rewrite !assoc.
          apply maponpaths_2.
          exact (!(tensor_split' _ _)).
        }
        rewrite !assoc.
        exact p.
      }
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply enrichment_id_right.
      }
      apply mon_rinvunitor_runitor.
    Qed.
  End FullyFaithfulToKleisli.

  Definition fully_faithful_functor_to_kleisli_cat_enrichment
    : fully_faithful_enriched_functor functor_to_kleisli_cat_enrichment.
  Proof.
    intros x y.
    use make_is_z_isomorphism.
    - exact (functor_to_kleisli_cat_enrichment_inv x y).
    - split.
      + exact (functor_to_kleisli_cat_enrichment_inv_right x y).
      + exact (functor_to_kleisli_cat_enrichment_inv_left x y).
  Defined.
End EnrichedKleisli.


Require Import
  HoTT.Types.Universe
  HoTT.Basics.Decidable
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.interfaces.integers
  HoTT.Classes.interfaces.naturals
  HoTT.Classes.interfaces.rationals
  HoTT.Classes.interfaces.orders
  HoTT.Classes.implementations.natpair_integers
  HoTT.Classes.theory.rings
  HoTT.Classes.theory.integers
  HoTT.Classes.theory.dec_fields
  HoTT.Classes.orders.dec_fields
  HoTT.Classes.theory.rationals
  HoTT.Classes.orders.lattices
  HoTT.Classes.theory.additional_operations
  HoTT.Classes.theory.premetric
  HoTT.Classes.implementations.assume_rationals
  HoTTClasses.cauchy_completion.

Require Export
  HoTTClasses.cauchy_reals.base.

Local Set Universe Minimization ToSet.

Section real_initial.

Context `{Field F} `{!FullPseudoSemiRingOrder (A:=F) Fle Flt}.

Variable F_archimedean : forall x y : F, x < y ->
  merely (exists q, x < rationals_to_field Q F q < y).

Instance Fclose : Closeness F := fun e x y =>
  x - y < rationals_to_field Q F (' e) /\ y - x < rationals_to_field Q F (' e).

Instance rat_to_field_strict_order_embedding
  : StrictOrderEmbedding (rationals_to_field Q F).
Proof.
Admitted.

Lemma F_separated : Separated F.
Proof.
intros x y E.
apply (right_cancellation (+) (-y)). rewrite plus_negate_r.
apply tight_apart. intros E'. apply apart_iff_total_lt in E'.
destruct E' as [E'|E'];apply F_archimedean in E';revert E';apply (Trunc_ind _);
intros [q [E1 E2]].
- assert (Eq : 0 < - q).
  { rewrite <-(preserves_0 (f:=rationals_to_field Q F)) in E2.
    apply (strictly_order_reflecting _) in E2.
    apply flip_neg_negate. trivial.
  }
  pose proof (E (mkQpos _ Eq)) as [E3 E4];unfold cast in E3,E4;simpl in E3, E4.
  rewrite (preserves_negate (f:=rationals_to_field Q F)) in E4.
  apply flip_lt_negate in E4;rewrite involutive,<-negate_swap_r in E4.
  apply (irreflexivity lt (x - y)). transitivity (rationals_to_field Q F q);trivial.
- assert (Eq : 0 < q).
  { apply (strictly_order_reflecting _). rewrite preserves_0. trivial. }
  pose proof (E (mkQpos _ Eq)) as [E3 E4];unfold cast in E3,E4;simpl in E3, E4.
  apply (irreflexivity lt (x - y)). transitivity (rationals_to_field Q F q);trivial.
Qed.

Instance F_premetric : PreMetric F.
Proof.
split.
- apply _.
- intros e x. hnf. rewrite plus_negate_r.
  split;rewrite <-(preserves_0 (f:=rationals_to_field Q F));
  apply (strictly_order_preserving _);solve_propholds.
- intros e x y E. hnf. apply prod_symm,E.
- apply F_separated.
- intros x y z e d E1 E2.
  hnf. rewrite (preserves_plus (f:=_:Q -> F)).
  split.
  + assert (Hrw : x - z = (x - y) + (y - z))
      by ring_tac.ring_with_integers (NatPair.Z nat);
    rewrite Hrw;clear Hrw. apply plus_lt_compat.
    * apply E1.
    * apply E2.
  + assert (Hrw : z - x = (y - x) + (z - y))
      by ring_tac.ring_with_integers (NatPair.Z nat);
    rewrite Hrw;clear Hrw. apply plus_lt_compat.
    * apply E1.
    * apply E2.
- hnf. intros e x y. split.
  + intros [E1 E2].
    apply F_archimedean in E1;apply F_archimedean in E2.
    revert E1;apply (Trunc_ind _);intros [q1 [E1 E1']];
    revert E2;apply (Trunc_ind _);intros [q2 [E2 E2']].
    apply (strictly_order_reflecting _) in E1';
    apply (strictly_order_reflecting _) in E2'.
    assert (E3 : exists d d', q1 < ' d /\ q2 < ' d /\ e = d + d').
    { apply pos_gt_both;trivial. }
    destruct E3 as [d [d' [E3 [E4 E5]]]].
    apply tr;exists d,d';split;trivial.
    hnf. split;etransitivity;eauto;apply (strictly_order_preserving _);trivial.
  + apply (Trunc_ind _);intros [d [d' [E1 [E2 E3]]]].
    assert (rationals_to_field Q F (' d) < rationals_to_field Q F (' e))
      by (apply (strictly_order_preserving _); rewrite E1;
          apply pos_plus_lt_compat_r; solve_propholds).
    split;etransitivity;eauto.
Qed.

Context `{!Lim F} `{!CauchyComplete F}.

Definition real_embed : real -> F.
Proof.
simple refine (lipschitz_extend Q (rationals_to_field Q F) 1);try apply _.
apply nonexpanding_lipschitz.
hnf. intros e q r [E1 E2].
hnf. rewrite <-!preserves_negate,<-!preserves_plus.
apply flip_lt_negate in E1. rewrite involutive,<-negate_swap_r in E1.
split;apply (strictly_order_preserving _);trivial.
Defined.

Definition real_embed_rat q : real_embed (rat q) = rationals_to_field Q F q
  := idpath.

(* To show that real_embed preserves plus/mult
   we need to know that they're continuous on F. *)

End real_initial.


From Coq Require Import
     String
.

From ExtensibleCompiler.Syntax.Terms Require Import
     Closure
     Lambda
     Stuck
.

From ExtensibleCompiler.Theory Require Import
     Algebra
     Environment
     Eval
     Functor
     ProgramAlgebra
     SubFunctor
     UniversalProperty
.

Local Open Scope SubFunctor.

Section Lambda.

  Context

    {T}
    `{Functor T}

    {E}
    `{! forall B, Functor (E B)}
    `{(E nat) supports (Closure E)}
    `{(E nat) supports Stuck}

  .

  Definition eval__Lambda
    : MixinAlgebra (Lambda T nat) (ValueFix (E nat)) (EvalResult (E nat))
    := fun rec e env =>
         match e with
         | App f a =>
           let f' := rec f env in
           match isClosure (proj1_sig f') with
           | Some (f, env') => rec f (insert (rec a env) env')
           | None           => stuck "Non-function in call position"
           end
         | Lam v b => stuck "TODO"
         | Var v   =>
           match lookup env v with
           | Some w => w
           | None   => stuck "Variable lookup failed"
           end
         end.

  Global Instance Eval__Lambda
    : ProgramAlgebra ForEval (Lambda T nat) (ValueFix (E nat)) (EvalResult (E nat))
    := {| programAlgebra := eval__Lambda |}.

End Lambda.


Set Implicit Arguments.
Unset Strict Implicit.

(** permission map class **)
Class PermMap (A B T:Type) :=
  {
    usePerm : bool;
    (** indicate whether to use Permission **)

    isRw : B -> bool;
    (** true: have write permission; false: have read permission **)
    flip : B -> B;
    (** flip permission: turn RO to RW, or RW to RO.
        Or Return None if all permission are RW **)
    sameV : B -> B -> Prop;
    (** [sameV v1 v2] means v1 v2 are same except for their permissions **)
    same : B -> B -> bool;
    (** [same v1 v2 = true ] means v1 = v2 **)
    emp: T;
    get : T -> A -> option B;
    set : T -> A -> B -> T;
    del : T -> A -> T;
    sig : A -> B -> T;
    join : T -> T -> T -> Prop;
    merge: T -> T -> T;
    minus: T -> T -> T;
    (** I only deal with emp, get, set, sig, join, merge at present  **)

    map_dec_a:
      forall (t1 t2: A), {t1 = t2} + {t1 <> t2};

    map_same:
      forall (v1 v2: B),
        usePerm = true ->
        same v1 v2 = true ->
        v1 = v2;

    map_same':
      forall (v1 v2: B),
        usePerm = true ->
        same v1 v2 = false ->
        v1 <> v2;

    (** * join **)
    map_join_emp:
      forall x, join x emp x;

    map_join_pos:
      forall x y,
        join x y emp ->
        x = emp /\ y = emp;

    map_join_comm:
      forall x y z,
        join x y z ->
        join y x z;

    map_join_assoc:
      forall a b mab c mabc,
        join a b mab ->
        join mab c mabc ->
        exists mbc,
          join a mbc mabc /\
          join b c mbc;

    map_join_cancel:
      forall a b b' c,
        join a b c ->
        join a b' c ->
        b = b';

    map_join_deter:
      forall a b c c',
        join a b c ->
        join a b c' ->
        c = c';

    (** * saveV and flip: Permission specific **)
    map_sv_ref:
      forall v, usePerm = true -> sameV v v;

    map_sv_comm:
      forall v v',
        usePerm = true ->
        sameV v v' ->
        sameV v' v;

    map_sv_assoc:
      forall v1 v2 v3,
        usePerm = true ->
        sameV v1 v2 ->
        sameV v2 v3 ->
        sameV v1 v3;

    map_perm_eql:
      forall v1 v2,
        usePerm = true ->
        sameV v1 v2 ->
        isRw v1 = isRw v2 ->
        v1 = v2;

    map_flip_isRw:
      forall v,
        usePerm = true ->
        isRw (flip v) = negb (isRw v);

    map_flip_sv:
      forall v,
        usePerm = true ->
        sameV v (flip v);

    (** * get **)
    (** ** general **)
    map_emp_get:
      forall t, get emp t = None;

    map_eql:
      forall x y,
        (forall t, get x t = get y t) ->
        x = y;

    map_disjoint:
      forall x y,
        (forall t, get x t = None \/
              get y t = None \/
              (exists v,
                  usePerm = true /\
                  get x t = Some v /\
                  get y t = Some v /\
                  isRw v = false)) ->
        exists z, join x y z;

    map_get_unique:
      forall x t v v',
        get x t = Some v ->
        get x t = Some v' ->
        v = v';
    (** above two axiom describe T to be a set of (A, B) **)

    map_get_sig:
      forall t v,
        get (sig t v) t = Some v;

    map_get_sig':
      forall t t' v,
        t <> t' ->
        get (sig t v) t' = None;

    map_get_set:
      forall x t v,
        get (set x t v) t = Some v;

    map_get_set':
      forall x t t' v,
        t <> t' ->
        get (set x t v) t' = get x t';

    map_join_get_none:
      forall x y z t,
        join x y z ->
        get x t = None ->
        get z t = get y t;

    (** ** no permission **)
    map_join_get_some:
      forall x y z t v1 v2,
        usePerm = false ->
        join x y z ->
        get x t = Some v1 ->
        get y t = Some v2 ->
        False;

    (** ** use permission **)
    map_join_getp_some:
      forall x y z t v1 v2 v',
        usePerm = true ->
        join x y z ->
        get x t = Some v1 ->
        get y t = Some v2 ->
        v' = flip v1 ->
        v1 = v2 /\ isRw v1 = false /\ get z t = Some v';

    (** * set **)
    (** ** general **)
    map_set_emp:
      forall t v,
        set emp t v = sig t v;

    map_set_sig:
      forall t v v',
        set (sig t v) t v' = sig t v';

    map_join_set_none:
      forall x y z t v',
        join x y z ->
        get y t = None ->
        join (set x t v') y (set z t v');

    (** ** use permission **)
    map_join_set_perm:
      forall x y z t v v',
        usePerm = true ->
        join x y z ->
        get x t = None ->
        get y t = Some v ->
        isRw v = false ->
        v' = flip v ->
        join (set x t v) y (set z t v');

    (** * sig **)
    (** ** general **)
    map_join_get_sig:
      forall x t v,
        get x t = Some v ->
        exists x', join (sig t v) x' x;

    (** ** use permission **)
    map_join_get_sig_perm:
      forall x t v v',
        usePerm = true ->
        get x t = Some v ->
        isRw v = true ->
        v' = flip v ->
        exists x1 x2, join (sig t v') x1 x /\ join (sig t v') x2 x1;

    (** * merge **)
    map_merge_sem:
      (** def1 **)
      forall m1 m2 a,
        usePerm = false ->
        get (merge m1 m2) a
        = match (get m1 a, get m2 a) with
            | (Some b1, Some b2) => Some b1
            | (Some b1, None) => Some b1
            | (None, Some b2) => Some b2
            | (None, None) => None
          end;

    map_merge_semp:
      (** def2 **)
      forall m1 m2 a,
        usePerm = true ->
        get (merge m1 m2) a
        = match (get m1 a, get m2 a) with
            | (Some b1, Some b2) =>
              match (same b1 b2) return (option B) with
                | true => match (isRw b1) with
                             | true => Some b1
                             | false => Some (flip b1)
                           end
                | false => Some b1
              end
            | (None, Some b2) => Some b2
            | (Some b1, None) => Some b1
            | (None, None) => None
          end;

    map_join_merge:
      (** the scope of exists is very large, using parenthesis **)
      forall x y,
        (exists z, join x y z) ->
        join x y (merge x y);

    map_merge_comm:
      forall x y,
        (exists z, join x y z) ->
        merge x y = merge y x;

    (** * disjoint **)
    map_disjoint_semp:
      forall m1 m2,
        usePerm = true ->
        (forall t,
            match (get m1 t, get m2 t) with
              | (Some b0, Some b1) => b0 = b1 /\ isRw b0 = false
              | (Some b0, None) => True
              | (None, Some b1) => True
              | (None, None) => True
            end) ->
        (exists m, join m1 m2 m);

    map_disjoint_semp':
      forall m1 m2,
        usePerm = true ->
        (exists m, join m1 m2 m) ->
        (forall t,
            match (get m1 t, get m2 t) with
              | (Some b0, Some b1) => b0 = b1 /\ isRw b0 = false
              | (Some b0, None) => True
              | (None, Some b1) => True
              | (None, None) => True
            end);

    (** * minus **)
    map_minus_sem:
      (** def1 **)
      forall m m1 a,
        usePerm = false ->
        get (minus m m1) a
        = match (get m a, get m1 a) with
            | (Some b, Some b1) => None
            | (Some b1, None) => Some b1
            | (None, Some b2) => None
            | (None, None) => None
          end;

    map_minus_semp:
      (** def2 **)
      forall m1 m a,
        usePerm = true ->
        get (minus m m1) a
        = match (get m a, get m1 a) with
            | (Some b, Some b1) =>
              match (same b (flip b1)) return (option B) with
                | true => match (isRw b) with
                             | true => Some b1
                             | false => None
                           end
                | false => None
              end
            | (Some b, None) => Some b
            | (None, Some b1) => None
            | (None, None) => None
          end;

    map_join_minus:
      forall z x,
        (exists y, join x y z) ->
        join x (minus z x) z;

    (** * del **)
    map_del_sem:
      forall m a t,
        get (del m a) t
        = match (map_dec_a a t) with
            | left _ => None
            | right _ => get m t
          end
    }.

Definition indom {A B T:Type} {MC: PermMap A B T} (x: T) (t: A) :=
  exists v, get x t = Some v.

Definition sub {A B T:Type} {MC: PermMap A B T} (x y:T) :=
  (** x is subset of y **)
  exists x', join x x' y.

Definition disjoint {A B T:Type} {MC:PermMap A B T} x y :=
  exists z, join x y z.

Definition joinsig {A B T:Type} {MC:PermMap A B T} x y m M :=
  join (sig x y) m M.

Definition eqdom {A B T:Type} {MC:PermMap A B T} M1 M2 :=
  forall x, indom M1 x <-> indom M2 x.

(** inform simpl not to unfold these keywords **)
Arguments usePerm : simpl never.
Arguments isRw : simpl never.
Arguments flip : simpl never.
Arguments sameV : simpl never.

Arguments sig : simpl never.
Arguments set : simpl never.
Arguments get : simpl never.
Arguments join : simpl never.
Arguments emp : simpl never.
Arguments merge : simpl never.
Arguments minus : simpl never.
Arguments del : simpl never.