(** * Some general constructions *)
(** ** Contensts
- Pair of morphisms
- Short exact sequence data
*)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.Notations.
Require Import UniMath.CategoryTheory.Core.Functors.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Local Open Scope cat.
Require Import UniMath.CategoryTheory.opp_precat.

Require Import UniMath.CategoryTheory.limits.zero.
Require Import UniMath.CategoryTheory.limits.Opp.

(** * Pair of morphisms *)
Section def_morphismpair.

  Context {C : precategory}.

  (** ** Morphism **)

  Definition Morphism : UU := ∑ (a b : C), a --> b.

  Definition make_Morphism {a b : C} (f : a --> b) : Morphism := (a,,(b,,f)).

  Definition Source (M : Morphism) : ob C := pr1 M.

  Definition Target (M : Morphism) : ob C := pr1 (pr2 M).

  Definition MorphismMor (M : Morphism) : C⟦Source M, Target M⟧ := pr2 (pr2 M).
  Coercion MorphismMor : Morphism >-> precategory_morphisms.

  (** ** MorphismPair **)

  Definition MorphismPair : UU := ∑ (a b c : C), (a --> b × b --> c).

  Definition make_MorphismPair {a b c : C} (f : a --> b) (g : b --> c) : MorphismPair.
  Proof.
    use tpair.
    - exact a.
    - use tpair.
      + exact b.
      + use tpair.
        * exact c.
        * use make_dirprod.
          -- exact f.
          -- exact g.
  Defined.

  (** Accessor function *)
  Definition Ob1 (MP : MorphismPair) : ob C := pr1 MP.

  Definition Ob2 (MP : MorphismPair) : ob C := pr1 (pr2 MP).

  Definition Ob3 (MP : MorphismPair) : ob C := pr1 (pr2 (pr2 MP)).

  Definition Mor1 (MP : MorphismPair) : C⟦Ob1 MP, Ob2 MP⟧ := dirprod_pr1 (pr2 (pr2 (pr2 MP))).

  Definition Mor2 (MP : MorphismPair) : C⟦Ob2 MP, Ob3 MP⟧ := dirprod_pr2 (pr2 (pr2 (pr2 MP))).

  (** Morphism of morphism pairs *)
  Definition MPMorMors (MP1 MP2 : MorphismPair) : UU :=
    (Ob1 MP1 --> Ob1 MP2) × (Ob2 MP1 --> Ob2 MP2) × (Ob3 MP1 --> Ob3 MP2).

  Definition make_MPMorMors {MP1 MP2 : MorphismPair} (f1 : Ob1 MP1 --> Ob1 MP2)
             (f2 : Ob2 MP1 --> Ob2 MP2) (f3 : Ob3 MP1 --> Ob3 MP2) : MPMorMors MP1 MP2 :=
    (f1,,(f2,,f3)).

  Definition MPMor1 {MP1 MP2 : MorphismPair} (MPM : MPMorMors MP1 MP2) : Ob1 MP1 --> Ob1 MP2 :=
    dirprod_pr1 MPM.

  Definition MPMor2 {MP1 MP2 : MorphismPair} (MPM : MPMorMors MP1 MP2) : Ob2 MP1 --> Ob2 MP2 :=
    dirprod_pr1 (dirprod_pr2 MPM).

  Definition MPMor3 {MP1 MP2 : MorphismPair} (MPM : MPMorMors MP1 MP2) : Ob3 MP1 --> Ob3 MP2 :=
    dirprod_pr2 (dirprod_pr2 MPM).

  Definition MPMorComms {MP1 MP2 : MorphismPair} (MPM : MPMorMors MP1 MP2) : UU :=
    (MPMor1 MPM · Mor1 MP2 = Mor1 MP1 · MPMor2 MPM)
      × (MPMor2 MPM · Mor2 MP2 = Mor2 MP1 · MPMor3 MPM).

  Definition make_MPMorComms {MP1 MP2 : MorphismPair} (MPM : MPMorMors MP1 MP2)
             (H1 : MPMor1 MPM · Mor1 MP2 = Mor1 MP1 · MPMor2 MPM)
             (H2 : MPMor2 MPM · Mor2 MP2 = Mor2 MP1 · MPMor3 MPM) : MPMorComms MPM := (H1,,H2).

  Definition MPComm1 {MP1 MP2 : MorphismPair} {MPM : MPMorMors MP1 MP2} (MPMC : MPMorComms MPM) :
    MPMor1 MPM · Mor1 MP2 = Mor1 MP1 · MPMor2 MPM := dirprod_pr1 MPMC.

  Definition MPComm2 {MP1 MP2 : MorphismPair} {MPM : MPMorMors MP1 MP2} (MPMC : MPMorComms MPM) :
    MPMor2 MPM · Mor2 MP2 = Mor2 MP1 · MPMor3 MPM := dirprod_pr2 MPMC.

  Definition MPMor (MP1 MP2 : MorphismPair) : UU := ∑ MPM : MPMorMors MP1 MP2, MPMorComms MPM.

  Definition make_MPMor {MP1 MP2 : MorphismPair} (MPM : MPMorMors MP1 MP2) (MPMC : MPMorComms MPM) :
    MPMor MP1 MP2 := (MPM,,MPMC).

  Definition MPMor_MPMorMors {MP1 MP2 : MorphismPair} (MPM : MPMor MP1 MP2) :
    MPMorMors MP1 MP2 := pr1 MPM.
  Coercion MPMor_MPMorMors : MPMor >-> MPMorMors.

  Definition MPMor_MPMorComms {MP1 MP2 : MorphismPair} (MPM : MPMor MP1 MP2) :
    MPMorComms MPM := pr2 MPM.
  Coercion MPMor_MPMorComms : MPMor >-> MPMorComms.

  Lemma reverseCommIsoSquare {M : precategory} {P Q P' Q':M} (f:P'-->P) (g:Q'-->Q) (i:z_iso P' Q') (j:z_iso P Q) :
    i · g = f · j -> z_iso_inv i · f = g · z_iso_inv j.
  Proof.
    intros l.
    refine (! id_right _ @ _).
    refine (maponpaths _ (! is_inverse_in_precat1 (z_iso_is_inverse_in_precat j)) @ _).
    refine (! assoc (z_iso_inv i) _ _ @ _).
    refine (maponpaths _ (assoc f _ _) @ _).
    refine (maponpaths (precomp_with (z_iso_inv i)) (maponpaths (postcomp_with (inv_from_z_iso j)) (!l)) @ _);
      unfold precomp_with, postcomp_with.
    refine (maponpaths _ (! assoc _ _ _) @ _).
    refine (assoc _ _ _ @ _).
    refine (maponpaths (postcomp_with (g · inv_from_z_iso j)) (is_inverse_in_precat2 (z_iso_is_inverse_in_precat i)) @ _);
      unfold postcomp_with.
    exact (id_left _).
  Qed.
  Lemma reverseCommIsoSquare' {M : precategory} {P Q P' Q':M} (f:P'-->P) (g:Q'-->Q) (i:z_iso P' Q') (j:z_iso P Q) :
    f · j = i · g -> g · z_iso_inv j = z_iso_inv i · f.
  Proof.
    intros l. refine (! _). apply reverseCommIsoSquare. refine (! _). exact l.
  Qed.
  Definition MorphismPairMap (P Q : MorphismPair) :=
    ∑ (f : Ob1 P --> Ob1 Q) (g : Ob2 P --> Ob2 Q) (h : Ob3 P --> Ob3 Q),
    f · Mor1 Q = Mor1 P · g  ×  g · Mor2 Q = Mor2 P · h.
  Definition Map1 {P Q : MorphismPair} (f : MorphismPairMap P Q) : Ob1 P --> Ob1 Q := pr1 f.
  Definition Map2 {P Q : MorphismPair} (f : MorphismPairMap P Q) : Ob2 P --> Ob2 Q := pr1 (pr2 f).
  Definition Map3 {P Q : MorphismPair} (f : MorphismPairMap P Q) : Ob3 P --> Ob3 Q := pr1 (pr2 (pr2 f)).
  Definition MorphismPairIsomorphism (P Q : MorphismPair) :=
    ∑ (f : z_iso (Ob1 P) (Ob1 Q)) (g : z_iso (Ob2 P) (Ob2 Q)) (h : z_iso (Ob3 P) (Ob3 Q)),
    ( f · Mor1 Q = Mor1 P · g
      ×
      Mor1 P · g = f · Mor1 Q )
    ×
    ( g · Mor2 Q = Mor2 P · h
      ×
      Mor2 P · h = g · Mor2 Q ).
  Definition InverseMorphismPairIsomorphism {P Q : MorphismPair} :
    MorphismPairIsomorphism P Q -> MorphismPairIsomorphism Q P.
  Proof.
    intros f.
    exists (z_iso_inv (pr1 f)). exists (z_iso_inv (pr12 f)). exists (z_iso_inv (pr122 f)).
    split.
    - split.
      + apply reverseCommIsoSquare. exact (pr11 (pr222 f)).
      + apply reverseCommIsoSquare'. exact (pr21 (pr222 f)).
    - split.
      + apply reverseCommIsoSquare. exact (pr12 (pr222 f)).
      + apply reverseCommIsoSquare'. exact (pr22 (pr222 f)).
  Defined.
  Definition make_MorphismPairIsomorphism
             (P Q : MorphismPair)
             (f : z_iso (Ob1 P) (Ob1 Q))
             (g : z_iso (Ob2 P) (Ob2 Q))
             (h : z_iso (Ob3 P) (Ob3 Q)) :
    f · Mor1 Q = Mor1 P · g ->
    g · Mor2 Q = Mor2 P · h -> MorphismPairIsomorphism P Q
    := λ r s, (f,,g,,h,,(r,,!r),,(s,,!s)).
End def_morphismpair.
Arguments MorphismPair : clear implicits.

(** * MorphismPair and opposite categories *)
Section MorphismPair_opp.

  Definition MorphismPair_opp {C : precategory} (MP : @MorphismPair C) :
    @MorphismPair (opp_precat C).
  Proof.
    use make_MorphismPair.
    - exact (Ob3 MP).
    - exact (Ob2 MP).
    - exact (Ob1 MP).
    - exact (Mor2 MP).
    - exact (Mor1 MP).
  Defined.

  Definition opp_MorphismPair {C : precategory} (MP : @MorphismPair (opp_precat C)) :
    @MorphismPair C.
  Proof.
    exact (MorphismPair_opp MP).
  Defined.

  Definition applyFunctorToPair {M N:precategory} :
    (M⟶N) -> @MorphismPair M -> @MorphismPair N
    := λ F P, make_MorphismPair (# F (Mor1 P)) (# F (Mor2 P)).
  Definition applyFunctorToPairIsomorphism {M N:precategory}
             (F : M⟶N) (P Q : @MorphismPair M) :
    MorphismPairIsomorphism P Q ->
    MorphismPairIsomorphism (applyFunctorToPair F P) (applyFunctorToPair F Q).
  Proof.
    intros [i1 [i2 [i3 [[d d'][e e']]]]].
    exists (functor_on_z_iso F i1).
    exists (functor_on_z_iso F i2).
    exists (functor_on_z_iso F i3).
    repeat split.
    - refine (! _ @ (maponpaths (# F) d ) @ _);apply functor_comp.
    - refine (! _ @ (maponpaths (# F) d') @ _);apply functor_comp.
    - refine (! _ @ (maponpaths (# F) e ) @ _);apply functor_comp.
    - refine (! _ @ (maponpaths (# F) e') @ _);apply functor_comp.
  Defined.
  Definition opp_MorphismPairIsomorphism {M:precategory} {P Q: @MorphismPair M} :
    MorphismPairIsomorphism P Q -> MorphismPairIsomorphism (MorphismPair_opp Q) (MorphismPair_opp P)
    := λ f, opp_z_iso (pr122 f),,
            opp_z_iso (pr12 f),,
            opp_z_iso (pr1 f),,
            (pr22 (pr222 f),,pr12 (pr222 f)),,
            (pr21 (pr222 f),,pr11 (pr222 f)).

End MorphismPair_opp.

(** * ShortShortExactData *)
Section def_shortshortexactdata.

  Variable C : category.
  Let hs : has_homsets C := homset_property C.
  Variable Z : Zero C.

  (** ** Data for [ShortShortExact]
    A pair of morphism such that composition of the morphisms is the zero
    morphism. *)

  Definition ShortShortExactData : UU :=
    ∑ MP : MorphismPair C, Mor1 MP · Mor2 MP = ZeroArrow Z _ _.

  Definition make_ShortShortExactData (MP : MorphismPair C)
             (H : Mor1 MP · Mor2 MP = ZeroArrow Z _ _) : ShortShortExactData := tpair _ MP H.

  (** Accessor functions *)
  Definition ShortShortExactData_MorphismPair (SSED : ShortShortExactData) :
    MorphismPair C := pr1 SSED.
  Coercion ShortShortExactData_MorphismPair : ShortShortExactData >-> MorphismPair.

  Definition ShortShortExactData_Eq (SSED : ShortShortExactData) :
    (Mor1 SSED) · (Mor2 SSED) = ZeroArrow Z _ _ := pr2 SSED.

End def_shortshortexactdata.
Arguments make_ShortShortExactData [C] _ _ _.
Arguments ShortShortExactData_Eq [C] _ _.

(** * ShortShortExactData and opposite categories *)
Section shortshortexactdata_opp.

  Lemma opp_ShortShortExactData_Eq {C : category} {Z : Zero C}
             (SSED : ShortShortExactData (op_category C) (Zero_opp C Z)) :
    Mor1 (opp_MorphismPair SSED) · Mor2 (opp_MorphismPair SSED) =
    ZeroArrow Z (Ob1 (opp_MorphismPair SSED)) (Ob3 (opp_MorphismPair SSED)).
  Proof.
    use (pathscomp0 (@ShortShortExactData_Eq (op_category C) (Zero_opp C Z) SSED)).
    rewrite <- ZeroArrow_opp. apply idpath.
  Qed.

  Definition opp_ShortShortExactData {C : category} {Z : Zero C}
             (SSED : ShortShortExactData (op_category C) (Zero_opp C Z)) : ShortShortExactData C Z.
  Proof.
    use make_ShortShortExactData.
    - exact (opp_MorphismPair SSED).
    - exact (opp_ShortShortExactData_Eq SSED).
  Defined.

  Lemma ShortShortExactData_opp_Eq {C : category} {Z : Zero C}
        (SSED : ShortShortExactData C Z) :
    Mor1 (MorphismPair_opp SSED) · Mor2 (MorphismPair_opp SSED) =
    ZeroArrow (Zero_opp C Z) (Ob1 (MorphismPair_opp SSED)) (Ob3 (MorphismPair_opp SSED)).
  Proof.
    use (pathscomp0 (@ShortShortExactData_Eq C Z SSED)).
    rewrite <- ZeroArrow_opp. apply idpath.
  Qed.

  Definition ShortShortExactData_opp {C : category} {Z : Zero C}
             (SSED : ShortShortExactData C Z) : ShortShortExactData (op_category C) (Zero_opp C Z).
  Proof.
    use make_ShortShortExactData.
    - exact (MorphismPair_opp SSED).
    - exact (ShortShortExactData_opp_Eq SSED).
  Defined.

End shortshortexactdata_opp.


Require Import Bedrock.Platform.Facade.Facade.
Require Import Bedrock.Memory.
Require Import Coq.Sets.Ensembles.

Require Bedrock.Bedrock.

Inductive ADTValue :=
  | List : list W -> ADTValue
  | Junk : False -> ADTValue
  | FEnsemble : Ensemble W -> ADTValue.

Require Import Bedrock.Platform.Cito.ADT.

Module Adt <: ADT.

  Definition ADTValue := ADTValue.

End Adt.

Require Import Coq.Lists.List Coq.Program.Program.

Definition SCAZero {t} := SCA t (Word.natToWord 32 0).
Definition SCAOne  {t} := SCA t (Word.natToWord 32 1).

Ltac crush_types :=
  unfold type_conforming, same_types, same_type; intros;
  repeat match goal with
           | [ H: exists t, _ |- _ ] => destruct H
         end; subst;
  intuition.

Section ListADTSpec.

  Definition List_new : AxiomaticSpec ADTValue.
    refine {|
        PreCond := fun args => args = [];
        PostCond := fun args ret => args = [] /\ ret = ADT (List [])
      |}; crush_types.
  Defined.

  Definition List_delete : AxiomaticSpec ADTValue.
    refine {|
        PreCond := fun args => exists l, args = [ADT (List l)];
        PostCond := fun args ret => exists l, args = [(ADT (List l), None)] /\ ret = SCAZero
      |}; crush_types.
  Defined.

  Definition List_pop : AxiomaticSpec ADTValue.
    refine {|
        PreCond := fun args =>
                     exists h t,
                       args = [ADT (List (h :: t))];
        PostCond := fun args ret =>
                      exists h t,
                        args = [ (ADT (List (h :: t)), Some (List t)) ] /\
                        ret = SCA ADTValue h
      |}; crush_types.
  Defined.

  Definition List_empty : AxiomaticSpec ADTValue.
    refine {|
        PreCond := fun args =>
                     exists l,
                       args = [ADT (List l)];
        PostCond := fun args ret =>
                      exists l,
                        args = [(ADT (List l), Some (List l))] /\
                        exists w, ret = SCA _ w /\ Bedrock.Programming.propToWord (l = nil) w
      |}; crush_types.
  Defined.

  Definition List_push : AxiomaticSpec ADTValue.
    refine {|
        PreCond := fun args =>
                     exists l w,
                       args = [ADT (List l); SCA _ w];
        PostCond := fun args ret =>
                      exists l w,
                        args = [ (ADT (List l), Some (List (w :: l))); (SCA _ w, None) ] /\
                        ret = SCAZero
      |}; crush_types.
  Defined.

  Definition List_copy : AxiomaticSpec ADTValue.
    refine {|
        PreCond := fun args =>
                     exists l,
                       args = [ADT (List l)];
        PostCond := fun args ret =>
                      exists l,
                        args = [ (ADT (List l), Some (List l)) ] /\
                        ret = ADT (List l)
      |}; crush_types.
  Defined.

  Definition List_rev : AxiomaticSpec ADTValue.
    refine {|
        PreCond := fun args =>
                     exists l,
                       args = [ADT (List l)];
        PostCond := fun args ret =>
                      exists l,
                        args = [ (ADT (List l), Some (List (rev l))) ] /\
                        ret = SCAZero
      |}; crush_types.
  Defined.

  Definition List_length : AxiomaticSpec ADTValue.
    refine {|
        PreCond := fun args =>
                     exists l,
                       args = [ADT (List l)];
        PostCond := fun args ret =>
                      exists l,
                        args = [ (ADT (List l), Some (List l)) ] /\
                        ret = SCA _ (Word.natToWord _ (length l))
      |}; crush_types.
  Defined.

End ListADTSpec.

Section FiniteSetADTSpec.

  (* Def Constructor sEmpty (_ : unit) : rep := ret (Empty_set _), *)
  Definition FEnsemble_sEmpty : AxiomaticSpec ADTValue.
    refine {|
        PreCond := fun args =>
                     args = [];
        PostCond := fun args ret =>
                      args = []
                      /\ ret = ADT (FEnsemble (Empty_set _))
      |}; crush_types.
  Defined.

  Definition FEnsemble_sDelete : AxiomaticSpec ADTValue.
    refine {|
        PreCond := fun args =>
                     exists s, args = [ADT (FEnsemble s)];
        PostCond := fun args ret =>
                      exists s, args = [(ADT (FEnsemble s), None)]
                      /\ ret = SCAZero
      |}; crush_types.
  Defined.

  (* Def Method sAdd (s : rep , w : W) : unit :=
      ret (Add _ s w, tt) *)
  Definition FEnsemble_sAdd : AxiomaticSpec ADTValue.
    refine {|
        PreCond := fun args =>
                     exists s w, args = [ADT (FEnsemble s); SCA _ w];
        PostCond := fun args ret =>
                      exists s w, args = [(ADT (FEnsemble s), Some (FEnsemble (Ensembles.Add _ s w)));
                                           (SCA _ w, None)]
                                  /\ ret = SCAZero
      |}; crush_types.
  Defined.

  (* Def Method sRemove (s : rep , w : W) : unit :=
      ret (Subtract _ s w, tt) *)
  Definition FEnsemble_sRemove : AxiomaticSpec ADTValue.
    refine {|
        PreCond := fun args =>
                     exists s w, args = [ADT (FEnsemble s); SCA _ w];
        PostCond := fun args ret =>
                      exists s w, args = [(ADT (FEnsemble s), Some (FEnsemble (Subtract _ s w)));
                                           (SCA _ w, None)]
                                  /\ ret = SCAZero
      |}; crush_types.
  Defined.

  (* Def Method sIn (s : rep , w : W) : bool :=
        (b <- { b : bool | b = true <-> Ensembles.In _ s w };
         ret (s, b)) *)
  Definition FEnsemble_sIn : AxiomaticSpec ADTValue.
    refine {|
        PreCond := fun args =>
                     exists s w, args = [ADT (FEnsemble s); SCA _ w];
        PostCond := fun args ret =>
                      exists s w, args = [(ADT (FEnsemble s), Some (FEnsemble s));
                                         (SCA _ w, None)]
                                  /\ exists w', ret = SCA _ w'
                                                /\ Bedrock.Programming.propToWord (Ensembles.In _ s w) w'
      |}; crush_types.
  Defined.

  (* These definitions should be imported *)
  Definition EnsembleListEquivalence
             {A}
             (ensemble : Ensemble A)
             (seq : list A) :=
    NoDup seq /\
    forall x, Ensembles.In _ ensemble x <-> List.In x seq.

  Definition cardinal U (A : Ensemble U) (n : nat) : Prop :=
    exists ls, EnsembleListEquivalence A ls /\ Datatypes.length ls = n.

  (* Def Method sSize (s : rep , _ : unit) : nat :=
          (n <- { n : nat | cardinal _ s n };
           ret (s, n)) *)
  Definition FEnsemble_sSize : AxiomaticSpec ADTValue.
        refine {|
        PreCond := fun args =>
                     exists s, args = [ADT (FEnsemble s)];
        PostCond := fun args ret =>
                      exists s n, args = [(ADT (FEnsemble s), Some (FEnsemble s))]
                                  /\ @cardinal _ s n
                                  /\ ret = SCA _ (Word.natToWord 32 n)
          |}; crush_types.
  Defined.

End FiniteSetADTSpec.


Require Import Coq.Strings.String Coq.Sets.Ensembles.
Require Import Fiat.Common.
Require Export Fiat.Computation.Notations.

Definition Comp := @Ensemble.

Definition Return (A : Type) : A -> Comp A :=
  Singleton A.

Definition Bind (A B : Type)
           (ca : Comp A)
           (k : A -> Comp B)
: Comp B :=
  fun b =>
    exists a : A,
      In A ca a /\ In B (k a) b.

Definition Pick (A : Type)
           (P : Ensemble A)
: Comp A := P.

Definition Bind2 (A B C: Type)
           (c : Comp (A * B))
           (k : A -> B -> Comp C)
  := Bind c (fun ab => k (fst ab) (snd ab)).

Bind Scope comp_scope with Comp.
Arguments Bind [A%type B%type] ca%comp k%comp _.
Arguments Bind2 [A%type B%type C%type] c%comp k%comp _.
Arguments Return [_] _ _.
Arguments Pick [_] _ _.

Notation ret := Return.

Notation "x >>= y" := (Bind x%comp y%comp) : comp_scope.
Notation "x <- y ; z" := (Bind y%comp (fun x => z%comp))
                           (at level 81, right associativity,
                            format "'[v' x  <-  y ; '/' z ']'") : comp_scope.

Notation "`( a , b ) <- c ; k" :=
  (Bind2 c%comp (fun a b => k%comp))
    (at level 81, right associativity,
     format "'[v' `( a ,  b )  <-  c ; '/' k ']'") : comp_scope.

Notation "x >> z" := (Bind x%comp (fun _ => z%comp) )
                       (at level 81, right associativity,
                        format "'[v' x >> '/' z ']'") : comp_scope.
Notation "{ x  |  P }" := (@Pick _ (fun x => P)) : comp_scope.
Notation "{ x : A  |  P }" := (@Pick A%type (fun x => P)) : comp_scope.

Definition computes_to {A : Type} (ca : Comp A) (a : A) : Prop := ca a.

Notation "c ↝ v" := (computes_to c v).

Lemma ReturnComputes
      {A : Type}
: forall (a : A),
    ret a ↝ a.
Proof.
  constructor.
Qed.

Lemma BindComputes
      {A B: Type}
: forall (ca : Comp A)
         (f : A -> Comp B)
         (a : A)
         (b : B),
    ca ↝ a ->
    f a ↝ b ->
    ca >>= f ↝ b.
Proof.
  econstructor; eauto.
Qed.

Lemma PickComputes {A : Type}
: forall (P : Ensemble A)
         (a : A),
    P a ->
    {a' | P a'} ↝ a.
Proof.
  intros; eauto.
Qed.

Lemma Return_inv {A : Type}
: forall (a v : A),
    ret a ↝ v -> a = v.
Proof.
  destruct 1; reflexivity.
Qed.

Lemma Bind_inv {A B: Type}
: forall (ca : Comp A)
         (f : A -> Comp B)
         (v : B),
    ca >>= f ↝ v ->
  exists a',
    ca ↝ a' /\ f a' ↝ v.
Proof.
  destruct 1; eauto.
Qed.

Lemma Pick_inv {A : Type}
: forall (P : Ensemble A)
         (v : A),
    {a | P a} ↝ v -> P v.
Proof.
  eauto.
Qed.

(** The old program might be non-deterministic, and the new program
      less so.  This means we want to say that if [new] can compute to
      [v], then [old] should be able to compute to [v], too. *)
Definition refine {A}
           (old : Comp A)
           (new : Comp A)
  := forall v, new ↝ v -> old ↝ v.

(* A definition and notation for pretty printing the goals used to
   interactively deriving refinements. *)

Definition Refinement_Of {A} (c : Comp A) :=
  {c' | refine c c'}.

Notation "'Refinement' 'of' c" :=
  {c' | refine c c'}
    (at level 0, no associativity,
     format "'Refinement'  'of' '/' '[v'    c ']' " )
  : comp_scope.

(** Define a symmetrized version of [refine] for ease of rewriting *)
Definition refineEquiv {A}
           (old : Comp A)
           (new : Comp A)
  := refine old new /\ refine new old.

Local Ltac t := repeat first [ solve [ unfold computes_to in *; eauto ]
                                        | progress hnf in *
                                        | intro
                                        | split
                                        | progress split_and ].

Global Instance refine_PreOrder A : PreOrder (@refine A).
t.
Qed.

Global Instance refineEquiv_Equivalence A : Equivalence (@refineEquiv A).
t.
Qed.

Global Opaque Return.
Global Opaque Bind.
Global Opaque Pick.
Global Opaque computes_to.

Global Hint Resolve ReturnComputes.
Global Hint Resolve BindComputes.
Global Hint Resolve PickComputes.

Ltac computes_to_inv :=
  repeat match goal with
           | H : {a' | @?P a'} ↝ _ |- _ => apply Pick_inv in H
           | H : Return ?a ↝ _ |- _ => apply Return_inv in H
           | H : Bind (A := ?A) ?ca ?k ↝ _ |- _ =>
             apply Bind_inv in H;
               let a' := fresh "v" in
               let H' := fresh H "'" in
               destruct H as [a' [H H'] ]
         end.

Ltac computes_to_econstructor :=
  first
    [ unfold refine; intros; eapply @ReturnComputes
    | unfold refine; intros; eapply @BindComputes
    | unfold refine; intros; eapply @PickComputes ].

Ltac computes_to_constructor :=
  first
    [ unfold refine; intros; apply @ReturnComputes
    | unfold refine; intros; apply @BindComputes
    | unfold refine; intros; apply @PickComputes ].


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  A variable module.

*)

Set Implicit Arguments.
Require Export BooleanEqualityDef.

Module Type VariableEquality <: BooleanEquality.
  Inductive Var : Set :=
  | var   : nat -> Var.
  Definition t := Var.

   Parameter eq : t -> t -> Prop.
   Parameter eq_equiv : Equivalence eq.
   Parameter eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
   Parameter eqb : t -> t -> bool.
   Parameter eqb_eq : forall x y : t, eqb x y = true <-> eq x y.
   Parameter eqb_refl : forall a : t, eqb a a = true.
   Parameter eqb_sym : forall x y : t, eqb x y = eqb y x.
   Parameter eqb_trans :
     forall x y z : t, eqb x y = true -> eqb y z = true -> eqb x z = true.
   Parameter eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
   Parameter eqb_to_eq : forall a b : t, eqb a b = true -> a = b.
   Parameter eqb_to_neq : forall a b : t, eqb a b = false -> a <> b.
   Parameter eqb_iff_eq : forall a b : t, eqb a b = true <-> a = b.
   Parameter eqb_iff_neq : forall a b : t, eqb a b = false <-> a <> b.

  Hint Resolve eqb.
  Hint Resolve eqb_refl.
  Hint Rewrite eqb_refl.
  Hint Immediate eqb_sym.
  Hint Resolve eqb_trans.
  Hint Resolve eq_trans.
  Hint Resolve eqb_to_eq.
  Hint Resolve eqb_to_neq.
  Hint Resolve eqb_iff_eq.
  Hint Resolve eqb_iff_neq.
End VariableEquality.


From CReal.MetricSpace Require Export M_pack.
From CReal.MetricSpace Require Export M_prop.
(**definition and some propsition of new Cauchilized Space**)
Inductive Cauchilize {A X : Type} (eqX : relation X) (eqA : relation A)
                (leX : relation X) (plusX : X -> X -> X) (x0 : X) (dist : A -> A -> X)
                    {mof : Plus_Field eqX leX plusX x0}  {M : Metric eqX eqA leX plusX _ mof dist}
                        : Type :=
  | con_intro (Cseq : prj_nat)(H : CauchySeq eqX eqA Cseq) .
Definition sig_inv {A X : Type} {eqX : relation X} {eqA : relation A}
          {leX : relation X} {plusX : X -> X -> X} {x0 : X} {dist : A -> A -> X}
                {mof : Plus_Field eqX leX plusX x0} {M : Metric eqX eqA leX plusX _ mof dist}
                    {HEX : Equivalence eqX} {HEA : Equivalence eqA} (a : A) :
            Cauchilize eqX eqA leX plusX _ _:=
        con_intro eqX eqA leX plusX _ _ (@singleton A eqA a)
                (c_trans X eqX HEX A eqA HEA leX plusX _ mof a).
Definition equC {A X : Type} {eqX : relation X} {eqA : relation A}
           {leX : relation X} {plusX : X -> X -> X} {x0 : X} {dist : A -> A -> X}
                {mof : Plus_Field eqX leX plusX x0} {M : Metric eqX eqA leX plusX x0 mof dist}
        (x1 x2 : Cauchilize eqX eqA leX plusX _ _):  Prop  :=
  match x1,   x2 with
    | con_intro _ _ _ _ _ _ cseq1 C1, con_intro _ _ _ _ _ _ cseq2 C2 =>
        (forall (eps : X), x0 < eps
             -> (exists (N : nat), forall (n :nat), (N < n)%nat
             -> forall (a1 a2 : A), cseq1 n a1  -> cseq2 n a2
             -> (dist a1 a2) < eps))
  end.
Notation "a == b" := (equC a b)
    (at level 70, no associativity) : equC.
Lemma refl_equC : forall {A X : Type} {eqX : relation X} {eqA : relation A}
          {leX : relation X} {plusX : X -> X -> X} {HE : Equivalence eqX} {x0 : X} {dist : A -> A -> X}
               {HEA : Equivalence eqA} {mof : Plus_Field eqX leX plusX x0}
                  {M : Metric eqX eqA leX plusX _ mof dist}
                      (x : @Cauchilize A X eqX eqA _ _ _ _ mof M), equC x x.
Proof.
  intros. unfold equC. destruct x. intros. inversion H. apply HCA in H0.
  destruct H0. exists x. intros. assert( (x < n) %nat /\  (x < n)%nat). split. auto. auto.
  apply H0 with (a := a1) (b := a2) in H4 . apply H4. split. apply H2. apply H3.
Qed.
Section EquR_playground.
Variables X : Type.
Variables A : Type.
Variables eqX : relation X.
Variables eqA : relation A.
Variables  leX : relation X.
Variables plusX : X -> X -> X.
Variables zero : X.
Variables HE : Equivalence eqX.
Variables HEA : Equivalence eqA.
Variables mof : Plus_Field eqX leX plusX zero.
Variables dist : A -> A -> X.
Variables M : Metric eqX eqA leX plusX _ mof dist.
Variables Dpd : Density eqX mof.
Notation "a + b" := (plusX a b)
  (at level 50, left associativity).
Notation "a <= b" := (leX a b)
  (at level 70, no associativity).
Notation "a >= b" := (leX b a)
  (at level 70, no associativity).

Instance EquR_trans : Equivalence (equC).
Proof.
  intros. split.
  -unfold Reflexive. apply refl_equC.
  -unfold Symmetric. unfold equC. destruct x. destruct y.
    intros. destruct H1 with (eps := eps). auto.
    exists x. intros. rewrite msy. apply H3 with (n := n). auto.
    auto. auto.
 -unfold Transitive. unfold equC. destruct x. destruct y. destruct z.
  intros. apply division_of_eps in H4. destruct H4 as [d1].
  destruct H4 as [d2]. destruct H4. destruct H5. destruct H2 with (eps := d1).
  auto. destruct H3 with (eps := d2). auto. remember x0 as x1.
  assert((x <= x1) %nat \/ (x1 <= x)%nat). apply le_one.
  destruct H9. exists x1. intros. assert(exists a, Cseq0 n a).
  apply HCseq1. destruct H13 as [a].
  destruct H7 with (n := n) (a1 := a1) (a2 := a). apply le_lt_or_eq in H9.
  destruct H9. apply (lt_trans _ x1 _).
  auto. auto. rewrite H9. auto. auto. auto.
  destruct H8 with (n := n) (a1 := a) (a2 := a2). auto. auto. auto.
  assert(dist a1 a2 <= ((dist a1 a) + (dist a a2)) -> ((dist a1 a) + (dist a a2)) < eps -> dist a1 a2 < eps).
  intros. destruct (le_lt_eq X eqX _ (dist a1 a2) (plusX (dist a1 a) (dist a a2))) as [Hex1 Hex2].
  apply Hex1 in H14. destruct H14.
  apply lttr with (y := (dist a1 a + dist a a2)). auto.
  auto. auto. rewrite H14. auto. apply H14. apply mtr.
  apply lt_intro. rewrite <- H6. apply le_two_plus_two with (eqX := eqX) (x0 := zero);auto.
  rewrite <- H6. unfold not. intros. assert(dist a1 a + dist a a2 < d1 + d2).
  apply lt_two_plus_two. auto. apply lt_intro. auto. auto.
  apply lt_intro. auto. auto. inversion H16.
  assert(eqX (dist a1 a + dist a a2) (d1 + d2) /\ ~eqX (dist a1 a + dist a a2) (d1 + d2)).
  split. auto. auto.
  apply PNP in H17. destruct H17.
  +exists x. intros. assert(exists a, Cseq0 n a). apply HCseq1. destruct H13 as [a].
    destruct H8 with (n := n) (a1 := a) (a2 := a2).
         *apply le_lt_or_eq in H9. destruct H9.
         apply (lt_trans _ x _). auto. auto. rewrite <-H9 in H10.
           auto.
         *auto. *auto.
          *destruct H7 with(n := n) (a1 := a1) (a2 := a). auto. auto. auto.
            rewrite <- H6. assert(dist a1 a2 <= dist a1 a + dist a a2).
            apply mtr. assert(dist a1 a + dist a a2 < d1 + d2).
            apply lt_two_plus_two. auto. apply lt_intro. auto. auto. apply lt_intro. auto. auto.
            destruct (le_lt_eq X eqX _  (dist a1 a2) (dist a1 a + dist a a2)) as [Hex1 Hex2]. apply Hex1 in H14.
            destruct H14. apply lttr with (y := dist a1 a + dist a a2);auto.
            rewrite <-H14 in H15. auto.
  +auto.
  +auto.
Defined.
End EquR_playground.
Existing Instance EquR_trans.
Definition leC {X : Type} {eqX : relation X} {leX : relation X} {plusX : X -> X -> X} {x0 : X}
        {dist : X -> X -> X}
        {mof : Plus_Field eqX leX plusX x0}  {M : Metric eqX eqX _ _ _ mof dist} {HE : Equivalence eqX}
        (x1 x2 : Cauchilize eqX eqX _ _ _ _) : Prop :=
    match x1,   x2 with
    | con_intro _ _ _ _ _ _ cseq1 _, con_intro _ _ _ _ _ _ cseq2 _ =>
         equC  x1 x2 \/ (exists (N : nat), forall (n : nat) (a1 a2 : X), (N < n)%nat -> cseq1 n a1
             -> cseq2 n a2 -> a1 < a2)
    end.
Notation " x1 <= x2" := (leC x1 x2) : leC.
Definition ltC {X : Type} {eqX : relation X} {leX : relation X} {plusX : X -> X -> X} {x0 : X}
        {dist : X -> X -> X}
        {mof : Plus_Field eqX leX plusX x0}  {M : Metric eqX eqX _ _ _ mof dist} {HE : Equivalence eqX}
        (x1 x2 : Cauchilize eqX eqX _ _ _ _) : Prop := leC x1 x2 /\ ~equC x1 x2 .
Notation "x1 < x2" := (ltC x1 x2) : ltC.
Section leCpre_playground.
Variables X : Type.
Variables eqX : relation X.
Variables leX : relation X.
Variables plusX : X -> X -> X.
Variables zero : X.
Variables mof : Plus_Field eqX leX plusX zero.
Variables dist : X -> X -> X.
Variables M : Metric eqX eqX _ _ _ mof dist.
Variables Dpd : Density eqX mof.
Variables HE : Equivalence eqX.

Variables HP : PropBucket.
Notation "a <= b" := (leX a b)
  (at level 70, no associativity).
Notation "a >= b" := (leX b a)
  (at level 70, no associativity).
Notation "a + b" := (plusX a b)
  (at level 50, left associativity).

Theorem leC_pre : forall (a b c d : Cauchilize eqX eqX _ _ _ _),
     equC a b -> equC c d -> leC a c -> leC b d .
Proof.
  intros.
  destruct (classic (equC a c)). -unfold leC. destruct b. destruct d. left.
  destruct (EquR_trans X X _ eqX leX plusX _ _ _ _ _ _); auto. rewrite <-H.
   rewrite  <-H0. auto.
    -unfold equC in H2. destruct a as [a ?], c as [c ?]. simpl in H1. destruct H1; [tauto |].
    apply not_all_ex_not in H2. destruct H2 as [eps]. apply not_all_ex_not in H2. destruct H2 as [Heps].
    assert(forall N : nat, (exists n : nat, (N < n)%nat /\ (exists a1 a2 : X, a n a1 /\
        c n a2 /\ eps <= dist a1 a2))).
        intros. apply not_ex_all_not with (n := N) in H2. apply not_all_ex_not in H2. destruct H2.
       exists x. split. apply not_all_ex_not in H2. destruct H2. auto. apply not_all_ex_not in H2.
       destruct H2. apply not_all_ex_not in H2. destruct H2. remember x1 as x2.
       exists x2. apply not_all_ex_not in H2.
       destruct H2. exists x3. apply not_all_ex_not in H2. destruct H2. apply not_all_ex_not in H2.
       destruct H2. split. auto. split. auto. destruct (lt_not X eqX _ _ (dist x2 x3) eps) as [Hex1 Hex2].
       apply Hex1;auto. destruct H1 as [N].
       destruct (division_of_eps _ _ _ _ _ _ eps) as [eps1 [eps2]]. auto.
       destruct (division_of_eps _ _ _ _ _ _ eps1) as [eps1a [eps1b]]. destruct H6. auto.
        destruct (division_of_eps _ _ _ _ _ _ eps2) as [eps2a [eps2b]].
        destruct H6.
        destruct H8. auto.
        assert(exists N : nat, forall m n : nat, (N < m)%nat /\ (N < n)%nat -> forall t1 t2 : X, a m t1 /\ a n t2 -> eps1a > dist t1 t2).
         apply HCA. destruct H7. auto.
         destruct H9 as [N9]. destruct b. simpl in H.
         destruct H with (eps := eps1b) as [N11]. +destruct H7. destruct H11. auto.
         +destruct H6 as [Heps1 [Heps2 Hepseq]]. destruct H7 as [Heps1a [Heps1b Heps1eq]].
         destruct H8 as [Heps2a [Heps2b Heps2eq]].
         assert(exists N : nat, forall m n : nat,
         (N < m)%nat /\ (N < n)%nat -> forall t1 t2 : X, c m t1 /\ c n t2 -> eps2a > dist t1 t2).
         apply HCA. auto.
        destruct d. simpl  in H0. destruct H0 with (eps := eps2b) as [N8].
        auto. destruct H6 as [N6]. destruct (always_greater N N9) as [G0 Hfin].
        destruct (always_greater G0 N11) as [G1]. destruct (always_greater N6 N8) as [G2].
        destruct (always_greater G1 G2) as [G3]. destruct H5 with (N := G3) as [N15].
        destruct H12 as [HG1 HG2]. destruct H13 as [HG3 HG4]. destruct H14 as [HG5 HG6].
        destruct H15 as [HG7 H16]. destruct H16 as [apin [cpin H16] ]. destruct H16 as [H16 [H17 H18]]. destruct Hfin as [Hfin1 Hfin2].
        simpl. right. destruct (always_greater G3 N15) as [G]. destruct H12 as [HG8 HG9].
        exists G. intros. assert(exists afloat, a n afloat). apply HCseq1. destruct H15 as [afloat].
        assert(exists cfloat, c n cfloat). apply HCseq1. destruct H19 as [cfloat].
        destruct H9 with (m := N15) (t1 := apin) (n := n) (t2 := afloat).
        split. apply (lt_trans _ G0 _). auto.  apply (lt_trans _ G1 _). auto. apply (lt_trans _ G3 _).
        auto. auto.  apply (lt_trans _ G0 _). auto.  apply (lt_trans _ G1 _). auto.
        apply (lt_trans _ G3 _). auto. apply (lt_trans _ N15 _). auto.
        apply (lt_trans _ G _). auto. auto. split. auto. auto.
        destruct H6 with (m := N15) (t1 := cpin) (n := n) (t2 := cfloat).
        split.
        apply (lt_trans _ G2 _). auto. apply (lt_trans _ G3 _). auto. auto. auto.
        apply (lt_trans _ G2 _). auto. apply (lt_trans _ G3 _). auto. apply (lt_trans _ N15 _). auto.
     apply (lt_trans _ G _). auto. auto. split. auto. auto.
     destruct H8 with (n := n) (a1 := cfloat) (a2 := a2).
        apply (lt_trans _ G2 _). auto. apply (lt_trans _ G3 _). auto.
        apply (lt_trans _ N15 _). auto. apply (lt_trans _ G _). auto. auto.
        auto. auto.
      destruct H11 with (n := n) (a1 := afloat) (a2 := a1).
      apply (lt_trans _ G1 _). auto. apply (lt_trans _ G3 _). auto.
      apply (lt_trans _ N15 _). auto. apply (lt_trans _ G _). auto. auto.
      auto. auto.
      assert(dist apin a1 < eps1). {
          assert(dist apin a1 <= dist apin afloat + dist afloat a1). apply mtr.
          assert(dist apin afloat + dist afloat a1 < eps1a + eps1b).
          apply lt_two_plus_two. auto. apply lt_intro. auto. auto. apply lt_intro.
          auto. auto. rewrite Heps1eq in H21.
          destruct (le_lt_eq _ _ _  (dist apin a1) (dist apin afloat + dist afloat a1)) as [Hex1 Hex2].
          apply Hex1 in H20. destruct H20.
          apply lttr with (y := dist apin afloat + dist afloat a1). auto. auto. auto.
          rewrite <-H20 in H21. auto. }
      assert(dist cpin a2 < eps2). {
          assert(dist cpin a2 <= dist cpin cfloat + dist cfloat a2). apply mtr.
          assert(dist cpin cfloat + dist cfloat a2 < eps2a + eps2b).
          apply lt_two_plus_two. auto. apply lt_intro. auto. auto. apply lt_intro.
          auto. auto. rewrite Heps2eq in H22.
          destruct (le_lt_eq _ _ _ (dist cpin a2) (dist cpin cfloat +dist cfloat a2)) as [Hex1 Hex2].
          apply Hex1 in H21. destruct H21.
          apply lttr with (y := dist cpin cfloat + dist cfloat a2). auto. auto. auto.
          rewrite <-H21 in H22. auto. }
      assert(dist a1 cpin > eps2). {
          assert(dist a1 cpin + dist apin a1 >= dist apin cpin). rewrite pfc.
           apply mtr. assert(exists id_api_a1,eqX (dist apin a1 + id_api_a1) zero).
           apply pfi. destruct H23 as [id_api_a1].
           assert(dist a1 cpin + dist apin a1 + id_api_a1 >= dist apin cpin + id_api_a1).
           apply le_two_plus_two with (eqX := eqX) (x0 := zero);auto. apply pofr. reflexivity.
           rewrite pfa in H24. rewrite H23 in H24. rewrite (pfc _ zero) in H24. rewrite pfz in H24.
           assert(exists ieps1, eqX (eps1 + ieps1) zero). apply pfi. destruct H25 as [ieps1].
           assert(id_api_a1 > ieps1). apply lt_inv with (x := dist apin a1) (y := eps1);auto.
           assert(dist apin cpin + id_api_a1 > eps + ieps1).
           destruct (le_lt_eq _ _ _ eps (dist apin cpin)) as [Hex1 Hex2].
           apply Hex1 in H18. destruct H18.
           apply lt_two_plus_two;auto. rewrite H18. rewrite pfc.
           rewrite (pfc _ id_api_a1). apply HpOt. auto. auto. rewrite <-Hepseq in H27.
           rewrite (pfc eps1 _) in H27. rewrite pfa in H27. rewrite H25 in H27.
           rewrite pfc in H27. rewrite pfz in H27.
           destruct (le_lt_eq _ _ _ (dist apin cpin + id_api_a1) (dist a1 cpin)) as [Hex1 Hex2].
           apply Hex1 in H24.
           destruct H24. apply lttr with (y := dist apin cpin + id_api_a1); auto.
           rewrite H24 in H27. auto. }
       assert(dist a2 apin > eps1). {
           assert(dist a2 apin + dist cpin a2 >= dist apin cpin). rewrite (msy a2 _).
           rewrite (msy cpin _). apply mtr.
           assert(exists id_cpi_a2, eqX (dist cpin a2 + id_cpi_a2) zero).
           apply pfi. destruct H24 as [id_cpi_a2].
           assert(dist a2 apin + dist cpin a2 + id_cpi_a2 >= dist apin cpin + id_cpi_a2).
           apply le_two_plus_two with (eqX := eqX) (x0 := zero);auto. apply pofr. reflexivity.
           rewrite pfa in H25.
           rewrite H24 in H25. rewrite (pfc _ zero) in H25. rewrite pfz in H25.
           assert(exists ieps2, eqX (eps2 + ieps2) zero). apply pfi. destruct H26 as [ieps2].
           assert(id_cpi_a2 > ieps2). apply lt_inv with (x := dist cpin a2) (y := eps2).
           auto. auto. auto. auto. assert(dist apin cpin + id_cpi_a2 > eps + ieps2).
           destruct (le_lt_eq _ _ _ eps (dist apin cpin)) as [Hex1 Hex2].
           apply Hex1 in H18. destruct H18. apply lt_two_plus_two;auto.
           rewrite H18. rewrite pfc. rewrite (pfc _ id_cpi_a2). apply HpOt; auto.
           rewrite <-Hepseq in H28. rewrite pfa in H28. rewrite H26 in H28.
           rewrite pfc in H28. rewrite pfz in H28.
           destruct (le_lt_eq _ _ _ (dist apin cpin + id_cpi_a2) (dist a2 apin)) as [Hex1 Hex2].
           apply Hex1 in H25. destruct H25.
           apply lttr with (y := dist apin cpin + id_cpi_a2);auto.
           rewrite H25 in H28. auto. }
           assert(ball apin eps1 a1). {apply ball_intro;auto. }
           assert(ball cpin eps2 a2). {apply ball_intro;auto. }
           assert(~ball apin eps1 a2). {unfold not. intros. inversion H26.
               assert(eps1 > dist apin a2 /\ eps1 < dist apin a2). split. auto. rewrite msy. auto.
               apply lt_not_and in H28. destruct H28. }
           assert(~ball cpin eps2 a1). {unfold not. intros. inversion H27.
               assert(eps2 > dist cpin a1 /\ eps2 < dist cpin a1). split. auto. rewrite msy. auto.
               apply lt_not_and in H29. destruct H29. }
            assert(~ball cpin eps2 apin). {unfold not. intros. inversion H28.
                assert(dist apin cpin > eps2). assert(eps > eps2). apply lt_div with (b := eps1).
                auto. rewrite pfc. auto. auto. auto. destruct (le_lt_eq _ _ _ eps (dist apin cpin)) as [Hex1 Hex2].
                apply Hex1 in H18. destruct H18.
                apply lttr with (y := eps);auto. rewrite <-H18;auto.
                assert(eps2 > dist cpin apin /\ eps2 < dist cpin apin). split. auto. rewrite msy.
                auto. apply lt_not_and in H31. destruct H31. }
            assert(a2 > apin). {apply inBall2 with (a0 := cpin) (eps0 := eps2);auto.
                destruct H1 with (n := N15) (a1 := apin) (a2 := cpin). apply (lt_trans _ G0 _).
                auto. apply (lt_trans _ G1 _). auto. apply (lt_trans _ G3 _); auto. auto. auto.
                apply lt_intro. auto. auto. }
            apply inBall1 with (a0  := apin) (eps0 := eps1). auto. auto. auto.
Qed.
End leCpre_playground.
Instance leC_rewrite : forall (X : Type) (eqX : relation X) (leX : relation X) (plusX : X -> X -> X)
  (x0 : X) (dist : X -> X -> X)
  {mof : Plus_Field eqX leX plusX x0} (M : Metric eqX eqX _ _ _ mof dist)
 {Dpd : Density eqX mof} (HE : Equivalence eqX) (HP : PropBucket) ,
      Proper (equC ==> equC ==> iff) leC.
    intros. hnf. intro x1. intro x2. intro. hnf. intro. intro. intro. split.
    -apply leC_pre. auto. auto. auto. auto.
    -apply leC_pre. auto. auto. destruct (EquR_trans X X _ eqX leX plusX _ _ _ _ _ _);auto.
      destruct (EquR_trans X X _ eqX leX plusX _ _ _ _ _ _);auto.
Defined.
Section leC_Field.
(**This section only talks about the pre_order_field on Cauchilize eqX eqX**)
Variables X : Type.
Variables eqX : relation X.
Variables leX : relation X.
Variables plusX : X -> X -> X.
Variables x0 : X.

Variables HE : Equivalence eqX.
Variables mof : Plus_Field eqX leX plusX x0.
Variables dist : X -> X -> X.
Variables M : Metric eqX eqX _ _ _ mof dist.
Variables Dpd : Density eqX mof.
Variables HPB :PropBucket.
Notation "a == b" := (eqX a b)
    (at level 70, no associativity).
Notation "a != b" := (~eqX a b)
    (at level 70, no associativity).
Notation "a + b" := (plusX a b)
    (at level 50, left associativity).
Notation "a <= b" := (leX a b)
    (at level 70, no associativity).
Notation "a >= b" := (leX b a)
    (at level 70, no associativity).
Instance le_prop_inst : Proper (equC ==> equC ==> iff) leC.
Proof.
       apply leC_rewrite;auto.
Defined.
Theorem preOrder_trans : @Pre_Order_Field (Cauchilize eqX eqX _ _ _ _) equC leC.
Proof.
      split.
     -intros. destruct a. destruct b. left. auto.
     -destruct a as [cseqa]. destruct b as [cseqb]. destruct c as [cseqc].
       intros. destruct H2. destruct H3.
            +rewrite H2. rewrite H3. left. reflexivity.
            +rewrite H2. right. auto.
            +destruct H3. *rewrite <- H3. right. auto.
                                    *right. destruct H2 as [N1]. destruct H3 as [N2].
                                    assert((N1 <= N2)%nat \/ (N2 <= N1)%nat). apply le_one.
                                    destruct H4. exists N2. {intros. assert(exists a, (cseqb n a)).
                                    apply HCseq1. destruct H8 as[a]. apply lttr with (y := a).
                                    auto. apply H2 with (n := n) (a1 := a1) (a2 := a). apply le_lt_or_eq in H4.
                                    destruct H4. apply lt_trans with (p := n) in H4. auto.
                                    auto. rewrite H4. auto. auto. auto. apply H3 with (n := n) (a2 := a2) (a1 := a).
                                    apply le_lt_or_eq in H4. destruct H4. apply lt_trans with (p := n) in H4.
                                    auto. auto. auto. auto. auto. }
                                    { exists N1. intros. assert(exists a, cseqb n a).
                                    apply HCseq1. destruct H8 as [a]. apply lttr with (y := a).
                                    auto. apply H2 with (n := n). auto. auto. auto. apply H3 with (n := n).
                                    apply le_lt_or_eq in H4. destruct H4. apply lt_trans with (p := n) in H4.
                                    auto. auto. rewrite H4. auto. auto. auto. }
     -intros. rewrite <- H. rewrite <- H0. auto.
     -intros. destruct (classic (equC a b)). {left. unfold leC. destruct a. destruct b. left. auto. }
           {unfold not in H. destruct a. destruct b. unfold equC in H. apply not_all_ex_not in H.
           destruct H as [eps]. apply not_all_ex_not in H. destruct H as [Heps0].
           assert(forall N : nat, ~( forall n : nat,  (N < n)%nat -> forall a1 a2 : X, Cseq n a1 ->
            Cseq0 n a2 -> eps > dist a1 a2)).
            intros. unfold not. intros. unfold not in H. apply H. exists N. auto.
            destruct (division_of_eps _ _ _ _ _ _ eps) as [eps1]. auto. destruct H3 as [eps2].
            destruct H3 as [Heps1 [Heps2 Hepseq ]]. assert(forall eps : X,
       eps > x0 -> exists N : nat, forall m n : nat, (N < m)%nat /\ (N < n)%nat -> forall a b : X,
         Cseq0 m a /\ Cseq0 n b -> eps > dist a b). apply HCA.
         assert(forall eps : X,eps > x0 -> exists N : nat,
         forall m n : nat, (N < m)%nat /\ (N < n)%nat -> forall a b : X,
         Cseq m a /\ Cseq n b -> eps > dist a b). apply HCA.
         destruct H3 with (eps := eps1) as [N5]. auto. destruct H4 with (eps := eps2) as [N6].
         auto. destruct (always_greater N5 N6) as [G0]. destruct H7.
         assert(~ (forall n : nat, (G0 < n)%nat -> forall a1 a2 : X,  Cseq n a1 ->
      Cseq0 n a2 -> eps > dist a1 a2)). auto.
      apply not_all_ex_not in H9. destruct H9 as [N9]. apply not_all_ex_not in H9.
      destruct H9 as [N10]. apply not_all_ex_not in H9. destruct H9 as [pin].
      apply not_all_ex_not in H9. destruct H9 as [pin0]. apply not_all_ex_not in H9.
      destruct H9 as [Hpin]. apply not_all_ex_not in H9. destruct H9 as [Hpin0].
      apply lt_not in H9. assert(~ pin == pin0). unfold not. intros. apply mre in H10.
      rewrite H10 in H9. assert(~(x0 >= eps)). destruct (le_not _ _ _ _ x0 eps) as [Hex1 Hex2].
      apply Hex1;auto. unfold not in H11.
      apply H11. auto. assert(pin < pin0 \/ pin > pin0). apply ltor. auto. auto.
      destruct H11. {left. unfold leC. right. exists N9. intro n. intro float. intro float0.
      intros. destruct H6 with (m := N9) (a := pin) (n := n) (b := float). split.
      apply (lt_trans _ G0 _). auto. auto. apply (lt_trans _ G0 _). auto. apply (lt_trans _ N9 _).
      auto. auto. split. auto. auto. destruct H5 with (m := N9) (a := pin0) (n := n) (b := float0).
      split. apply (lt_trans _ G0 _). auto. auto. apply (lt_trans _ G0 _). auto.
      apply (lt_trans _ N9 _). auto. auto. split. auto. auto.
      assert(ball pin eps2 float). {apply ball_intro. auto. apply lt_intro. auto. auto. }
      assert(ball pin0 eps1 float0). {apply ball_intro. auto. apply lt_intro. auto. auto. }
      assert(~ball pin eps2 pin0). {unfold not. intros. inversion H17. assert(eps > eps2).
      apply lt_div with (b := eps1). auto. rewrite pfc. auto. auto. auto.
      assert(dist pin pin0 > dist pin pin0). destruct (le_lt_eq _ _ _ eps (dist pin pin0)) as [Hex1 Hex2].
      apply Hex1 in H9. destruct H9.
      apply lttr with (y := eps). auto.
      apply lttr with (y := eps2). auto. auto. auto. auto.
      rewrite H9 in H19. apply lttr with (y := eps2);auto.
      pose proof (lt_not _ _ _ _ (dist pin pin0) (dist pin pin0)) as [Hex1 Hex2];auto.
      apply Hex2 in H20. destruct H20. auto. apply pofr. reflexivity. }
      assert(~ball pin0 eps1 float). {unfold not. intros. inversion H18.
          assert(eps1 < dist pin0 float). {assert(exists id_pin_float, dist pin float + id_pin_float == x0).
          apply pfi. destruct H20 as [id_pin_float]. assert(exists ieps2, eps2 + ieps2 == x0).
          apply pfi. destruct H21 as [ieps2]. assert(id_pin_float > ieps2).
           apply lt_inv with (y := eps2) (x := dist pin float). auto. auto. auto. apply lt_intro.
           auto. auto.
          assert(dist pin0 float + dist pin float >= dist pin pin0). rewrite pfc. rewrite (msy pin0 _). apply mtr.
          assert(dist pin0 float + dist pin float + id_pin_float >= dist pin pin0 + id_pin_float).
          apply le_two_plus_two with (eqX := eqX) (x0 := x0);auto.
          apply pofr. reflexivity. rewrite pfa in H24.
          rewrite H20 in H24. rewrite (pfc _ x0) in H24. rewrite pfz in H24.
          assert(dist pin0 float > eps + ieps2).
          destruct (le_lt_eq _ _ _ (dist pin pin0 + id_pin_float) (dist pin0 float)) as [Hex1 Hex2].
          apply Hex1 in H24. destruct H24.
          apply lttr with (y := dist pin pin0 + id_pin_float). auto.
          destruct (le_lt_eq _ _ _ eps (dist pin pin0)) as [Hex3 Hex4].
          apply Hex3 in H9.
          destruct H9. apply lt_two_plus_two. auto. auto. auto. rewrite H9.
          rewrite pfc. rewrite (pfc _ id_pin_float). apply HpOt. auto. auto. auto.
          rewrite <- H24. destruct (le_lt_eq _ _ _ eps (dist pin pin0)) as [Hex3 Hex4].
          apply Hex3 in H9. destruct H9. apply lt_two_plus_two.
          auto. auto. auto. rewrite H9. rewrite pfc. rewrite (pfc _ id_pin_float). apply HpOt.
          auto. auto. rewrite <-Hepseq in H25. rewrite pfa in H25. rewrite H21 in H25.
          rewrite pfc in H25. rewrite pfz in H25. auto. }
          assert(~(dist pin0 float > eps1 /\ dist pin0 float < eps1)). apply lt_not_and.
          destruct H21. split. auto. auto. }
       assert(pin0 > float). apply inBall1 with (a := pin) (eps0 := eps2). auto. auto. auto.
       apply inBall2 with (a := pin0) (eps0 := eps1). auto. auto. auto. }
       {right. unfold leC. right. exists N9. intro n. intro float0. intro float.
      intros. destruct H6 with (m := N9) (a := pin) (n := n) (b := float). split.
      apply (lt_trans _ G0 _). auto. auto. apply (lt_trans _ G0 _). auto. apply (lt_trans _ N9 _).
      auto. auto. split. auto. auto. destruct H5 with (m := N9) (a := pin0) (n := n) (b := float0).
      split. apply (lt_trans _ G0 _). auto. auto. apply (lt_trans _ G0 _). auto.
      apply (lt_trans _ N9 _). auto. auto. split. auto. auto.
      assert(ball pin eps2 float). {apply ball_intro. auto. apply lt_intro. auto. auto. }
      assert(ball pin0 eps1 float0). {apply ball_intro. auto. apply lt_intro. auto. auto. }
      assert(~ball pin eps2 pin0). {unfold not. intros. inversion H17. assert(eps > eps2).
      apply lt_div with (b := eps1). auto. rewrite pfc. auto. auto. auto.
      assert(dist pin pin0 > dist pin pin0).
      destruct (le_lt_eq _ _ _ eps (dist pin pin0)) as [Hex3 Hex4].
      apply Hex3 in H9. destruct H9.
      apply lttr with (y := eps). auto.
      apply lttr with (y := eps2). auto. auto. auto. auto.
      rewrite H9 in H19. apply lttr with (y := eps2). auto. auto. auto.
      destruct (lt_not _ _ _ _ (dist pin pin0) (dist pin pin0)) as [Hex1 Hex2].
      apply Hex2 in H20.
      destruct H20. apply pofr. reflexivity. }
      assert(~ball pin0 eps1 float). {unfold not. intros. inversion H18.
          assert(eps1 < dist pin0 float). {assert(exists id_pin_float, dist pin float + id_pin_float == x0).
          apply pfi. destruct H20 as [id_pin_float]. assert(exists ieps2, eps2 + ieps2 == x0).
          apply pfi. destruct H21 as [ieps2]. assert(id_pin_float > ieps2).
           apply lt_inv with (y := eps2) (x := dist pin float). auto. auto. auto. apply lt_intro.
           auto. auto.
          assert(dist pin0 float + dist pin float >= dist pin pin0). rewrite pfc. rewrite (msy pin0 _). apply mtr.
          assert(dist pin0 float + dist pin float + id_pin_float >= dist pin pin0 + id_pin_float).
          apply le_two_plus_two with (eqX := eqX) (x0 := x0);auto. apply pofr. reflexivity. rewrite pfa in H24.
          rewrite H20 in H24. rewrite (pfc _ x0) in H24. rewrite pfz in H24.
          assert(dist pin0 float > eps + ieps2).
          destruct (le_lt_eq _ _ _ (dist pin pin0 + id_pin_float) (dist pin0 float)) as [Hex1 Hex2].
          apply Hex1 in H24. destruct H24.
          apply lttr with (y := dist pin pin0 + id_pin_float). auto.
          destruct (le_lt_eq _ _ _ eps (dist pin pin0)) as [Hex3 Hex4].
          apply Hex3 in H9.
          destruct H9. apply lt_two_plus_two. auto. auto. auto. rewrite H9.
          rewrite pfc. rewrite (pfc _ id_pin_float). apply HpOt. auto. auto. auto.
          rewrite <- H24. destruct (le_lt_eq _ _ _ eps (dist pin pin0)) as [Hex3 Hex4].
          apply Hex3 in H9. destruct H9. apply lt_two_plus_two.
          auto. auto. auto. rewrite H9. rewrite pfc. rewrite (pfc _ id_pin_float). apply HpOt.
          auto. auto. rewrite <-Hepseq in H25. rewrite pfa in H25. rewrite H21 in H25.
          rewrite pfc in H25. rewrite pfz in H25. auto. }
          assert(~(dist pin0 float > eps1 /\ dist pin0 float < eps1)). apply lt_not_and.
          destruct H21. split. auto. auto. }
       assert(float > pin0). apply inBall2 with (a := pin) (eps0 := eps2). auto. auto. auto.
       apply inBall1 with (a := pin0) (eps0 := eps1). auto. auto. auto. } auto. }
     -intros. destruct a. destruct b. destruct H. destruct H0.
       +auto.
       +auto.
       +symmetry. destruct H0.
         *auto.
         *intros. destruct H as [n1]. destruct H0 as [n2].
          assert((n1 <= n2)%nat \/ (n2 <= n1)%nat). apply le_one.
          destruct H3. {unfold equC. intros. exists n2. intros. assert (a1 > a2).
          apply H with (n := n). apply le_lt_or_eq in H3. destruct H3.
          apply lt_trans with (p := n) in H3. auto. auto. rewrite H3.
          auto. auto. auto. assert (a1 < a2). apply H0 with (n := n).
          auto. auto. auto. assert (a1 > a2 -> a2 > a1 -> False). intros. inversion H10.
          inversion H11. assert(a1 == a2). apply pore. auto. auto. assert(a1 == a2 /\ ~(a1 == a2)).
          split. auto. auto. apply PNP in H13. destruct H13. apply H10 in H8.
           destruct H8. auto. }
           {exists n1. intros. assert(a1 > a2). apply H with (n := n). auto. auto. auto.
            assert(a2 > a1). apply H0 with (n := n). apply le_lt_or_eq in H3. destruct H3.
            apply lt_trans with (p := n) in H3. auto. auto. rewrite H3. auto. auto. auto.
            assert (a1 > a2 -> a2 > a1 -> False). intros. inversion H10.
          inversion H11. assert(a1 == a2). apply pore. auto. auto.
          assert(a1 == a2 /\ ~(a1 == a2)). split. auto. auto. apply PNP in H13.
          destruct H13. apply H10 in H8.
           destruct H8. auto. }
Qed.
End leC_Field.
Section plusC_playground.
Variables X : Type.
Variables eqX : relation X.
Variables leX : relation X.
Variables plusX : X -> X -> X.
Variables HE : Equivalence eqX.
Variables A : Type.
Variables eqA : relation A.
Variables leA : relation A.
Variables plusA : A -> A -> A.
Variables HEA : Equivalence eqA.
Variables zeroX : X.
Variables mof : Plus_Field eqX leX plusX zeroX.
Variables dist : A -> A -> X.
Variables M : Metric eqX eqA _ _ _ mof dist.
Variables zeroA : A.
Variables HPA : Plus_Field eqA leA plusA zeroA.
        (**This Plus_Field is sometimes the same as the field mof**)
Variables Dpd : Density eqX mof.
Variables HPD : forall a b c, eqX (dist (plusA a b) (plusA a c)) (dist b c).
Notation "a + b" := (plusA a b)
    (at level 50, left associativity).
Notation "a <= b" := (leX a b)
    (at level 70, no associativity).
Notation "a >= b" := (leX b a)
    (at level 70, no associativity).
Definition plusC (x y : Cauchilize eqX eqA _ _ _ _) : Cauchilize eqX eqA _ _ _ _.
    destruct x. destruct y. assert (CauchySeq eqX eqA (@dibasic A eqA _ _ _ HPA Cseq Cseq0)).
    apply plus_trans;auto. apply (con_intro eqX eqA _ _ _ _ (dibasic Cseq Cseq0) H1).
Defined.
Instance plusC_rewrite : Proper (equC ==> equC ==> equC) plusC.
    hnf. intros. hnf. intros. destruct x. destruct y. destruct x0. destruct y0. simpl in H0. simpl in H.
    simpl. intros. destruct (division_of_eps _ eqX _ _ _ _ eps H5) as [eps1].
    destruct H6 as [eps2[Heps1 [Heps2 Heq]]]. destruct H with (eps := eps1) as [N]. auto.
    destruct H0 with (eps := eps2) as [N0]. auto. destruct (always_greater N N0) as [G]. destruct H8.
    exists G. intros. destruct H11. destruct H12. rewrite He. rewrite He0.
    assert(dist (a + b) (a0 + b0) <=
        plusX (dist (a + b) (a + b0)) (dist (a + b0) (a0 + b0))). apply mtr.
    rewrite HPD in H11. rewrite (pfc a b0) in H11. rewrite (pfc a0 b0) in H11. rewrite HPD in H11.
    assert(dist b b0 < eps2). apply H7 with (n := n). apply (lt_trans _ G _). auto. auto. auto. auto.
    assert (dist a a0 < eps1). apply H6 with (n := n). apply (lt_trans _ G _). auto. auto. auto. auto. auto.
    assert(plusX (dist b b0) (dist a a0) <plusX eps2 eps1). apply lt_two_plus_two. auto. auto. auto.
    rewrite (pfc eps2 _) in H14. rewrite Heq in H14.
    destruct (le_lt_eq _ _ _  (dist (a + b) (b0 + a0)) (plusX (dist b b0) (dist a a0))) as [Hex1 Hex2].
    apply Hex1 in H11. destruct H11.
    apply lttr with (y := plusX (dist b b0) (dist a a0)). auto. rewrite (pfc a0 _ ); auto.
    auto. rewrite (pfc a0 _). rewrite H11. auto.
Defined.

End plusC_playground.
Existing Instance plusC_rewrite.
Section plus_field_trans.
 (**This section only prove that the Group (S, plusC, zeroC) is a well Group.
      S is the space of Type Cauchilize eqX eqX.**)
Variables X : Type.
Variables eqX : relation X.
Variables HE : Equivalence eqX.
Variables leX : relation X.
Variables plusX : X -> X -> X.
Variables x0 : X.
Variables dist : X -> X -> X.
Notation "a + b" := (plusX a b)
    (at level 50, left associativity).
Notation "a <= b" := (leX a b)
    (at level 70, no associativity).
Notation "a >= b" := (leX b a)
    (at level 70, no associativity).
Variables mof : Plus_Field eqX leX plusX x0.
Variables MX : Metric eqX eqX _ _ _ mof dist.
Variables DX : Density eqX mof.
Variables HPD : forall a b c : X, eqX (dist (a + b) (a + c)) (dist b c).
Variables HPB :PropBucket.
Variables HIN : forall a b, eqX (dist a b) (dist (inv a) (inv b)).

Definition CX :Type := Cauchilize eqX eqX _ _ _ _.
Definition plusCX :CX -> CX -> CX.
    apply plusC with (leA := leX) (plusA := plusX) (zeroA := x0); auto.
Defined.
Definition zeroX :CX.
    apply (sig_inv x0).
Defined.
Definition invX (x : CX) :CX.
    destruct x. pose proof inv_trans.
    assert(CauchySeq eqX eqX (invseq Cseq)). apply H0;auto.
    apply (con_intro eqX eqX _ _ _ _ (invseq Cseq) H1).
Defined.
Definition pofX :Pre_Order_Field equC leC.
    apply preOrder_trans with (HE := HE). auto. auto.
Defined.
Theorem pf_trans : Plus_Field equC leC plusCX zeroX.
Proof.
  split.
  -apply pofX.
  -intros. destruct x. destruct y. simpl. intros. destruct H. destruct H0.
    exists 0. intros. destruct H0. destruct H2. assert(eqX a b0).
    destruct HWS. apply HCseq3 with (m := n). auto. auto.
    assert(eqX a0 b). apply HCseq3 with (m := n). auto. auto.
    rewrite He. rewrite He0. rewrite H0. rewrite H2.
    rewrite pfc. pose proof mre. destruct H3 with (p1 := b + b0) (p2 := b + b0).
    rewrite H4. auto. reflexivity.
  -intros. destruct x. destruct y. destruct z. simpl. intros. exists 0. intros. destruct H4. destruct H5.
    rewrite He. rewrite He0. destruct Ha. destruct Hb0. rewrite He2. rewrite He1.
    assert(eqX a a0). destruct H. destruct HWS. apply HCseq3 with (m := n). auto. auto.
    assert(eqX b1 a1). destruct H0. destruct HWS. apply HCseq3 with (m := n). auto.
    auto. assert(eqX b b0). destruct H1. apply HCseq3 with (m := n). auto. auto.
    rewrite H4. rewrite H5. rewrite H6. rewrite pfa.
    pose proof (mre (a0 + (a1 + b0)) (a0 + (a1 + b0))) as [Hex1 Hex2].
    rewrite Hex1. auto. reflexivity.
    -intros. destruct x. simpl. intros. exists 0. intros. destruct H2. assert(eqX a x0).
      destruct (@well_sig X eqX x0). auto. assert(@singleton X eqX x0 n x0). apply sig.
      apply HCseq3 with (m := n). auto. auto. rewrite H2 in He. rewrite pfz in He. rewrite He.
      assert(eqX a2 b). apply HCseq3 with (m := n). auto. auto. rewrite H4.
      pose proof (mre b b) as [Hex1 Hex2];rewrite Hex1. auto.
      reflexivity.
    -intros. exists(invX x). destruct x. simpl. intros. exists 0.
      intros. assert(eqX a2 x0). destruct H3. reflexivity. symmetry;auto.
      assert(eqX a1 x0). destruct H2. rewrite He. destruct Hb.
      assert(eqX a a0). destruct H. apply HCseq3 with (m := n);auto.
      rewrite <-H5. unfold inv. destruct pfi_strong;auto. rewrite He0.
      assert(eqX a a0). destruct H. apply HCseq3 with (m := n);auto.
      rewrite H5. unfold inv. destruct pfi_strong. auto. rewrite H5. rewrite H4.
      pose proof (mre x0 x0) as [Hex1 ?];rewrite Hex1;[auto |reflexivity].
    -intros. destruct a. destruct b. destruct c. destruct d. simpl.
      intros. destruct (division_of_eps _ _ _ _ _ _ eps) as [eps1];auto.
      destruct H6 as [eps2 [Heps1 [Heps2 Heq]]].
      destruct H with (eps := eps1) as [N1];auto.
      destruct H0 with (eps := eps2) as [N2];auto.
      destruct (always_greater N1 N2) as [G]. destruct H8. exists G.
      intros. destruct H11. destruct H12. rewrite He. rewrite He0.
      assert(dist (a + b) (a0 + b0) <= dist (a + b) (a + b0) + dist (a + b0) (a0 + b0)).
      apply mtr.
      assert(eqX (dist (a + b) (a + b0)) (dist b b0)) as Hex1.
      rewrite HPD. reflexivity.
      assert(eqX (dist (a + b0) (a0 + b0)) (dist a a0)) as Hex2.
      rewrite (pfc _ b0). rewrite (pfc _ b0). rewrite HPD;reflexivity.
      rewrite Hex1 in H11. rewrite Hex2 in H11.
      assert(dist b b0 + dist a a0 < eps2 + eps1). apply lt_two_plus_two;auto.
      apply H7 with (n := n) (a1 := b) (a2 := b0);auto. apply (lt_trans _ G _);auto.
      apply H6 with (n := n) (a1 := a) (a2 := a0);auto. apply(lt_trans _ G _);auto.
      rewrite (pfc eps2 _) in H12. rewrite Heq in H12.
      destruct (le_lt_eq _ _ _ (dist (a + b) (a0 + b0)) (dist b b0 + dist a a0)) as [Hex3 Hex4].
      apply Hex3 in H11.
      destruct H11. apply lttr with (y := (dist b b0 + dist a a0));auto.
      rewrite H11;auto.
    -intros. destruct x. destruct y. destruct z. simpl. simpl in H. destruct H.
      +left. intros. destruct H with (eps := eps) as [N];auto. exists N.
        intros. destruct H6. destruct H7. rewrite He. rewrite He0.
        assert(eqX b b0). destruct H2. apply HCseq3 with (m := n);auto.
        rewrite H6. rewrite (pfc a _). rewrite (pfc a0 _). rewrite HPD.
        apply H4 with (n := n);auto.
      +right. destruct H as [N]. exists N. intros. destruct H4. destruct H5.
        rewrite He. rewrite He0. assert(eqX b0 b). destruct H2.
        apply HCseq3 with (m := n);auto. rewrite H4. apply HpOt;auto.
        apply H with (n := n);auto.
Qed.
End plus_field_trans.
Definition distC  {A X : Type} {eqX : relation X} {eqA : relation A} {HE : Equivalence eqX} {HEA : Equivalence eqA}
           {leX : relation X} {plusX : X -> X -> X} {x0 : X}
           {dist : A -> A -> X} {distX : X -> X -> X}
           {mof : Plus_Field eqX leX plusX x0}
           {M : Metric eqX eqA leX plusX x0 mof dist}
           {MX : Metric eqX eqX leX plusX x0 mof distX} {Dpd : Density eqX mof}
           {HDD_pre : forall (x : X),leX x0 x -> eqX (distX x0 x) x}
           {HPD : forall (a b c : X),
               eqX (distX (plusX a b) (plusX a c)) (distX b c)}
           {PB : PropBucket}
           (x1 x2 : Cauchilize eqX eqA leX plusX _ _) :
  Cauchilize eqX eqX leX plusX _ _ .
Proof.
  destruct x1. destruct x2.
    assert(CauchySeq eqX eqX (@distseq A X eqX eqA leX plusX x0 mof dist M Cseq Cseq0)).
    apply dist_trans with (HE := HE);auto.
    apply(con_intro
            eqX eqX _ _ _ _
            (@distseq A X eqX eqA leX plusX x0 mof dist M Cseq Cseq0) H1).
Defined.


Require Import UniMath.Foundations.Generalities.uu0.
Require Import UniMath.Foundations.hlevel1.hProp.
Require Import UniMath.Foundations.hlevel2.hSet.

Require Import UniMath.RezkCompletion.precategories.
Require Import UniMath.RezkCompletion.functor_categories.
Require Import SubstSystems.UnicodeNotations.
Require Import UniMath.RezkCompletion.whiskering.
Require Import UniMath.RezkCompletion.Monads.
Require Import SubstSystems.Auxiliary.
Require Import SubstSystems.PointedFunctors.
Require Import SubstSystems.ProductPrecategory.
Require Import SubstSystems.HorizontalComposition.
Require Import SubstSystems.PointedFunctorsComposition.
Require Import SubstSystems.EndofunctorsMonoidal.
Require Import SubstSystems.Signatures.
Require Import SubstSystems.SubstitutionSystems.
Require Import SubstSystems.FunctorAlgebraViews.

Local Notation "# F" := (functor_on_morphisms F)(at level 3).
Local Notation "F ⟶ G" := (nat_trans F G) (at level 39).
Arguments functor_composite {_ _ _} _ _ .
Arguments nat_trans_comp {_ _ _ _ _} _ _ .
Local Notation "G ∙ F" := (functor_composite F G : [ _ , _ , _ ]) (at level 35).
Local Notation "α ∙∙ β" := (hor_comp β α) (at level 20).
Ltac pathvia b := (apply (@pathscomp0 _ _ b _ )).

Local Notation "α 'ø' Z" := (pre_whisker Z α)  (at level 25).
Local Notation "Z ∘ α" := (post_whisker _ _ _ _ α Z) (at level 35).

Section monad_from_hss.

(** ** Some variables and assumptions *)

(** Assume having a precategory [C] whose hom-types are sets *)
Variable C : precategory.
Variable hs : has_homsets C.

Variable H : Signature C hs.

Let θ := theta H.

Let θ_strength1_int := Sig_strength_law1 _ _ H.
Let θ_strength2_int := Sig_strength_law2 _ _ H.

(*
(** [H] is a rank-2 endofunctor on endofunctors *)
Variable H : functor [C, C, hs] [C, C, hs].
*)
(** The forgetful functor from pointed endofunctors to endofunctors *)
Local Notation "'U'" := (functor_ptd_forget C hs).
(** The precategory of pointed endofunctors on [C] *)
Local Notation "'Ptd'" := (precategory_Ptd C hs).
(** The category of endofunctors on [C] *)
Local Notation "'EndC'":= ([C, C, hs]) .
(** The product of two precategories *)
Local Notation "A 'XX' B" := (product_precategory A B) (at level 2).
(** Pre-whiskering defined as morphism part of the functor given by precomposition
    with a fixed functor *)
Local Notation "α 'øø' Z" :=  (# (pre_composition_functor_data _ _ _ hs _  Z) α) (at level 25).

Local Notation "A ⊗ B" := (prodcatpair _ _ A B) (at level 10).
Local Notation "'τ'" := (tau).

(** ** Definition of algebra structure [τ] of a pointed functor *)

(** ** Derivation of the monad laws from a heterogeneous substitution system *)

Section mu_from_fbracket.

(** We assume given a hss [T] *)

Variable T : hss H.

Local Notation "'η'" := (ptd_pt _ (pr1 (pr1 T))).

Coercion ALG_from_hss (T : hss H) : ALG H := pr1 T.

Definition μ_0 : functor_identity C ⟶ pr1 (U T) := η. (*ptd_pt _ (pr1 (pr1 T)).*)

Definition μ_0_ptd : id_Ptd C hs ⇒ T.
Proof.
  exists μ_0.
  intro c. simpl. apply id_left.
Defined.

Definition μ_1 : functor_composite (U (id_Ptd C hs)) (U T) ⟶ pr1 (U T)
  := fbracket _ μ_0_ptd.

Lemma μ_1_identity : μ_1 = identity (U T) .
Proof.
  apply pathsinv0.
  apply fbracket_unique.
  - apply nat_trans_eq; try assumption.
    intros; simpl.
    rewrite id_right.
    apply idpath.
  - apply nat_trans_eq; try assumption.
    intro c. simpl.
    rewrite id_right.
    assert (H':= θ_Strength1_int_implies_θ_Strength1 _ _ _ _ θ_strength1_int).
    red in H'. simpl in H'.
    assert (H2 := H' (U T)).
    assert (H3 := nat_trans_eq_pointwise _ _ _ _ _ _ H2 c).
    simpl in *.
    pathvia (identity _ ;; τ T c).
    + apply cancel_postcomposition. apply H3.
    + apply id_left.
Qed.

Lemma μ_1_identity' : ∀ c : C, μ_1 c = identity _.
Proof.
  intros c.
  assert (HA:= nat_trans_eq_pointwise _ _ _ _ _ _ μ_1_identity).
  apply HA.
Qed.

(* The whole secret is that this typechecks
  Check (μ_1:U T⇒U T).
*)

(* therefore, it is not just the type itself that makes it necessary to introduce μ_1_alt,
   it is rather the question of the formulation of the first strength law of θ *)

(*
Lemma μ_1_identity_stronger : μ_1 = identity (U T).
Proof.
  set (t':=nat_trans_eq_weq C C hs _ _ μ_1 (identity (U T))).
  apply invweq in t'.
  set (t'' := t' μ_1_identity').
  exact t''.
Qed.
*)

(** This is the multiplication of the monad to be constructed *)

Definition μ_2 : functor_composite (U T) (U T) ⟶ pr1 (U T)
  := fbracket T (identity _ ).

Definition functor_with_mu_from_hss : functor_with_μ C.
Proof.
  exists (U T).
  exact μ_2.
Defined.

Definition Monad_data_from_hss : Monad_data C.
Proof.
  exists functor_with_mu_from_hss.
  exact μ_0.
Defined.

(** *** Proof of the first monad law *)

Lemma Monad_law_1_from_hss :
  ∀ c : C, μ_0 (pr1 (U T) c);; μ_2 c = identity ((pr1 (U T)) c).
Proof.
  intro c.
  unfold μ_2. simpl.
  unfold μ_0. simpl.
  set (H':=fbracket_η T (identity _) ).
  set (H2:= nat_trans_eq_weq _ _ hs _ _ _ _ H').
  simpl in H2.
  apply pathsinv0.
  apply H2.
Qed.

(** *** Proof of the second monad law *)

Lemma Monad_law_2_from_hss:
  ∀ c : C, # (pr1 (U T)) (μ_0 c);; μ_2 c = identity ((pr1 (U T)) c).
Proof.
 intro c.
      transitivity (μ_1 c).
      * unfold μ_1.
        set (H':= @fbracket_unique_target_pointwise _ _  _ T).
        set (H1:= H'  _ μ_0_ptd).
        set (x:= post_whisker _ _ _ _ μ_0 (U T)).
        set (x':= x ;; μ_2).
        set (H2 := H1 x').
        apply H2; clear H2.
        unfold x'. clear x'.
        unfold x; clear x.
        clear H1. clear H'. clear c.
        simpl.
        apply nat_trans_eq; simpl.
         apply hs.
         intro c.
         set (H':=nat_trans_ax (ptd_pt _ (pr1 (pr1 T)))).
         simpl in H'.
         rewrite assoc.
         rewrite <- H'; clear H'.
         set (H':= fbracket_η T (identity _ )).
         unfold μ_2.
         set (H2 := nat_trans_eq_weq _ _ hs _ _ _ _ H').
         simpl in H2.
         rewrite <- assoc.
         rewrite <- H2.
         rewrite id_right.
         apply idpath. (* done *)

         unfold x'; clear x'.
         unfold x; clear x.
         clear H1. clear H'.
         set (H':=θ_nat_2 _ _ H θ).
         set (H2 := H' (U T) _ _ μ_0_ptd).
         simpl in H2.
         rewrite functor_comp.
         apply nat_trans_eq; try assumption.
         clear c.
         intro c; simpl.
         set (H3:= nat_trans_eq_weq _ _ hs _ _ _ _ H2 c).
         simpl in H3.
         rewrite id_left in H3.
         rewrite <- horcomp_id_postwhisker.
         repeat rewrite assoc.
         simpl in *.
         transitivity ( # (pr1 (H ( (U T)))) (μ_0 c);; pr1 (θ ((U T) ⊗ T)) c ;;
                           pr1 (# H μ_2) c ;; (τ T) c).
           apply cancel_postcomposition.
           apply cancel_postcomposition.
           apply (!H3). (* done *)

           clear H3 H2 H'.
           set (H':= fbracket_τ T (identity _ )).
           unfold μ_2.
           simpl.
           set (H2:= nat_trans_eq_weq _ _ hs _ _ _ _ H' c).
             clearbody H2.
           simpl in *.
           repeat rewrite <- assoc.
           transitivity (  # (pr1 (H (U T))) (μ_0 c);;
                             (pr1 (τ T) (pr1 (U T) c);; pr1 (fbracket T (identity T)) c)).
             apply maponpaths.
             rewrite assoc.
             apply H2; clear H2. (* rewrite done *)

           clear H2 H'.
           repeat rewrite assoc.
           apply cancel_postcomposition.

           set (H':=nat_trans_ax (τ T) ).
           rewrite H'.
           apply idpath.
    * apply μ_1_identity'.
Qed.

(** [T_squared] is [T∙T, η∙η], that is, the selfcomposition of [T] as a pointed functor *)

Definition T_squared : Ptd.
Proof.
  exact (ptd_composite _ (pr1 (pr1 T)) (pr1 (pr1 T))).
Defined.

(** [μ_2] is not just a natural transformation from [T∙T] to [T], but also compatible with
    the pointed structure given by [η] *)

Lemma μ_2_is_ptd_mor :
  ∀ c : C, (ptd_pt C T_squared) c;; μ_2 c = (ptd_pt C (pr1 (pr1 T))) c.
Proof.
  intro c.
  unfold μ_2.
  unfold T_squared. simpl.
  set (H':=Monad_law_2_from_hss c).
  simpl in H'.
  pathvia (η c ;; identity _ ).
  - repeat rewrite <- assoc.
    apply maponpaths.
    apply H'.
  - apply id_right.
Qed.

Definition μ_2_ptd : T_squared ⇒ T.
Proof.
  exists μ_2.
  unfold is_ptd_mor.
  apply μ_2_is_ptd_mor.
Defined.

Definition μ_3 : U T_squared ∙ U T ⇒ U T := fbracket T μ_2_ptd.

(*
Definition μ_3' := fbracket T μ_2_ptd.
Check μ_3'.
Check (μ_3' = μ_3).
*)

(** *** Proof of the third monad law via transitivity *)
(** We show that both sides are equal to [μ_3 = fbracket μ_2] *)

Lemma μ_3_T_μ_2_μ_2 : μ_3 = (U T) ∘ μ_2 ;; μ_2.
Proof.
  apply pathsinv0.
  set (H1 := fbracket_unique T  μ_2_ptd).
  apply H1; clear H1.
  - apply nat_trans_eq; try assumption.
    intro c; simpl.
    assert (H2 := nat_trans_ax η); simpl in H2.
    rewrite assoc.
    rewrite <- H2.
    assert (H3 := Monad_law_1_from_hss).
    rewrite <- assoc.
    transitivity (μ_2 c ;; identity _ ).
    + rewrite id_right; apply idpath.
    + apply maponpaths.
      apply pathsinv0. apply H3.
  - rewrite functor_comp.
    assert (H1 := θ_nat_2 _ _ H θ (U T) _ _ μ_2_ptd).
    set (H3:=horcomp_id_postwhisker).
    assert (H4 := H3 _ _ _ hs hs _ _ μ_2 (U T)); clear H3.
    simpl in H1.
    repeat rewrite assoc.
    match goal with |[H1 : ?g = _ |- _ ;; _ ;; ?f ;; ?h = _ ] =>
         transitivity (g ;; f ;; h) end.
    + apply cancel_postcomposition.
      apply cancel_postcomposition.
      apply pathsinv0.
      rewrite H1.
      apply maponpaths.
      apply maponpaths.
      apply H4.
    +
      assert (H2 := fbracket_τ T  (identity _ )).
      clear H1 H4.
      apply nat_trans_eq; try assumption.
      intro c; simpl.
      rewrite id_left.
      assert (H3:= nat_trans_eq_pointwise _ _ _ _ _ _ H2 c); clear H2.
      simpl in *.
      match goal with |[H3 : _ = ?f |- ?e ;; _ ;; _ ;; _  = _ ] =>
         transitivity (e ;; f) end.
      * repeat rewrite <- assoc.
        apply maponpaths.
        repeat rewrite <- assoc in H3.
        apply H3.
      * repeat rewrite assoc.
        apply cancel_postcomposition.
        set (H1 := nat_trans_ax (τ T )).
        apply H1.
Qed.

Local Notation "'T∙T²'" := (functor_compose hs hs (functor_composite (U T) (U T)) (U T) : [C, C, hs]).
(*
Definition TtimesTthenT': [C, C] hs := functor_compose hs hs (functor_composite (U T) (U T)) (U T).
*)

Local Notation "'T²∙T'" := (@functor_composite C C C
                    (@functor_composite C C C ((functor_ptd_forget C hs) T)
                                              ((functor_ptd_forget C hs) T))
                    ((functor_ptd_forget C hs) T) : functor C C).
(*
Definition TtimesTthenT: functor C C := @functor_composite C C C
                    (@functor_composite C C C ((functor_ptd_forget C hs) T)
                                              ((functor_ptd_forget C hs) T))
                    ((functor_ptd_forget C hs) T).
*)
Lemma μ_3_μ_2_T_μ_2 :  (
    @compose (functor_precategory C C hs)
                 (* TtimesTthenT *) T²∙T _ _
                 (* (@functor_composite C C C ((functor_ptd_forget C hs) T)
                    ((functor_ptd_forget C hs) T))
                 ((functor_ptd_forget C hs) T) *)
          ((μ_2 øø U T) (* :  TtimesTthenT' ⇒ _ *)
                  (*:@functor_compose C C C hs hs
                    (@functor_composite C C C ((functor_ptd_forget C hs) T)
                                              ((functor_ptd_forget C hs) T))
                    ((functor_ptd_forget C hs) T) ⇒ _*) ) μ_2 :
            (*TtimesTthenT'*) T∙T² ⇒ U T) = μ_3.
  unfold μ_3.
  set (H1 := fbracket_unique (*_pointwise*) T μ_2_ptd).
  apply H1; clear H1.
  - simpl.
    apply nat_trans_eq; try assumption; intro c.
    simpl.
    set (H1 := Monad_law_1_from_hss (pr1 (U T) c)).
    simpl in H1.
    rewrite assoc.
    unfold μ_0 in H1.
    transitivity (identity _ ;; μ_2 c).
    + rewrite id_left; apply idpath.
    + apply cancel_postcomposition.
      apply (!H1).
  -

    set (A:=θ (U T ⊗ T_squared)).
    set (B:= τ T).
    match goal with | [|- _ = ?q] => set (Q:=q) end.
    match goal with | [|- _ ;; # ?H (?f ;; _ ) ;; _ = _ ] => set (F:=f : (*TtimesTthenT'*) T∙T² ⇒ _ ) end.
    set (HX:=θ_nat_1 _ _ H θ _ _ μ_2).  (* it may be tested with the primed version *)
    set (H3:= functor_comp H _ _ _ F μ_2).
    unfold functor_compose in H3.
    match goal with | [ H' : ?f = _ |- _ ] => transitivity (A ;; f ;; B) end.
    + apply idpath.
    + rewrite H3.
      clear H3.
      set (A':= θ ((U T) ⊗ T) øø U T ;; θ ((functor_compose hs hs (U T) (U T)) ⊗ T)).
      simpl in *.

      apply nat_trans_eq; try assumption.
      intro c. simpl.
      unfold A.
      simpl.
      set (A'c := A' c).
      simpl in *.

      clear A Q.
      match goal with | [ |- ?a ;; _ ;; _ = _ ] => set (Ac:= a) end.

      simpl in Ac.
      unfold θ_target_ob in *.
      simpl in *.
      unfold functor_compose in *.
      set (HX1:= HX (pr1 (pr1 T))).
      simpl in HX1.
      assert (HXX:=nat_trans_eq_pointwise _ _ _ _ _ _ HX1 c).
      clear HX1. clear HX.
      simpl in HXX.
      rewrite (functor_id ( H (U T))) in HXX.
      rewrite id_right in HXX. (* last two lines needed because of def. of theta on product category *)
      match goal with |[HXX : ?f ;; ?h = _ ;; _ |- _ ;; (_ ;; ?x ) ;; ?y = _ ] =>
      transitivity (pr1 (θ ((U T) ⊗ T)) (pr1 (pr1 (pr1 T)) c);;
                       f  ;; h ;; x;; y) end.
      * repeat rewrite assoc.
        apply cancel_postcomposition.
        apply cancel_postcomposition.
        unfold Ac.
        simpl.

(*
        unfold F.
        match goal with |[ H : _ = ?b ;; ?c |- _ = ?a ;; _ ;; _  ] =>
             transitivity ( a ;; (b ;; c)) end.
          repeat rewrite <- assoc.

          match goal with |[|- _ ;;  ((# ?H) ?f) _ = _ ] => set (E:=f) end.
*)
          assert (Strength_2 : ∀ α : functor_compose hs hs (functor_composite (U T) (U T))(U T) ⇒ functor_composite (U T) (U T),

                    pr1 (θ (U T ⊗ T_squared)) c ;; pr1 (# H α) c =
                     pr1 (θ ((U T) ⊗ T)) ((pr1 (pr1 (pr1 T))) c);;
                     pr1 (θ ((functor_composite (U T) (U T)) ⊗ (pr1 (pr1 T)))) c;;
                     pr1 (# H (α : functor_compose hs hs (U T) (functor_composite (U T) (U T))⇒ _)) c       ).
             {  intro α.
                assert (HA := θ_Strength2_int_implies_θ_Strength2 _ _ _ _ θ_strength2_int). red in HA. simpl in HA.
                assert (HA':= HA (U T) (pr1 (pr1 T)) (pr1 (pr1 T)) _ α).
                assert (HA2 := nat_trans_eq_pointwise _ _ _ _ _ _  HA' c ).
                simpl in HA2.
                apply HA2.
              }

         (*
         assert (Strength_2' : ∀ α : functor_compose hs hs (functor_composite (U T) (U T))(U T) ⇒ functor_composite (U T) (U T),
                               ∀ β : _ ,
                        α = β →
                    pr1 (θ (U T ⊗ T_squared)) c ;; pr1 (# H α) c =
                     pr1 (θ ((U T) ⊗ T)) ((pr1 (pr1 (pr1 T))) c);;
                     pr1 (θ ((functor_composite (U T) (U T)) ⊗ (pr1 (pr1 T)))) c;;
                     pr1 (# H (β : functor_compose hs hs (U T) (functor_composite (U T) (U T))⇒ _ )) c       ).
             admit. *)
(*
         fold TtimesTthenT' in Strength_2. (*, Strength_2' .*)
*)
         rewrite <- assoc.
         match goal with |[ HXX : ?a ;; ?b = _ |- _ = ?e ;; _] =>
             transitivity (e ;; (a ;; b)) end.
           Focus 2.
             apply idpath.

           rewrite HXX.
           clear HXX.

           rewrite assoc.
           assert (HS :=  Strength_2 F).
           match goal with |[ H : ?a ;; ?b = _ ;; _ ;; _ |- _ ] =>
             transitivity (a ;; b) end.
           apply idpath.
           rewrite HS.
           clear HS.

           repeat rewrite <- assoc.
           apply maponpaths.
           apply maponpaths.

           match goal with |[ |- _ = ?pr1 (# ?G ?g) _ ] =>
              assert (X : F = g) end.
           { apply nat_trans_eq. assumption.
             intros. unfold F.
             simpl.
             rewrite functor_id.
             rewrite id_right.
             apply idpath.
           }
              rewrite X.
              apply idpath.

    * set (H4 := fbracket_τ T  (identity _ )).
      set (H5:= nat_trans_eq_pointwise _ _ _ _ _ _ H4 c).
      simpl in H5.
      unfold μ_2.
      unfold B.
      clearbody H5; clear H4; clear HXX.

      match goal with |[ H5 : _ = ?e |- ?a ;; ?b ;; _ ;; _ ;; _ = _ ] =>
            transitivity (a ;; b ;; e) end.

        repeat rewrite <- assoc.
        apply maponpaths.
        apply maponpaths.
        repeat rewrite assoc; repeat rewrite assoc in H5; apply H5.

        repeat rewrite assoc.
        apply cancel_postcomposition.

        set (HT := fbracket_τ T (identity _ )).
        set (H6:= nat_trans_eq_pointwise _ _ _ _ _ _ HT).
        apply H6.
Qed.

(** proving a variant of the third monad law with assoc iso explicitly inserted *)

Section third_monad_law_with_assoc.

Lemma bla : (U T) ∘ μ_2 ;; μ_2 =
     (α_functor _ _ _ _ : functor_compose hs hs _ _  ⇒ _) ;; (μ_2 øø U T) ;; μ_2.
Proof.
  pathvia μ_3.
  - apply pathsinv0. apply μ_3_T_μ_2_μ_2.
  -  unfold μ_3.
    set (H1 := fbracket_unique (*_pointwise*) T  μ_2_ptd).
    apply pathsinv0.
    apply H1; clear H1.
    + simpl.
      apply nat_trans_eq; try assumption; intro c.
      simpl.
      set (H1 := Monad_law_1_from_hss (pr1 (U T) c)).
      simpl in H1.
      rewrite assoc.
      unfold μ_0 in H1.
      transitivity (identity _ ;; μ_2 c).
      * rewrite id_left; apply idpath.
      * apply cancel_postcomposition.
        rewrite id_left.
        apply (!H1).
    +
      (* unfold θ_Strength2_int in HTT. *)
      rewrite functor_comp.
      rewrite functor_comp.

      rewrite assoc.
      rewrite assoc.
      rewrite assoc.
      rewrite assoc.
      unfold T_squared.
      apply nat_trans_eq; try assumption.
      intro x; simpl.

      assert (HTT := θ_strength2_int).
      assert (HX := HTT (U T) (T) (T)); clear HTT.
      assert (HX':= nat_trans_eq_pointwise _ _ _ _ _ _ HX x); clear HX.
      simpl in HX'.

      match goal with | [ H : _  = ?f |- _ ;; _ ;; ?g ;; ?h ;; ?i = _ ] =>
               pathvia (f ;; g ;; h ;; i) end.
       * apply cancel_postcomposition.
         apply cancel_postcomposition.
         apply cancel_postcomposition.
         apply HX'.
       * clear HX'.
         rewrite id_left.
         rewrite id_right.
         assert (HX:=θ_nat_1 _ _ H θ _ _ μ_2).
         assert (HX1:= HX (pr1 (pr1 T))); clear HX.
         simpl in HX1.
         assert (HXX:=nat_trans_eq_pointwise _ _ _ _ _ _ HX1 x); clear HX1.
         simpl in HXX.
         match goal with | [ H : ?x = _ |- ?e ;; _ ;; _ ;; ?f ;; ?g = _ ] =>
                 pathvia (e ;; x ;; f ;; g) end.
           apply cancel_postcomposition.
           apply cancel_postcomposition.
           repeat rewrite <- assoc.
           apply maponpaths. apply pathsinv0.
           match goal with | [ H : _ = ?x |- _ ] => pathvia x end.
             repeat rewrite assoc.
             repeat rewrite assoc in HXX.
             apply HXX.

             clear HXX.
             apply maponpaths.
             match goal with | [ |- _  ?a ?x = _  ?b ?y ] => assert (TTT : a = b) end.
             match goal with | [ |- _ ?a = _ ?b ] => assert (TTTT : a = b) end.
               apply nat_trans_eq; try assumption.
               intros. simpl. rewrite functor_id. apply id_right.

               rewrite TTTT. apply idpath.

               rewrite TTT. apply idpath.

               clear HXX.

         assert (H4 := fbracket_τ T (identity _ )).
         assert (H5:= nat_trans_eq_pointwise _ _ _ _ _ _ H4 x); clear H4.
         unfold μ_2.
         simpl in H5.
         repeat rewrite assoc.
      match goal with |[ H5 : _ = ?e |- ?a ;; ?b ;; ?c ;; _ ;; _ ;; _ = _ ] =>
            transitivity (a ;; b ;; c;; e) end.

        repeat rewrite <- assoc.
        apply maponpaths.
        apply maponpaths.
        apply maponpaths.
        repeat rewrite <- assoc in H5.
        apply H5.

         rewrite functor_id.
         rewrite id_right.
         assert (H4':= fbracket_τ T (identity _ )).
         assert (H6:= nat_trans_eq_pointwise _ _ _ _ _ _ H4'); clear H4'.
         repeat rewrite assoc.
         apply cancel_postcomposition.
         apply H6.

Qed.

End third_monad_law_with_assoc.

Unset Printing All.
Set Printing Notations.
Unset Printing Implicit.

(** Finally putting together all the preparatory results to obtain a monad *)

Lemma Monad_laws_from_hss : Monad_laws Monad_data_from_hss.
Proof.
  split.
  - unfold Monad_data_from_hss; simpl; split.
    + apply Monad_law_1_from_hss.
    + apply Monad_law_2_from_hss.

  - unfold Monad_data_from_hss; simpl.
    intro c.
    transitivity (pr1 μ_3 c).
    + set (H1 := μ_3_T_μ_2_μ_2).
      set (H2 := nat_trans_eq_weq _ _ hs _ _ _ _ H1).
      apply pathsinv0, H2.
    + set (H1 :=  μ_3_μ_2_T_μ_2).
      set (H2 := nat_trans_eq_weq _ _ hs _ _ _ _ H1).
      apply pathsinv0, H2.
Qed.

Definition Monad_from_hss : Monad C.
Proof.
  exists Monad_data_from_hss.
  exact Monad_laws_from_hss.
Defined.

End mu_from_fbracket.

(** ** A functor from hss to monads *)

(** Objects are considered above, now morphisms *)

Definition Monad_Mor_laws_from_hssMor (T T' : hss H)(β : hssMor T T')
  : Monad_Mor_laws (T:=Monad_from_hss T) (T':=Monad_from_hss T') (#U β).
Proof.
  repeat split; simpl.
  - intro c.
    unfold μ_2. simpl.
    set (H':=isbracketMor_hssMor _ _ _ β).
    unfold isbracketMor in H'.
    set (H2:= H' _ (identity _ )).
    set (H3:=(nat_trans_eq_weq _ _ hs _ _ _ _ H2)).
    rewrite id_left in H3.
    simpl in H3.
    rewrite H3; clear H3 H2 H'.
    rewrite compute_fbracket.
    simpl.
    repeat rewrite assoc.
    apply idpath.
  - unfold μ_0.
    intro c.
    set (H':=ptd_mor_commutes _  (pr1 β)).
    apply H'.
Qed.

Definition Monad_Mor_from_hssMor {T T' : hss H}(β : hssMor T T')
  : Monad_Mor (Monad_from_hss T) (Monad_from_hss T')
  := tpair _ (#U β) (Monad_Mor_laws_from_hssMor T T' β).

Definition hss_to_monad_functor_data : functor_data (hss_precategory H) (precategory_Monad C hs).
Proof.
  exists Monad_from_hss.
  exact @Monad_Mor_from_hssMor.
Defined.

Lemma is_functor_hss_to_monad : is_functor hss_to_monad_functor_data.
Proof.
  split; simpl.
  - intro a.
    apply (invmap (Monad_Mor_equiv hs _ _ )).
    apply idpath.
  - intros a b c f g.
    apply (invmap (Monad_Mor_equiv hs _ _ )).
    apply idpath.
Qed.

Definition hss_to_monad_functor : functor _ _ := tpair _ _ is_functor_hss_to_monad.

Lemma isaset_Monad_Mor (T T' : Monad C) : isaset (Monad_Mor T T').
Proof.
  intros β β'.
  apply (isofhlevelweqb _ (Monad_Mor_equiv hs  _ _)).
  apply isaset_nat_trans.
  apply hs.
Qed.

Definition hssMor_Monad_Mor_eq {T T' : hss H} (β β' : hssMor T T')
  : β = β' ≃ Monad_Mor_from_hssMor β = Monad_Mor_from_hssMor β'.
Proof.
  eapply weqcomp.
  - apply hssMor_eq.
  - apply invweq.
    apply Monad_Mor_equiv.
    apply hs.
Defined.

(** *** The functor from hss to monads is faithful, i.e. forgets at most structure *)

Lemma faithful_hss_to_monad : faithful hss_to_monad_functor.
Proof.
  unfold faithful.
  intros T T'.
  apply isinclbetweensets.
  - apply isaset_hssMor.
  - apply isaset_Monad_Mor.
  - intros β β'.
    apply (invmap (hssMor_Monad_Mor_eq _ _ )).
Qed.

End monad_from_hss.