Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e213m3_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import HoTT.
From GR.bicategories Require Import
     bicategory.bicategory_laws
     lax_functor.lax_functor
     lax_transformation.lax_transformation
     lax_transformation.examples.composition
     modification.modification.

Section AssociativityInverse.
  Context `{Univalence}
          {C D : BiCategory}
          {F₁ F₂ F₃ F₄ : LaxFunctor C D}.
  Variable (η₁ : LaxTransformation F₃ F₄)
           (η₂ : LaxTransformation F₂ F₃)
           (η₃ : LaxTransformation F₁ F₂).

  Local Notation assoc_inv_mod_d
    := (fun (A : C) =>
          assoc_inv (η₁ A) (η₂ A) (η₃ A)
          : compose (compose η₃ η₂) η₁ A ==> compose η₃ (compose η₂ η₁) A).

  Definition assoc_inv_d_is_modification : is_modification assoc_inv_mod_d.
  Proof.
    intros A B f ; cbn in *.
    unfold bc_whisker_l, bc_whisker_r.
    rewrite !vcomp_assoc.
    repeat (rewrite <- (vcomp_left_identity (id₂ (η₁ B)))
            ; rewrite interchange
            ; rewrite vcomp_left_identity).
    rewrite !vcomp_assoc.
    repeat (rewrite <- (vcomp_left_identity (id₂ (η₃ A))) ; rewrite interchange).
    rewrite !vcomp_left_identity.
    rewrite !vcomp_assoc.
    refine (vcomp_move_L_Mp _ _ _ _).
    rewrite <- !vcomp_assoc.
    rewrite inverse_pentagon_4.
    rewrite !vcomp_assoc.
    repeat f_ap.
    rewrite <- !hcomp_id₂.
    rewrite !(ap (fun z => _ ∘ (_ ∘ z)) (vcomp_assoc _ _ _)^).
    rewrite inverse_pentagon_5.
    rewrite !vcomp_assoc.
    rewrite !(ap (fun z => _ ∘ z) (vcomp_assoc _ _ _)^).
    rewrite <- assoc_inv_natural.
    rewrite <- !vcomp_assoc.
    rewrite assoc_left, vcomp_left_identity.
    rewrite !vcomp_assoc.
    repeat f_ap.
    rewrite <- !vcomp_assoc.
    rewrite assoc_natural.
    rewrite !vcomp_assoc.
    f_ap.
    rewrite <- !vcomp_assoc.
    rewrite pentagon_2.
    rewrite !vcomp_assoc.
    repeat f_ap.
    rewrite <- !vcomp_assoc.
    rewrite assoc_natural.
    rewrite !vcomp_assoc.
    f_ap.
    rewrite !(ap (fun z => _ ∘ z) (vcomp_assoc _ _ _)^).
    rewrite <- inverse_pentagon.
    rewrite <- !vcomp_assoc.
    rewrite assoc_left, vcomp_left_identity.
    reflexivity.
  Qed.

  Definition assoc_inv_modification
    : Modification
        (compose (compose η₃ η₂) η₁)
        (compose η₃ (compose η₂ η₁))
    := Build_Modification assoc_inv_mod_d assoc_inv_d_is_modification.

  Definition assoc_inv_modification_is_iso
    : iso_modification assoc_inv_modification.
  Proof.
    intros X ; cbn.
    apply _.
  Qed.

  Definition assoc_inv_mod
    : IsoModification
        (compose (compose η₃ η₂) η₁)
        (compose η₃ (compose η₂ η₁)).
  Proof.
    make_iso_modification.
    - exact assoc_inv_modification.
    - exact assoc_inv_modification_is_iso.
  Defined.
End AssociativityInverse.


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

 Eilenberg-Moore objects in the opposite bicategory

 We show that Eilenberg-Moore objects in the opposite bicategory can be
 constructed from Kleisli objects in the original bicategory.

 ****************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.TransportLaws.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.Examples.OpMorBicat.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.MonadInclusion.
Require Import UniMath.Bicategories.Limits.EilenbergMooreObjects.
Require Import UniMath.Bicategories.Colimits.KleisliObjects.
Require Import UniMath.Bicategories.Monads.Examples.MonadsInOp1Bicat.

Local Open Scope cat.

Section EilenbergMooreOpposite.
  Context {B : bicat}.

  Section Op1Cone.
    Context (m : mnd (op1_bicat B)).

    Let x : B := ob_of_mnd m.
    Let f : x --> x := endo_of_mnd m.
    Let η : id₁ x ==> f := unit_of_mnd m.
    Let μ : f · f ==> f := mult_of_mnd m.

    Section ToKleisliCocone.
      Context (e : em_cone m).

      Let h : B ⟦ ob_of_mnd m , e ⟧ := mor_of_mnd_mor (mor_of_em_cone _ e).
      Let γ : f · h ==> h · id₁ _ := mnd_mor_endo (mor_of_em_cone _ e).
      Let p₁ : rinvunitor h • (_ ◃ id₂ _) = linvunitor h • (η ▹ _) • γ
        := mnd_mor_unit (mor_of_em_cone _ e).
      Let p₂ : rassociator _ _ _
               • (f ◃ γ)
               • lassociator _ _ _
               • (γ ▹ _)
               • rassociator _ _ _
               • (h ◃ runitor _)
               =
               (μ ▹ h) • γ
          := mnd_mor_mu (mor_of_em_cone _ e).

      Definition from_op1_em_cone
        : kleisli_cocone m.
      Proof.
        use make_kleisli_cocone.
        - exact e.
        - exact h.
        - exact (γ • runitor _).
        - abstract
            (cbn ;
             rewrite lwhisker_id2 in p₁ ;
             rewrite id2_right in p₁ ;
             rewrite !vassocr ;
             use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ;
             use vcomp_move_L_pM ; [ is_iso | ] ; cbn ;
             rewrite !vassocr ;
             exact (!p₁)).
        - abstract
            (rewrite !vassocr ;
             refine (_ @ maponpaths (λ z, z • _) p₂) ;
             rewrite !vassocl ;
             apply maponpaths ;
             rewrite !vassocr ;
             apply maponpaths_2 ;
             rewrite <- !lwhisker_vcomp ;
             rewrite !vassocl ;
             apply maponpaths ;
             rewrite runitor_triangle ;
             rewrite vcomp_runitor ;
             rewrite !vassocr ;
             apply maponpaths_2 ;
             rewrite <- runitor_triangle ;
             rewrite !vassocr ;
             rewrite lassociator_rassociator ;
             rewrite id2_left ;
             apply idpath).
      Defined.
    End ToKleisliCocone.

    Definition to_op1_em_cone
               (k : kleisli_cocone m)
      : em_cone m.
    Proof.
      use make_em_cone.
      - exact k.
      - exact (mor_of_kleisli_cocone _ k).
      - exact (cell_of_kleisli_cocone _ k • rinvunitor _).
      - abstract
          (cbn ;
           rewrite !vassocr ;
           refine (!(id2_left _) @ _) ;
           apply maponpaths_2 ;
           rewrite !vassocl ;
           use vcomp_move_L_pM ; [ is_iso | ] ; cbn ;
           rewrite id2_right ;
           rewrite kleisli_cocone_unit ;
           apply idpath).
      - abstract
          (cbn ;
           rewrite <- !lwhisker_vcomp ;
           rewrite !vassocl ;
           rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ;
           rewrite lwhisker_vcomp ;
           rewrite rinvunitor_runitor ;
           rewrite lwhisker_id2 ;
           rewrite id2_left ;
           rewrite !vassocr ;
           apply maponpaths_2 ;
           rewrite kleisli_cocone_mult ;
           apply idpath).
    Defined.

    Section ToEMMore.
      Context (e : em_cone m)
              {k : kleisli_cocone m}
              (g : kleisli_cocone_mor m k (from_op1_em_cone e)).

      Let h : B ⟦ ob_of_mnd m , e ⟧
        := mor_of_mnd_mor (mor_of_em_cone m e).

      Let γ : f · h ==> h · id₁ _
        := mnd_mor_endo (mor_of_em_cone m e).

      Definition to_op1_em_cone_mor_mnd_cell_eq
        : lassociator _ _ _
          • ((cell_of_kleisli_cocone m k • rinvunitor _) ▹ g)
          • rassociator _ _ _
          • (mor_of_kleisli_cocone m k ◃ (lunitor g • rinvunitor g))
          • lassociator _ _ _
          • (cell_of_kleisli_cocone_mor _ g ▹ _)
          =
          (_ ◃ cell_of_kleisli_cocone_mor _ g)
          • γ.
      Proof.
        rewrite <- !rwhisker_vcomp.
        rewrite !vassocl.
        rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)).
        rewrite !rwhisker_hcomp.
        rewrite <- triangle_r_inv.
        rewrite <- !lwhisker_hcomp, <- !rwhisker_hcomp.
        rewrite lwhisker_vcomp.
        rewrite !vassocr.
        rewrite linvunitor_lunitor.
        rewrite id2_left.
        rewrite !vassocl.
        rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)).
        rewrite rinvunitor_triangle.
        rewrite !rwhisker_hcomp.
        rewrite <- rinvunitor_natural.
        rewrite <- rwhisker_hcomp.
        rewrite !vassocr.
        etrans.
        {
          apply maponpaths_2.
          exact (!(kleisli_cocone_mor_endo _ g)).
        }
        rewrite !vassocl.
        etrans.
        {
          apply maponpaths.
          refine (vassocl _ _ _ @ _).
          apply maponpaths.
          cbn.
          apply runitor_rinvunitor.
        }
        rewrite id2_right.
        apply idpath.
      Qed.

      Definition to_op1_em_cone_mor_mnd_cell
        : # (mnd_incl (op1_bicat B)) g · mor_of_em_cone m (to_op1_em_cone k)
          ==>
          mor_of_em_cone m e.
      Proof.
        use make_mnd_cell.
        - exact (cell_of_kleisli_cocone_mor _ g).
        - exact to_op1_em_cone_mor_mnd_cell_eq.
      Defined.

      Definition to_op1_em_cone_mor
        : em_cone_mor
            _
            e
            (to_op1_em_cone k).
      Proof.
        use make_em_cone_mor.
        - exact g.
        - use make_invertible_2cell.
          + exact to_op1_em_cone_mor_mnd_cell.
          + use is_invertible_mnd_2cell.
            exact (cell_of_kleisli_cocone_mor_is_invertible _ g).
      Defined.
    End ToEMMore.

    Definition op1_has_em_ump_1
               (k : kleisli_cocone m)
               (Hk : has_kleisli_ump_1 _ k)
      : em_ump_1 m (to_op1_em_cone k).
    Proof.
      intro e.
      use to_op1_em_cone_mor.
      exact (Hk (from_op1_em_cone e)).
    Defined.

    Section UMP2.
      Context (k : kleisli_cocone m)
              (Hk : has_kleisli_ump_2 _ k)
              {z : B}
              {g₁ g₂ : k --> z}
              (α : # (mnd_incl (op1_bicat B)) g₁ · mor_of_em_cone m (to_op1_em_cone k)
                   ==>
                   # (mnd_incl (op1_bicat B)) g₂ · mor_of_em_cone m (to_op1_em_cone k)).

      Let αcell : mor_of_kleisli_cocone m k · g₁ ==> mor_of_kleisli_cocone m k · g₂
          := cell_of_mnd_cell α.

      Let p : lassociator _ _ _
              • ((cell_of_kleisli_cocone m k • rinvunitor _) ▹ g₁)
              • rassociator _ _ _
              • (_ ◃ (lunitor _ • rinvunitor _))
              • lassociator _ _ _
              • (αcell ▹ _)
              =
              (_ ◃ αcell)
              • (lassociator _ _ _
                 • ((cell_of_kleisli_cocone m k • rinvunitor _) ▹ _)
                 • rassociator _ _ _
                 • (_ ◃ (lunitor _ • rinvunitor _))
                 • lassociator _ _ _)
          := mnd_cell_endo α.

      Local Lemma op1_has_em_ump_2_help_eq
        : lassociator _ _ _ • (cell_of_kleisli_cocone m k ▹ g₁) • αcell
          =
          (_ ◃ αcell) • lassociator _ _ _ • (cell_of_kleisli_cocone m k ▹ g₂).
      Proof.
        rewrite <- !lwhisker_vcomp in p.
        rewrite <- !rwhisker_vcomp in p.
        rewrite !vassocl in p.
        rewrite !(maponpaths (λ z, _ • (_ • (_ • z))) (vassocr _ _ _)) in p.
        rewrite lunitor_lwhisker in p.
        rewrite !vassocl in p.
        rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) in p.
        rewrite rwhisker_vcomp in p.
        rewrite rinvunitor_runitor in p.
        rewrite id2_rwhisker in p.
        rewrite id2_left in p.
        rewrite !vassocl in p.
        rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) in p.
        rewrite rinvunitor_triangle in p.
        rewrite !vassocl in p.
        rewrite !rwhisker_hcomp in p.
        rewrite <- rinvunitor_natural in p.
        rewrite <- !rwhisker_hcomp in p.
        rewrite !(maponpaths (λ z, _ • (_ • (_ • z))) (vassocr _ _ _)) in p.
        rewrite !rwhisker_hcomp in p.
        rewrite <- triangle_l_inv in p.
        rewrite <- !lwhisker_hcomp, <- !rwhisker_hcomp in p.
        rewrite !vassocl in p.
        rewrite !(maponpaths (λ z, _ • (_ • (_ • (_ • z)))) (vassocr _ _ _)) in p.
        rewrite lassociator_rassociator in p.
        rewrite id2_left in p.
        rewrite !vassocl in p.
        rewrite !(maponpaths (λ z, _ • (_ • (_ • z))) (vassocr _ _ _)) in p.
        rewrite lwhisker_vcomp in p.
        rewrite linvunitor_lunitor in p.
        rewrite lwhisker_id2 in p.
        rewrite id2_left in p.
        rewrite rinvunitor_triangle in p.
        use (vcomp_rcancel (rinvunitor _)) ; [ is_iso | ].
        rewrite !vassocl.
        exact p.
      Qed.

      Definition op1_has_em_ump_2_unique
        : isaprop
            (∑ (β : g₁ ==> g₂), ## (mnd_incl (op1_bicat B)) β ▹ _ = α).
      Proof.
        use invproofirrelevance.
        intros β₁ β₂.
        use subtypePath ; [ intro ; apply cellset_property | ].
        use (maponpaths
               pr1
               (proofirrelevance
                  _
                  (isapropifcontr (Hk z g₁ g₂ αcell _))
                  (pr1 β₁ ,, _)
                  (pr1 β₂ ,, _))).
        - exact op1_has_em_ump_2_help_eq.
        - exact (maponpaths pr1 (pr2 β₁)).
        - exact (maponpaths pr1 (pr2 β₂)).
      Qed.

      Definition op1_has_em_ump_2_cell
        : g₁ ==> g₂
        := pr11 (Hk z g₁ g₂ αcell op1_has_em_ump_2_help_eq).

      Definition op1_has_em_ump_2_eq
        : ## (mnd_incl (op1_bicat B)) op1_has_em_ump_2_cell ▹ _ = α.
      Proof.
        use eq_mnd_cell.
        exact (pr21 (Hk z g₁ g₂ αcell op1_has_em_ump_2_help_eq)).
      Qed.
    End UMP2.

    Definition op1_has_em_ump_2
               (k : kleisli_cocone m)
               (Hk : has_kleisli_ump_2 _ k)
      : em_ump_2 m (to_op1_em_cone k).
    Proof.
      intros z g₁ g₂ α.
      use iscontraprop1.
      - exact (op1_has_em_ump_2_unique k Hk α).
      - simple refine (_ ,, _).
        + exact (op1_has_em_ump_2_cell k Hk α).
        + exact (op1_has_em_ump_2_eq k Hk α).
    Defined.
  End Op1Cone.

  Definition op1_has_em
             (HB : has_kleisli B)
    : bicat_has_em (op1_bicat B).
  Proof.
    intro m.
    pose (HB m) as q.
    refine (to_op1_em_cone m (pr1 q) ,, _ ,, _).
    - apply op1_has_em_ump_1.
      exact (pr12 q).
    - apply op1_has_em_ump_2.
      exact (pr22 q).
  Defined.
End EilenbergMooreOpposite.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e266m3_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Set Primitive Projections.

Record foo := Foo {
  foo_car : Type;
  foo_rel : foo_car -> foo_car -> Prop
}.
Arguments foo_rel : simpl never.

Definition foo_fun {A B} := Foo (A -> B) (fun f g => forall x, f x = g x).

Goal @foo_rel foo_fun (fun x : nat => x) (fun x => x).
Proof.
intros x; exact eq_refl.
Undo.
progress hnf; intros; exact eq_refl.
Undo.
unfold foo_rel. intros x. exact eq_refl.
Qed.


Require Export sequences_LS.
Require Export ZArith_dec.
Require Export Recdef.

Module lub_proof_LS.

Module Export UU := seq_LS.

Import LSw.

Definition max_natlist (l:list nat) := fold_right Max.max 0%nat l.

Lemma max_natlist_biggest : forall u l , In u l -> u<= max_natlist l.
Proof.
induction l.
intros HH; inversion HH.
intros HH; destruct HH.
intros; subst.
simpl.
apply Max.le_max_l.
simpl.
apply Coq.Arith.Le.le_trans with (max_natlist l).
apply IHl; assumption.
apply Max.le_max_r.
Qed.

(*
Definition mk_list (a:A) : lim a /\ (0<=A a) -> list A.
intros.
apply (nat_like_induction (fun (_:A) => list A)) with (n:=a).
exact (cons a0 nil).
intros n Hn rec.
exact (cons (n+1) rec).
assumption.
Defined.

Lemma mk_r1 : forall (H:lim a0/\0<=A a0), mk_list (a0) H = cons a0 nil.
intros.
unfold mk_list.
rewrite (nat_like_induction_r1).
reflexivity.
Qed.

Lemma mk_r2 : forall n, forall (H:lim n/\0<=A n), forall (H':lim (n+1)/\0<=A (n+1)),
mk_list (n+1) H' = (n+1)::mk_list n H.
Proof.
intros.
unfold mk_list.
rewrite nat_like_induction_r2 with (H:=H).
reflexivity.
Qed.
*)

Definition steps : forall X Y:A->Prop, (forall k:A,  X k -> Y k) ->  list {k:A| X k} ->  list {k:A| Y k}.
intros X Y HXY l.
eapply (@map ( {k : A | X k})).
intros p(*; destruct p as [x Hx]*).
exists (proj1_sig p).
apply HXY.
clear l HXY Y; abstract (destruct p; assumption).
exact l.
Defined.

(*
Definition mk_list2 (a:A) : lim a /\ (0<=A a) -> list {k : A | (lim k /\ 0 <=A k) /\ k <=A (a + 1)}.
intros.
apply (nat_like_induction (fun (a:A) => list {k : A | (lim k /\ 0 <=A k) /\ k <=A (a + 1)})) with (n:=a).
refine (cons _ nil).
exists a0.
split.
split.
apply lim0.
apply le_refl.
setoid_replace 0 with (0+0) at 1 by ring.
apply le_plus.
apply le_refl.
apply lt_le; apply lt_0_1.

intros n Hn rec.
assert (rec':list {k : A | (lim k /\ 0 <=A k) /\ k <=A (n + 1+1)}).
apply steps with (X:=(fun k => (lim k /\ 0 <=A k) /\ k <=A (n + 1)))
(Y:= fun k => (lim k /\ 0 <=A k) /\ k <=A (n + 1 + 1)).
intros k (Ha1,Ha2).
split.
assumption.
setoid_replace k with (k+0) by ring.
apply le_plus.
assumption.
apply lt_le; apply lt_0_1.
exact rec.

refine (cons _ rec').
exists (n+1).
split.
split.
apply ANS2a.
intuition.
apply ANS1.
setoid_replace 0 with (0+0) by ring.
apply le_plus.
intuition.
apply lt_le; apply lt_0_1.
setoid_replace (n+1) with ((n+1)+0) at 1 by ring.
apply le_plus.
apply le_refl.
apply lt_le; apply lt_0_1.
assumption.
Qed.
*)

Lemma mk_list2_aux1 : forall n k : A, (std k /\ 0 <=A k) /\ k <=A n -> (std k /\ 0 <=A k) /\ k <=A (n + 1).
Proof.
intros n k (Ha1,Ha2).
split ; [ assumption |
setoid_replace k with (k+0) by ring;
apply le_plus; [
assumption |
apply lt_le; apply lt_0_1]].
Qed.

Lemma mk_list2_aux2 : forall n, (std n /\ 0<=A n) -> (std (n + 1) /\ 0 <=A (n + 1)) /\ (n + 1) <=A (n + 1).
Proof.
intros n Hn.
abstract (repeat split;
[apply ANS2a'; try apply ANS1'; solve[intuition]
| setoid_replace 0 with (0+0) by ring; apply le_plus; (solve [intuition] || apply lt_le; apply lt_0_1)
|apply le_refl
]).
Qed.

Definition mk_list2' (a:A) : std a /\ (0<=A a) -> list {k : A | (std k /\ 0 <=A k) /\ k <=A (a)}.
(* builds the list [0 ..i .. a ] with each time a proof of lim i /\ 0<=A i /\ i <=A a *)
intros.
apply (nat_like_induction (fun (a:A) => list {k : A | (std k /\ 0 <=A k) /\ k <=A a })) with (n:=a).
refine (cons _ nil).
exists a0.
 (repeat split; apply std0 || apply le_refl).

intros n Hn rec.
apply cons.

exists (n+1).
apply (mk_list2_aux2 n Hn).

apply steps with (X:=(fun k => (std k /\ 0 <=A k) /\ k <=A n ))
(Y:= fun k => (std k /\ 0 <=A k) /\ k <=A (n + 1)).
apply mk_list2_aux1.
exact rec.

assumption.
Defined.

(*
Lemma mk_list2_prop :
  forall n, forall Hn:  lim n/\0<=A n, forall p,  In p  (mk_list2' n Hn) -> 0 <=A (proj1_sig p) /\ (proj1_sig p) <=A n.
Proof.
intros n Hn p.
assert (Hn': lim n /\ 0 <=A n).
assumption.
revert p Hn.
apply (nat_like_induction (fun (n:A) => forall (p: {k : A | (lim k /\ 0 <=A k) /\ k <=A n}), forall (Hn:lim n/\0<=A n), In p (mk_list2' n Hn) -> 0 <=A proj1_sig p /\ proj1_sig p <=A n)).
intros p Hn.
unfold mk_list2'.
rewrite nat_like_induction_r1.
simpl; intros Hp.
destruct Hp as [Hp | Hf].
subst; simpl.
split; apply le_refl.
destruct Hf.
intros p Hp HRp X Hp1.
unfold mk_list2'; rewrite nat_like_induction_r2  with (H:=Hp).
simpl; intros.
destruct H as [HA | HB].
subst; simpl.
split; [solve [intuition] | apply le_refl].
apply HRp.
des
simpl.
simpl.

*)

(** seq_of_Ms ssA bbA (n+1) produces the sequences M_{n+1}^0 to M_{n+1}^{n+1} *)

Definition seq_of_Ms : forall
(ssA:forall k0 : A, std k0 /\ 0 <=A k0 -> A)
(bbA:forall k0 : A, std k0 /\ 0 <=A k0 -> A)
(n : A)
(Hn : std n  /\ 0 <=A n)
(*(Hn1: lim (n+1) /\ 0<=A (n+1))*)
(Mn1
    : forall (k : A) (Hk : std k /\ 0 <=A k),
      k <=A (n) -> {N : nat | forall m : nat, m >= N -> (ssA n Hn m < bbA k Hk m)%Z}),
list nat.
Proof.
intros ssA bbA n Hn (*Hn1*) Mn1.
apply (@map {k : A | (std k /\ 0 <=A k) /\ k <=A (n)} nat).
intros K.
case K; intros k Hk.
case Hk; intros Hk1 Hk2.
Check (Mn1 k Hk1 Hk2) .
exact (proj1_sig (Mn1 k Hk1 Hk2)).
apply mk_list2'.
assumption.
Defined.

Definition nat2A : nat -> {n:A | std n /\ 0<=A n}.
Proof.
fix nat2A 1.
intros n; case n.
exists a0.
clear nat2A n; abstract (split; [apply std0 | apply le_refl]).
intros p.
case (nat2A p).
intros xp Hxp.
exists (xp+a1).
clear nat2A n p;
abstract (split; [apply ANS2a'; [intuition | apply ANS1']| setoid_replace 0 with (0+0) by ring; apply le_plus; [intuition| apply lt_le;apply lt_0_1]]).
Defined.

(* adapting power_lim to take into account (k+1) when computing b^n - s^n *)

Axiom power_lim2
     : forall x : HRw,
       x [>] [0] ->
       [1] [>] x ->
       forall a : HRw,
       a [>] [0] ->
       forall eps : HRw,
       eps [>] [0] -> exists n : A, std n /\ 0 <=A n /\ (forall H : std n /\ 0 <=A n, eps [>] (a [*] ((mk_HRw n H)[+] [1]) [*] power x n H)).

Lemma std_n_n1
     : forall n : A,
       std n /\ 0 <=A n ->
       std (n + 1) /\ 0 <=A (n + 1).
Proof.
intros n Hn.
split.
apply ANS2a'.
apply Hn.
apply ANS1'.
setoid_replace 0 with (0+0) by ring.
apply le_plus.
apply Hn.
apply lt_le; apply lt_0_1.
Qed.

Definition def_bigM : forall
(ssA : forall k0 : A, std k0 /\ 0 <=A k0 -> A)
(bbA : forall k0 : A, std k0 /\ 0 <=A k0 -> A)
(M : forall (n : A) (Hn : std n /\ 0 <=A n) (k : A) (Hk : std k /\ 0 <=A k),
    k <=A n -> {N : nat | forall m : nat, m >= N -> (ssA n Hn m < bbA k Hk m)%Z}),
{n:A| std n /\ 0<=A n} ->  nat.
intros ssA bbA M.
intros (n, Hn).
apply (nat_like_induction (fun (_:A) =>  nat)) with (n:=n).
pose (H:= (M 0 (conj std0 (le_refl 0)) 0 (conj std0 (le_refl 0)) (le_refl 0))).
exact (proj1_sig H).
intros p Hp bigM_p.

(* seq_of_Ms builds the list [ M_{p+1}^{0} .. M_{p+1}^{p+1} *)
(* bigM_p, to which we add + 1 *)
exact (Max.max (bigM_p+1)%nat (max_natlist ( seq_of_Ms ssA bbA (p+1) (std_n_n1 p Hp) (M (p+1) (std_n_n1 p Hp))))).
assumption.
Defined.

Definition pack : forall n, forall Hn : std n /\ 0<=A n, {n| std n /\ 0<=A n}.
intros n Hn.
exists n.
assumption.
Defined.

Lemma bigM_fst_is_OK :
forall
(ssA : forall k0 : A, std k0 /\ 0 <=A k0 -> A)
(bbA : forall k0 : A, std k0 /\ 0 <=A k0 -> A)
(M : forall (n : A) (Hn : std n /\ 0 <=A n) (k : A) (Hk : std k /\ 0 <=A k),
    k <=A n -> {N : nat | forall m : nat, m >= N -> (ssA n Hn m < bbA k Hk m)%Z})
(n : A)
(Hn:std n /\ 0<=A n)
(Hn':std n/\0<=A n)
(p: A)
(Hp : std p/\0<=A p)
(p':A)
(Hp':std p'/\0<=A p')
(Hle: p<=A n)
(Hle':p'<=A n)
(Heq:p=A p'),
proj1_sig (M n Hn p Hp Hle) = proj1_sig (M n Hn' p' Hp' Hle').
Proof.
Admitted. (* proof irrelevance and dependent rewriting *)

(*
Lemma In_transp :
forall
(ssA : forall k0 : A, lim k0 /\ 0 <=A k0 -> A)
(bbA : forall k0 : A, lim k0 /\ 0 <=A k0 -> A)
(M : forall (n : A) (Hn : lim n /\ 0 <=A n) (k : A) (Hk : lim k /\ 0 <=A k),
    k <=A n -> {N : nat | forall m : nat, m >= N -> (ssA n Hn m < bbA k Hk m)%Z})
(n : A)
(Hn:lim n /\ 0<=A n)
(p :  {k : A | (lim k /\ 0 <=A k) /\ k <=A n}),
In p (mk_list2' n Hn) -> {k:A | In (M n Hn k Hk) (seq_of_Ms ssA bbA n Hn (M n Hn))}.
*)

Lemma bigM_bigger : forall
(ssA : forall k0 : A, std k0 /\ 0 <=A k0 -> A)
(bbA : forall k0 : A, std k0 /\ 0 <=A k0 -> A)
(M : forall (n : A) (Hn : std n /\ 0 <=A n) (k : A) (Hk : std k /\ 0 <=A k),
    k <=A n -> {N : nat | forall m : nat, m >= N -> (ssA n Hn m < bbA k Hk m)%Z})
(n : A)
(Hn:std n /\ 0<=A n)
(p: A)
(Hp : std p/\0<=A p)
(Hle: p<=A n),
  proj1_sig (M n Hn p Hp Hle) <= def_bigM ssA bbA M (pack n Hn).
Proof.
Admitted.

(*
intros ssA bbA M n Hn p Hp Hle.
revert Hn Hle.
unfold def_bigM.
intros Hn Hle.
assert (Hn2: lim n /\ 0 <=A n).
assumption.
revert Hn Hle.
apply (nat_like_induction (fun (n:A) => forall (Hn : lim n /\ 0 <=A n) (Hle : p <=A n),def_bigM ssA bbA M (pack n Hn) >= proj1_sig (M n Hn p Hp Hle))).
intros.
unfold pack, def_bigM.
rewrite nat_like_induction_r1.
assert (Heq:0=Ap).
apply le_id; solve[intuition].
rewrite <- (bigM_fst_is_OK ssA bbA M 0 (conj lim0 (le_refl 0)) Hn 0 (conj lim0 (le_refl 0)) p Hp (le_refl 0) Hle Heq).
omega.

intros m Hm Hn' Hle' Hle''.
unfold pack, def_bigM.
rewrite nat_like_induction_r2 with (H:=Hm).
assert (Hab:forall a b, a<=b -> b>=a) by (intros;omega).
apply Hab.

apply Le.le_trans with (max_natlist (seq_of_Ms ssA bbA (plusA m a1) (lim_n_n1 m Hm) (M (plusA m a1) (lim_n_n1 m Hm))))%nat.
apply max_natlist_biggest.
unfold seq_of_Ms.
unfold mk_list2'.
apply Max.le_max_r.
assumption.
Qed.
Show 2.
2:symmetry;eassumption.
revert Hle Hn.

Check (bigM_fst_is_OK ssA bbA M 0 (conj lim0 (le_refl 0))). Hn 0 (conj lim0 (le_refl 0)) Hp). with (Hn':=Hn) (Hp':= Hp) (Hle':=Hle).
assert (Heq:p=A 0).
apply le_id; solve[intuition].
setoid_rewrite Heq.

se
rewrite <- (proof_irr _ Hn (conj lim0 (le_refl 0))).
rewrite
destruct (M 0 (conj lim0 (le_refl 0)) 0 (conj lim0 (le_refl 0)) (le_refl 0)).
destruct (M 0 Hn p Hp Hle).
simpl.
destruct (M 0 (conj lim0 (le_refl 0)) 0
         (conj lim0 (le_refl 0))
         (le_refl 0)).
simpl.
rewrite nat_like_induction_r1.
unfold def_bigM.
*)

Lemma bigM_increases_step : forall
(ssA : forall k0 : A, std k0 /\ 0 <=A k0 -> A)
(bbA : forall k0 : A, std k0 /\ 0 <=A k0 -> A)
(M : forall (n : A) (Hn : std n /\ 0 <=A n) (k : A) (Hk : std k /\ 0 <=A k),
    k <=A n -> {N : nat | forall m : nat, m >= N -> (ssA n Hn m < bbA k Hk m)%Z})
(n : A)
(Hn:std n /\ 0<=A n)
(Hn1 : std (n+1)/\0<=A (n+1)),
  def_bigM ssA bbA M (pack n Hn) < def_bigM ssA bbA M (pack (n+1) Hn1).
Proof.
intros.
simpl.
rewrite (nat_like_induction_r2) with(H:=Hn).

change (
def_bigM ssA bbA M (pack n Hn) <
Max.max
  (nat_like_induction (fun _ : A => nat)
     (let (M0, _) := M 0 (conj std0 (le_refl 0)) 0 (conj std0 (le_refl 0)) (le_refl 0) in M0)
     (fun (p : A) (Hp : std p /\ 0 <=A p) (bigM_p : nat) =>
      Max.max (bigM_p + 1) (max_natlist (seq_of_Ms ssA bbA (p + 1) (std_n_n1 p Hp) (M (p + 1) (std_n_n1 p Hp))))) n
     Hn + 1) (max_natlist (seq_of_Ms ssA bbA (n + 1) (std_n_n1 n Hn) (M (n + 1) (std_n_n1 n Hn))))).
change (
def_bigM ssA bbA M (pack n Hn) <
Max.max (def_bigM ssA bbA M (pack n Hn)+1) (max_natlist (seq_of_Ms ssA bbA (n + 1) (std_n_n1 n Hn) (M (n + 1) (std_n_n1 n Hn))))).
apply Coq.Arith.Lt.lt_le_trans with (def_bigM ssA bbA M (pack n Hn) + 1)%nat.
omega.
apply Max.le_max_l.
Qed.

Lemma bigM_increases : forall
(ssA : forall k0 : A, std k0 /\ 0 <=A k0 -> A)
(bbA : forall k0 : A, std k0 /\ 0 <=A k0 -> A)
(M : forall (n : A) (Hn : std n /\ 0 <=A n) (k : A) (Hk : std k /\ 0 <=A k),
    k <=A n -> {N : nat | forall m : nat, m >= N -> (ssA n Hn m < bbA k Hk m)%Z}),
(forall x y : {n : A | std n /\ 0 <=A n},
  proj1_sig x <A proj1_sig y -> def_bigM ssA bbA M x < def_bigM ssA bbA M y).
Proof.
Admitted. (* bigM_increases *)

Lemma bigM_increases2 : forall
(ssA : forall k0 : A, std k0 /\ 0 <=A k0 -> A)
(bbA : forall k0 : A, std k0 /\ 0 <=A k0 -> A)
(M : forall (n : A) (Hn : std n /\ 0 <=A n) (k : A) (Hk : std k /\ 0 <=A k),
    k <=A n -> {N : nat | forall m : nat, m >= N -> (ssA n Hn m < bbA k Hk m)%Z}),
(forall x y : {n : A | std n /\ 0 <=A n},
  proj1_sig x <=A proj1_sig y -> def_bigM ssA bbA M x <= def_bigM ssA bbA M y).
Proof.
Admitted. (* bigM_increases2 *)

Lemma lt_le_dec : forall n m : nat, {n < m} + {m <= n}.
Proof.
intros.
destruct (lt_dec n m).
left; omega.
right; omega.
Qed.

Lemma nat2A_1 : forall i, (proj1_sig (nat2A i) <A proj1_sig (nat2A (i + 1))).
Proof.
intros.
setoid_replace (i+1)%nat with (S i)%nat by ring.
induction i.
simpl.
setoid_replace 0 with (0+0) at 1 by ring.
apply le_lt_plus.
apply le_refl.
apply lt_0_1.
simpl.
destruct (nat2A i).
simpl.
setoid_replace (x+1) with (x+1+0) at 1 by ring.
apply le_lt_plus.
apply le_refl.
apply lt_0_1.
Qed.

Section def_rec.
Variable u: {n : A | std n /\ 0 <=A n} -> nat.
Variable u_increases : (forall (x y : {n : A | std n /\ 0 <=A n}), (proj1_sig x) <A (proj1_sig y) -> u x < u y).

Definition my_measure (mi:nat*nat) : nat := (fst mi)-(u (nat2A (snd mi))).

(*
Function computation (mi:nat*nat) {measure my_measure} : nat :=
match mi with (m,i) =>
if (lt_dec m (u (nat2A (i+1)))) then i else computation (m,(i+1)%nat) end.
intros.
unfold my_measure, my_measure'.
assert (u (nat2A (i + 1)) > u (nat2A i)) by (apply u_increases;apply nat2A_1).
abstract omega.
Defined.
*)
Function computation2 (mi:nat*nat) (carryH:u (nat2A (snd mi)) <=(fst mi)) {measure my_measure mi} :
  {n : nat | u (nat2A n) <= (fst mi) < u (nat2A (n + 1)%nat)} :=
match  (lt_le_dec (fst mi) (u (nat2A ((snd mi)+1)))) with
 | left Hl =>  exist (fun (n:nat) => u (nat2A n) <=fst mi< u (nat2A (n+1)%nat)) (snd mi) (conj carryH Hl)
 | right Hr => computation2 ((fst mi),((snd mi)+1)%nat) Hr
end.
intros.
unfold my_measure; simpl in *.

assert (u (nat2A ((snd mi) + 1)) > u (nat2A (snd mi))) by (apply u_increases;apply nat2A_1).
abstract omega.
Defined.

End def_rec.

Definition hyp2: (* how to decompose the natural numbers to build the function tau *)
       forall (m : nat) (u : {n : A | std n /\ 0 <=A n} -> nat),
       (forall (x y : {n : A | std n /\ 0 <=A n}), (proj1_sig x) <A (proj1_sig y) -> u x < u y) ->
       {n : nat | u (nat2A n) <= m < u (nat2A (n + 1)%nat)} + {m < u (nat2A 0)%nat}.
Proof.
intros m u Hu.
case (lt_le_dec m (u (nat2A 0)%nat)).
right.
exact l.
left.
change (u (nat2A 0) <= fst (m, 1)) in l.
exact (computation2 u Hu (m,0%nat) l).
Defined.

Definition def_tau : forall
(ssA : forall k0 : A, std k0 /\ 0 <=A k0 -> A)
(bbA : forall k0 : A, std k0 /\ 0 <=A k0 -> A)
(M : forall (n : A) (Hn : std n /\ 0 <=A n) (k : A) (Hk : std k /\ 0 <=A k),
    k <=A n -> {N : nat | forall m : nat, m >= N -> (ssA n Hn m < bbA k Hk m)%Z}),
nat -> Z.
Proof.
intros ssA bbA M m.
(*assert (Hprop:(forall x y : {n : A | lim n /\ 0 <=A n},
  proj1_sig x <=A proj1_sig y -> def_bigM ssA bbA M x < def_bigM ssA bbA M y))
  by apply bigM_increases. (* bigM strictly increasing ... *) *)
case (hyp2 m (def_bigM ssA bbA M) (bigM_increases ssA bbA M)).
intros (x, Hx).
exact (ssA (proj1_sig (nat2A x)) (proj2_sig (nat2A x)) m).
intros; exact 0%Z.
Defined.

Lemma sub_lemma1 : (forall x y z:Z, x<=z -> z<= y -> (Z.abs z)<=(Z.abs y) \/ (Z.abs z) <= (Z.abs x))%Z.
Proof.
intros x y z Hxz Hyz.
destruct (Z_le_gt_dec z 0).
destruct (Z_le_gt_dec x 0).
rewrite (Z.abs_neq z).
rewrite (Z.abs_neq x).
right; omega.
omega.
omega.
destruct (Z_le_gt_dec y 0).
rewrite (Z.abs_neq z).
rewrite (Z.abs_neq y).
left; omega.
omega.
omega.
assert False by omega.
omega.

destruct (Z_le_gt_dec x 0).
destruct (Z_le_gt_dec y 0).

assert False by omega.
omega.
rewrite (Z.abs_eq z).
rewrite (Z.abs_eq y).
left; omega.
omega.
omega.
destruct (Z_le_gt_dec y 0).
assert False by omega.
omega.
rewrite (Z.abs_eq z).
rewrite (Z.abs_eq y).
left; omega.
omega.
omega.
Qed.

Lemma sub_lemma2 : (forall x y z:Z, x<=z -> z<= y -> Z.abs z <= (Z.abs y)+(Z.abs x))%Z.
Proof.
intros.
destruct (sub_lemma1 x y z H H0).
generalize (Z.abs_nonneg x); intros Hnew.
omega.
generalize (Z.abs_nonneg y); intros Hnew.
omega.
Qed.

Lemma lemma1 : forall x y z, x<=A z -> z<=A y -> |z|<=A |y|+|x|.
Proof.
unfold_intros.
destruct_exists.
exists (H+H0+1)%nat.
intros.
apply sub_lemma2.
apply H2; omega.
apply H1; omega.
Qed.

Lemma between_is_P :
forall x y :A, P x -> P y -> forall z, x<=A z -> z<=A y -> P z.
Proof.
intros x y Hx Hy z Hxz Hzy; unfold P in *.
assert (|z|<=A |x|+|y|).
rewrite plus_comm.
(apply lemma1; assumption).
destruct Hx as [nx [Hnx1 [Hnx2 Hnx]]].
destruct Hy as [ny [Hny1 [Hny2 Hny]]].
exists (nx+ny).
split.
apply ANS2a; assumption.
split.
setoid_replace 0 with (0+0) by ring.
apply lt_plus; assumption.
eapply le_trans.
apply H.
ring_simplify.
apply le_plus; assumption.
Qed.

Lemma A_is_nat :
forall a:A, std a /\ 0<=A a -> exists n:nat, a=proj1_sig (nat2A n).
Proof.
intros.
apply (nat_like_induction (fun (a:A) => exists n : nat, a = proj1_sig (nat2A n))).
exists 0%nat.
simpl; reflexivity.
intros n Hn Hex.
destruct Hex as [p Hp].
exists (S p)%nat.
simpl.
destruct (nat2A p) as [x Hx].
simpl in *.
now apply f_equal2.
assumption.
Qed.

Lemma proj_nat2A : forall p q, proj1_sig (nat2A p) <=A proj1_sig (nat2A (p+q)).
Proof.
induction q.
replace (p+0)%nat with p by ring.
apply le_refl.
rewrite <- plus_n_Sm.
replace (S (p+q))%nat with ((p+q)+1)%nat by ring.
eapply le_trans.
eassumption.
apply lt_le; apply nat2A_1.
Qed.

Lemma proj_nat2A' : forall p q, p<= q -> proj1_sig (nat2A p) <=A proj1_sig (nat2A q).
Proof.
intros p q Hpq.
destruct (PeanoNat.Nat.le_exists_sub p q Hpq) as [v [Hv1 Hv2]].
subst.
rewrite Plus.plus_comm.
apply proj_nat2A.
Qed.

(*Lemma P_dec : forall P:nat -> Prop, (exists N : nat,P N) -> {N:nat | P N}.
Proof.
intros.
Search nat.
destruct H.
*)

Lemma least_upper_bound_principle :
  forall S:subset, non_empty S -> bound_above S ->
    (forall alpha beta a b:HRw, upper_bound S beta /\ S alpha /\ (beta [>=] b /\ b [>=] a /\ a [>=] alpha) ->
       {s:HRw| S s /\ s [>] a}+{upper_bound S b}) ->
 has_least_upper_bound_weak S.
Proof.
intros S Hnon_empty Hbound Hdec.
elim Hnon_empty; intros s0 Hs0.
elim Hbound; intros b0 Hb0.

pose (s_b := (def_s_b S Hdec s0 b0 Hs0 Hb0)).
(* avec valeurs dans HRw *)
pose (ss := fun k0 Hk0 =>  (projT1  (s_b k0 Hk0))).
pose (bb := fun k0 Hk0 => (projT1 (projT2  (s_b k0 Hk0)))).
(* avec valeurs dans A *)
pose (ssA := (fun k0 Hk0 => proj1_sig (ss k0 Hk0))).
pose (bbA := (fun k0 Hk0 => proj1_sig (bb k0 Hk0))).

assert (HbsA : forall (n:A) (k:A) (Hn:std n /\ 0 <=A n) (Hk: std k /\ 0 <=A k), k <=A n -> ssA n Hn <A bbA k Hk).

assert (Hbs : forall (n:A) (k:A) (Hn:std n /\ 0 <=A n) (Hk: std k /\ 0 <=A k), k <=A n -> bb k Hk [>] ss n Hn).
intros.
assert (HS:(S (ss n Hn))).
unfold ss.
elim (s_b n Hn).
intros sn (bn, (Hsn,(Hbn,H'))).
simpl; solve [intuition].
assert (HB: upper_bound S (bb k Hk)).
unfold bb.
elim (s_b k Hk).
intros sk (bk, (Hsk,(Hbk,H'))).
simpl; solve [intuition].
apply HB; assumption.

intros.
apply HRwgt_Zgt; apply Hbs; assumption.
assert (Hb0s0:  (b0[+] (-w s0)) [>] [0]).
apply HRwgt_HRwplus_inv_r with (s0).
ring_simplify.
apply Hb0; apply Hs0.

(* end asserts *)
unfold ltA in HbsA.
assert (Maux : forall (n : A) (Hn : std n /\ 0 <=A n) (k:A) (Hk : std k /\ 0 <=A k),
       k <=A n -> exists N : nat, forall n0 : nat, n0 > N -> (ssA n Hn n0 < bbA k Hk n0)%Z).
intros; apply HbsA; assumption.
assert (Maux' : forall (n : A) (Hn : std n /\ 0 <=A n) (k:A) (Hk : std k /\ 0 <=A k),
       k <=A n -> exists N : nat, forall n0 : nat, n0 >= N -> (ssA n Hn n0 < bbA k Hk n0)%Z).
intros n Hn k Hk Hnk; destruct (Maux n Hn k Hk Hnk) as [N HN]; exists (N+1)%nat; intros; apply HN; omega.

assert (M:(forall (n : A) (Hn : std n /\ 0 <=A n) (k : A) (Hk : std k /\ 0 <=A k),
       k <=A n -> { N : nat | forall m : nat, m >= N -> (ssA n Hn m < bbA k Hk m)%Z})).
admit. (* to be fixed (easy), we shifted to Set-existential types *)

pose (tau:=def_tau ssA bbA M).

assert (tau_prop: forall n:A, forall Hn:(std n/\0<=A n), (ssA n Hn) <=A tau /\  tau <=A (bbA n Hn)).
intros p Hp.
split.

exists (def_bigM ssA bbA M (exist _ p Hp)). (* we choose M_p *)
intros m Hm.
unfold tau,def_tau.
destruct (hyp2 m (def_bigM ssA bbA M) (bigM_increases ssA bbA M)) as[[nx Hnx ]|].
assert (Hp1:std (p+1)/\0<=A (p+1)) by (apply std_n_n1; assumption).

destruct (A_is_nat p Hp) as [px Hpx].
subst.

destruct (le_lt_dec px nx)%nat.

apply (s_increases S Hdec s0 b0 Hs0 Hb0) with (bbA:=bbA).
reflexivity.
reflexivity.
apply proj_nat2A'; assumption.

assert ( def_bigM ssA bbA M (nat2A (nx + 1))<m).
assert (nx+1<=px) by omega.
eapply Lt.le_lt_trans.
2:apply Hm.
apply bigM_increases2.
simpl.

apply proj_nat2A'.
assumption.
omega.

assert (m<= def_bigM ssA bbA M  (exist (fun n : A => std n /\ 0 <=A n) p Hp)).
eapply Le.le_trans.
apply lt_le_weak; apply l.
apply bigM_increases2.
simpl.
destruct Hp; assumption.
omega.
(* concludes : ss n <=w Tau *)

exists (def_bigM ssA bbA M (exist _ p Hp)). (* we choose M_p *)
intros m Hm.
unfold tau,def_tau.
destruct (hyp2 m (def_bigM ssA bbA M) (bigM_increases ssA bbA M)) as[[nx Hnx ]|].
assert (Hp1:std (p+1)/\0<=A (p+1)) by (apply std_n_n1; assumption).

destruct (A_is_nat p Hp) as [px Hpx].
subst.

destruct (le_lt_dec px nx)%nat.
assert (Hle : proj1_sig (nat2A px) <=A proj1_sig (nat2A nx)).
apply proj_nat2A'; assumption.

pose (localM := (M (proj1_sig (nat2A nx)) (proj2_sig (nat2A nx)) (proj1_sig (nat2A px)) Hp Hle)).

apply Z.lt_le_incl.
apply (proj2_sig localM).

assert (proj1_sig localM <=def_bigM ssA bbA M (nat2A (nx))).
destruct (nat2A nx) as [v Hv].
unfold localM; apply bigM_bigger.

omega.

assert ( def_bigM ssA bbA M (nat2A (nx + 1))<m).
assert (nx+1<=px) by omega.
eapply Lt.le_lt_trans.
2:apply Hm.
apply bigM_increases2.
simpl.

apply proj_nat2A'.
assumption.
omega.

assert (m<= def_bigM ssA bbA M  (exist (fun n : A => std n /\ 0 <=A n) p Hp)).
eapply Le.le_trans.
apply lt_le_weak; apply l.
apply bigM_increases2.
simpl.
destruct Hp; assumption.
omega.
(* concludes : bb n >=w Tau *)

assert (Ptau:(P tau)).
assert (H0:std 0 /\ 0<=A 0) by (split; [apply std0 | apply le_refl]).
eapply between_is_P with (x:=proj1_sig (ss 0 H0)) (y:=proj1_sig (bb 0 H0)).
destruct (ss 0 H0); assumption.
destruct (bb 0 H0); assumption.
apply tau_prop.
apply tau_prop.

pose(Tau := (exist (fun x : A => P x) tau Ptau)).
exists Tau.
split.
intros.
assert (HTauv: (v [+] (-w Tau)) [>] [0]).
apply HRwgt_HRwplus_inv_r with (Tau).
ring_simplify; assumption.
(* Check (power_lim2 two_third (proj1 two_third_prop) (proj2 two_third_prop) (b0 [+] (-w s0)) Hb0s0 (v [+] (-w Tau)) HTauv). *)
destruct (power_lim2 two_third (proj1 two_third_prop) (proj2 two_third_prop) (b0 [+] (-w s0)) Hb0s0 (v [+] (-w Tau)) HTauv)
  as [n [Hn1 [Hn2 Hn3]]].

assert  (HPsb:(Psb S s0 b0 n (conj Hn1 Hn2) (ss n (conj Hn1 Hn2)) (bb n (conj Hn1 Hn2)))).
unfold ss, bb ; destruct (s_b n (conj Hn1 Hn2)) as [x s].
destruct s as [y [r1 [r2 r3]]].
unfold Psb; simpl.
repeat split; assumption.

destruct HPsb as [HH1 [HH2 HH3]].

assert ((((b0 [+] (-w s0)) [*] (mk_HRw n (conj Hn1 Hn2) [+] [1])) [*] power two_third n (conj Hn1 Hn2)) [=]
  bb n (conj Hn1 Hn2) [+] -w (ss n (conj Hn1 Hn2))).
symmetry.
assert (HRew: exist P (n * w + w) (Padd (n * w) w (HRw_n n (conj Hn1 Hn2)) Pw) [=] (mk_HRw n (conj Hn1 Hn2) [+] [1])).
simpl;intros.
setoid_replace (n * w + w + - (n * w + w)) with a0 by ring.
rewrite abs_pos_val.
ring_simplify.
apply lt_le; apply Aw.
apply le_refl.

rewrite HH3; ring.
assert ((v [+] -w (bb n (conj Hn1 Hn2))) [>] (Tau [+] (-w (ss n (conj Hn1 Hn2))))).
generalize (Hn3 (conj Hn1 Hn2)); intros Hn3'.
rewrite H0 in Hn3'.
apply HRwgt_HRwplus_inv_r with (bb n (conj Hn1 Hn2) [+] (-w Tau)).
ring_simplify; unfold HRwminus; assumption.
assert ( (Tau [+] (-w ss n (conj Hn1 Hn2))) [>=] [0]).
apply HRwge_HRwplus_inv_r with (ss n (conj Hn1 Hn2)).
ring_simplify.
apply Zge_HRwge; apply tau_prop.
assert ( (v [+] (-w bb n (conj Hn1 Hn2))) [>] [0]).
apply HRwgt_HRwge_trans with (Tau [+] (-w ss n (conj Hn1 Hn2))).
assumption.
assumption.
exists (bb n (conj Hn1 Hn2)).
split.
unfold upper_bound; intros.
apply HH2; assumption.
split.
apply HRwgt_HRwplus_inv_r with (-w bb n (conj Hn1 Hn2)).
setoid_replace (bb n (conj Hn1 Hn2) [+] (-w bb n (conj Hn1 Hn2))) with [0] by ring.
assumption.
apply Zge_HRwge; apply tau_prop.
intros mu HmuTau.
assert (HmuTau': (Tau [+] (-w mu)) [>] [0]).
apply HRwgt_HRwplus_inv_r with (mu).
ring_simplify; assumption.
destruct (power_lim2 two_third (proj1 two_third_prop) (proj2 two_third_prop) (b0 [+] (-w s0)) Hb0s0 (Tau [+] (-w mu)) HmuTau')
  as [k [Hk1 [Hk2 Hk3]]].

assert  (HPsb:(Psb S s0 b0 k (conj Hk1 Hk2) (ss k (conj Hk1 Hk2)) (bb k (conj Hk1 Hk2)))).
unfold ss, bb ; destruct (s_b k (conj Hk1 Hk2)) as [x s].
destruct s as [y [r1 [r2 r3]]].
unfold Psb; simpl.
repeat split; assumption.

destruct HPsb as [HH1 [HH2 HH3]].

assert (((ss k (conj Hk1 Hk2)) [+] (-w mu)) [>] (bb k (conj Hk1 Hk2) [+] (-w Tau))).
generalize (Hk3 (conj Hk1 Hk2)); intros Hk3'.
setoid_replace (((b0 [+] (-w s0)) [*] (mk_HRw k (conj Hk1 Hk2) [+] [1])) [*] power two_third k (conj Hk1 Hk2)) with
((mk_HRw k (conj Hk1 Hk2) [+] [1]) [*] (power two_third k (conj Hk1 Hk2) [*] (b0 [+] (-w s0)))) in Hk3' by ring.
rewrite <- HH3 in Hk3'.
apply HRwgt_HRwplus_inv_l with ( (-w (ss k (conj Hk1 Hk2)) [+] Tau)).
ring_simplify.
rewrite HRwplus_comm.
unfold HRwminus; assumption.
assert (((bb k (conj Hk1 Hk2)) [+] (-w Tau)) [>=] [0]).
apply HRwge_HRwplus_inv_r with (Tau).
ring_simplify.
apply Zge_HRwge; apply tau_prop.
assert ((((ss k (conj Hk1 Hk2))) [+] (-w mu)) [>] [0]).
apply HRwgt_HRwge_trans with (bb k (conj Hk1 Hk2) [+] (-w Tau)).
assumption.
assumption.
exists (ss k (conj Hk1 Hk2)).
split.
apply HH1.
apply HRwgt_HRwplus_inv_r with (-w mu).
setoid_replace (mu [+] (-w mu)) with [0] by ring.
assumption.
Admitted.

End lub_proof_LS.

(* Local Variables: *)
(* coq-prog-name: "/Users/magaud/.opam/4.09.0/bin/coqtop" *)
(* coq-load-path: ( ("." "HR") ) *)
(* suffixes: .v *)
(* End: *)


Require Import lang.
Require Import lib.
Require Import Ascii.

Definition injection_symbol : ascii := "i".
Definition injection_var : exp := (exp_var "i").

Fixpoint _quote (t_env : type_env) (e : exp) : option exp :=
  match e with
  | exp_func v t_v e =>
    if (ascii_dec v injection_symbol) then None else
      let new_t_env := { v, t_v | t_env } in
      option_map (fun e' => exp_func v t_v e')
                 (_quote new_t_env e)
  | exp_app e1 e2 =>
      match _typecheck t_env e1,
            _quote t_env e1,
            _quote t_env e2 with
      | Some t, Some e1', Some e2' =>
          Some (exp_app (exp_app
                           (exp_tapp injection_var t) e1'
                        ) e2')
      | _, _, _ => None
      end
  | exp_tfunc v e =>
    if (ascii_dec v injection_symbol) then None else
      option_map (fun e' => exp_tfunc v e')
                 (_quote t_env e)
  | exp_tapp e t =>
      match _typecheck t_env e,
            _quote t_env e with
      | Some t', Some e' =>
          Some (exp_tapp (exp_app
                            (exp_tapp injection_var t') e'
                         ) t)
      | _, _ => None
      end
  | exp_var v => if (ascii_dec v injection_symbol) then None else Some (exp_var v)
  end.

Hint Transparent option_map.

Definition quote (e: exp) : option exp :=
  option_map (fun e' => exp_func injection_symbol identity_type e')
             (_quote empty_mapping e).

Inductive no_injection_symbol : exp -> Prop :=
  | nis_func: forall v t_v e,
      v <> injection_symbol ->
      no_injection_symbol e ->
      no_injection_symbol (exp_func v t_v e)
  | nis_app: forall e1 e2,
      no_injection_symbol e1 ->
      no_injection_symbol e2 ->
      no_injection_symbol (exp_app e1 e2)
  | nis_tfunc: forall v e,
      no_injection_symbol e ->
      no_injection_symbol (exp_tfunc v e)
  | nis_tapp: forall e t,
      no_injection_symbol e ->
      no_injection_symbol (exp_tapp e t)
  | nis_var: forall v,
      v <> injection_symbol ->
      no_injection_symbol (exp_var v).

Hint Constructors no_injection_symbol.

Lemma _quote_nis : forall e e' env,
    _quote env e = Some e' ->
    no_injection_symbol e.
Proof.
  intros e.
  induction e; intros e' env Hq; simpl in Hq;
    destruct_prem; unfold option_map in *; destruct_match; eauto.
Qed.

Hint Resolve _quote_nis.

Lemma quote_nis : forall e e',
    quote e = Some e' ->
    no_injection_symbol e.
Proof.
  intros e e' H.
  unfold quote in H.
  unfold option_map in H.
  destruct_match.
  eauto.
Qed.

Hint Resolve quote_nis.

Definition unquote : exp :=
  let rtype := type_func identity_type (type_var "a") in
  exp_tfunc "a" (exp_func "q" rtype
                          (exp_app (exp_var "q") identity)).

Lemma strong_quote_nf : forall e e' t_env,
    _quote t_env e = Some e' ->
    nf e'.
Proof.
  intros e.
  induction e; intros; simpl in *; try unfold option_map in *;
    destruct_match; repeat constructor; intuition;
      destruct_ex; solve_by_inversion_step eauto.
Qed.

Hint Resolve strong_quote_nf.

Theorem quote_nf : forall e e',
    quote e = Some e' ->
    nf e'.
Proof.
  intros e e' H.
  unfold quote in H.
  unfold option_map in H.
  destruct_match.
  eauto.
Qed.

Lemma typecheck_without_i : forall e env,
    no_injection_symbol e ->
    _typecheck env e = _typecheck {injection_symbol, identity_type | env} e.
Proof.
  intros e.
  induction e; intros env Hi; simpl; inversion Hi;
    auto_cond_rewrite; try rewrite mapping_reorder by auto; eauto.
  (* only the variable case left *)
  unfold mapping_update.
  destruct_prem.
  reflexivity.
Qed.

Lemma identity_app_type : forall e env t,
    no_injection_symbol e ->
    _typecheck env e = Some t ->
    _typecheck {injection_symbol, identity_type | env}
               (exp_app (exp_tapp injection_var t) e) = Some t.
Proof.
  intros e env t Hi Ht.
  simpl.
  rewrite <- typecheck_without_i by auto.
  multi_rewrite 1.
  destruct_prem.
  reflexivity.
Qed.

Hint Resolve identity_app_type.

Lemma identity_app_type' : forall e env t,
    no_injection_symbol e ->
    / env |- e : t ->
    / {injection_symbol, identity_type | env} |-
    (exp_app (exp_tapp injection_var t) e) : t.
Proof.
  intros.
  auto.
Qed.

Hint Resolve identity_app_type'.

(* Lemmas for automations *)

Lemma quote_func_type : forall v t_v e0 t0 env,
    v <> injection_symbol ->
    / {injection_symbol, identity_type | {v, t_v | env}} |- e0 : t0 ->
    / {injection_symbol, identity_type | env} |-
    exp_func v t_v e0 : type_func t_v t0.
Proof.
  intros.
  constructor.
  rewrite mapping_reorder by auto.
  assumption.
Qed.

Lemma quote_app_type : forall e1 e2 t0 t1 env env',
    env' = {injection_symbol, identity_type | env} ->
    / env' |- e1 : type_func t0 t1 ->
    / env' |- e2 : t0 ->
    / env' |- exp_app (exp_app (exp_tapp injection_var
                                        (type_func t0 t1)) e1) e2 : t1.
Proof.
  intros e1 e2 t0 t1 env env' He H1 H2.
  rewrite He in *.
  repeat econstructor; auto.
Qed.

Lemma quote_tapp_type : forall e1 t2 v t1 env env',
    env' = {injection_symbol, identity_type | env} ->
    / env' |- e1 : type_forall v t1 ->
    / env' |- exp_tapp (exp_app (exp_tapp injection_var
                                         (type_forall v t1)) e1) t2 :
               subst_type t1 v t2.
Proof.
  intros e1 t2 v t1 env env' He H1.
  rewrite He in *.
  repeat econstructor.
  auto.
Qed.

Lemma quote_var_type: forall v t env,
    v <> injection_symbol ->
    env v = Some t ->
    / {injection_symbol, identity_type | env} |- exp_var v : t.
Proof.
  intros.
  constructor.
  unfold mapping_update.
  destruct_prem.
  assumption.
Qed.

Hint Resolve
     quote_func_type
     quote_app_type
     quote_tapp_type
     quote_var_type.

Ltac rewrite_type_equiv :=
  repeat match goal with
         | [H1 : Some _ = _typecheck ?env ?e, H2 : / ?env |- ?e : _ |- _] =>
           apply typecheck_complete in H2; rewrite H2 in H1; inversion H1
         end.

Lemma strong_quote_type : forall e e' env t0,
    _quote env e = Some e' ->
    _typecheck env e = Some t0 ->
    _typecheck {injection_symbol, identity_type | env} e'
    = Some t0.
Proof.
  intros e e' env t0 He Ht.
  generalize (_quote_nis _ _ _ He).
  intros Hi.
  apply typecheck_sound in Ht.
  apply typecheck_complete.
  generalize dependent e'.
  generalize dependent env.
  generalize dependent t0.
  induction e; intros t0 env Ht e0' He; simpl in He;
    try unfold option_map in He; inversion Ht; subst; inversion Hi;
      destruct_match ; rewrite_type_equiv; remove_option_wrapper; eauto.
Qed.

Hint Resolve strong_quote_type.

Theorem quote_type : forall e e' t0,
    quote e = Some e' ->
    typecheck e = Some t0 ->
    typecheck e' = Some (type_func identity_type t0).
Proof.
  intros e e' t0 H1 H2.
  unfold quote in H1.
  unfold option_map in H1.
  destruct_match.
  apply typecheck_complete.
  eauto.
Qed.

(* don't have a decision procedure for reduction,
   so this proof is quite verbose *)
Lemma unquoted_wrapper : forall t e e',
    exp_subst e injection_symbol identity e' ->
    (exp_app (exp_tapp unquote t)
             (exp_func injection_symbol identity_type e)) ~ e'.
Proof.
  intros t e e' H0.
  assert ((exp_tapp unquote t)
            ~ (exp_func "q" (type_func identity_type t)
                        (exp_app (exp_var "q") identity))) as H.
  {
    repeat constructor.
    unfold identity_type_symbol.
    congruence.
  }
  rewrite H.
  (* needs two steps of reductions here *)
  econstructor 3;
    repeat econstructor; try (intros contra; inversion contra).
  assumption.
Qed.

(*
  it's nice to have these trivial lemmas,
  since using eauto is much easier than rewrite
 *)
Lemma identity_reduce : forall e t,
    (exp_app (exp_tapp identity t) e) ~ e.
Proof.
  intros e t.
  constructor.
  econstructor 2; repeat constructor.
Qed.

Lemma exp_func_equiv : forall v t_v e1 e2,
    e1 ~ e2 ->
    exp_func v t_v e1 ~ exp_func v t_v e2.
Proof.
  intros.
  rewrite H.
  reflexivity.
Qed.

Lemma exp_app_equiv : forall e1 e2 e1' e2',
    e1 ~ e1' ->
    e2 ~ e2' ->
    exp_app e1 e2 ~ exp_app e1' e2'.
Proof.
  intros.
  rewrite H.
  rewrite H0.
  reflexivity.
Qed.

Lemma exp_tfunc_equiv : forall v e e',
    e ~ e' ->
    exp_tfunc v e ~ exp_tfunc v e'.
Proof.
  intros.
  rewrite H.
  reflexivity.
Qed.

Lemma exp_tapp_equiv : forall e e' t,
    e ~ e' ->
    exp_tapp e t ~ exp_tapp e' t.
Proof.
  intros.
  rewrite H.
  reflexivity.
Qed.

Hint Resolve identity_reduce.
Hint Resolve exp_func_equiv.
Hint Resolve exp_app_equiv.
Hint Resolve exp_tfunc_equiv.
Hint Resolve exp_tapp_equiv.

Lemma unquoted_free_eq : forall t e e' env,
    _typecheck env e = Some t ->
    _quote env e = Some e' ->
    (subst_exp e' injection_symbol identity) ~ e.
Proof.
  intros t e e' env Ht He.
  generalize (_quote_nis _ _ _ He).
  intros Hi.
  generalize dependent t.
  generalize dependent e'.
  generalize dependent env.
  induction e; intros env e' He t0 Ht;
    inversion Hi; inversion He; subst; simpl in *;
      try unfold option_map in *;
      destruct_match; simpl; destruct_prem; eauto.
Qed.

Hint Resolve unquoted_wrapper.
Hint Resolve unquoted_free_eq.

Theorem unquoted_eq : forall e e' t,
    quote e = Some e' ->
    typecheck e = Some t ->
    (exp_app (exp_tapp unquote t) e') ~ e.
Proof.
  intros e e0' t0 Hq Ht.
  unfold quote in Hq.
  unfold option_map in Hq.
  option_match Hq e'.
  constructor 3 with (subst_exp e' injection_symbol identity); eauto.
  apply unquoted_wrapper.
  apply subst_exp_correct.
  auto.
Qed.


Require Export XR_Rminus.
Require Export XR_Rplus_lt_reg_r.

Local Open Scope R_scope.

Lemma Rminus_lt : forall r1 r2,
  r1 - r2 < R0 ->
  r1 < r2.
Proof.
  intros x y h.
  apply Rplus_lt_reg_r with (-y).
  rewrite Rplus_opp_r.
  unfold Rminus in h.
  exact h.
Qed.


From iris.algebra Require Export cmra.
From iris.algebra Require Import updates local_updates.
From stdpp Require Export collections gmap mapset.
Set Default Proof Using "Type".

(* The union CMRA *)
Section gset.
  Context `{Countable K}.
  Implicit Types X Y : gset K.

  Canonical Structure gsetC := discreteC (gset K).

  Instance gset_valid : Valid (gset K) := λ _, True.
  Instance gset_unit : Unit (gset K) := (∅ : gset K).
  Instance gset_op : Op (gset K) := union.
  Instance gset_pcore : PCore (gset K) := λ X, Some X.

  Lemma gset_op_union X Y : X ⋅ Y = X ∪ Y.
  Proof. done. Qed.
  Lemma gset_core_self X : core X = X.
  Proof. done. Qed.
  Lemma gset_included X Y : X ≼ Y ↔ X ⊆ Y.
  Proof.
    split.
    - intros [Z ->]. rewrite gset_op_union. set_solver.
    - intros (Z&->&?)%subseteq_disjoint_union_L. by exists Z.
  Qed.

  Lemma gset_ra_mixin : RAMixin (gset K).
  Proof.
    apply ra_total_mixin; eauto.
    - solve_proper.
    - solve_proper.
    - solve_proper.
    - intros X1 X2 X3. by rewrite !gset_op_union assoc_L.
    - intros X1 X2. by rewrite !gset_op_union comm_L.
    - intros X. by rewrite gset_core_self idemp_L.
  Qed.
  Canonical Structure gsetR := discreteR (gset K) gset_ra_mixin.

  Global Instance gset_cmra_discrete : CmraDiscrete gsetR.
  Proof. apply discrete_cmra_discrete. Qed.

  Lemma gset_ucmra_mixin : UcmraMixin (gset K).
  Proof. split. done. intros X. by rewrite gset_op_union left_id_L. done. Qed.
  Canonical Structure gsetUR := UcmraT (gset K) gset_ucmra_mixin.

  Lemma gset_opM X mY : X ⋅? mY = X ∪ default ∅ mY.
  Proof. destruct mY; by rewrite /= ?right_id_L. Qed.

  Lemma gset_update X Y : X ~~> Y.
  Proof. done. Qed.

  Lemma gset_local_update X Y X' : X ⊆ X' → (X,Y) ~l~> (X',X').
  Proof.
    intros (Z&->&?)%subseteq_disjoint_union_L.
    rewrite local_update_unital_discrete=> Z' _ /leibniz_equiv_iff->.
    split. done. rewrite gset_op_union. set_solver.
  Qed.

  Global Instance gset_core_id X : CoreId X.
  Proof. by apply core_id_total; rewrite gset_core_self. Qed.
End gset.

Arguments gsetC _ {_ _}.
Arguments gsetR _ {_ _}.
Arguments gsetUR _ {_ _}.

(* The disjoint union CMRA *)
Inductive gset_disj K `{Countable K} :=
  | GSet : gset K → gset_disj K
  | GSetBot : gset_disj K.
Arguments GSet {_ _ _} _.
Arguments GSetBot {_ _ _}.

Section gset_disj.
  Context `{Countable K}.
  Arguments op _ _ !_ !_ /.
  Arguments cmra_op _ !_ !_ /.
  Arguments ucmra_op _ !_ !_ /.

  Canonical Structure gset_disjC := leibnizC (gset_disj K).

  Instance gset_disj_valid : Valid (gset_disj K) := λ X,
    match X with GSet _ => True | GSetBot => False end.
  Instance gset_disj_unit : Unit (gset_disj K) := GSet ∅.
  Instance gset_disj_op : Op (gset_disj K) := λ X Y,
    match X, Y with
    | GSet X, GSet Y => if decide (X ## Y) then GSet (X ∪ Y) else GSetBot
    | _, _ => GSetBot
    end.
  Instance gset_disj_pcore : PCore (gset_disj K) := λ _, Some ε.

  Ltac gset_disj_solve :=
    repeat (simpl || case_decide);
    first [apply (f_equal GSet)|done|exfalso]; set_solver by eauto.

  Lemma gset_disj_included X Y : GSet X ≼ GSet Y ↔ X ⊆ Y.
  Proof.
    split.
    - move=> [[Z|]]; simpl; try case_decide; set_solver.
    - intros (Z&->&?)%subseteq_disjoint_union_L.
      exists (GSet Z). gset_disj_solve.
  Qed.
  Lemma gset_disj_valid_inv_l X Y : ✓ (GSet X ⋅ Y) → ∃ Y', Y = GSet Y' ∧ X ## Y'.
  Proof. destruct Y; repeat (simpl || case_decide); by eauto. Qed.
  Lemma gset_disj_union X Y : X ## Y → GSet X ⋅ GSet Y = GSet (X ∪ Y).
  Proof. intros. by rewrite /= decide_True. Qed.
  Lemma gset_disj_valid_op X Y : ✓ (GSet X ⋅ GSet Y) ↔ X ## Y.
  Proof. simpl. case_decide; by split. Qed.

  Lemma gset_disj_ra_mixin : RAMixin (gset_disj K).
  Proof.
    apply ra_total_mixin; eauto.
    - intros [?|]; destruct 1; gset_disj_solve.
    - by constructor.
    - by destruct 1.
    - intros [X1|] [X2|] [X3|]; gset_disj_solve.
    - intros [X1|] [X2|]; gset_disj_solve.
    - intros [X|]; gset_disj_solve.
    - exists (GSet ∅); gset_disj_solve.
    - intros [X1|] [X2|]; gset_disj_solve.
  Qed.
  Canonical Structure gset_disjR := discreteR (gset_disj K) gset_disj_ra_mixin.

  Global Instance gset_disj_cmra_discrete : CmraDiscrete gset_disjR.
  Proof. apply discrete_cmra_discrete. Qed.

  Lemma gset_disj_ucmra_mixin : UcmraMixin (gset_disj K).
  Proof. split; try apply _ || done. intros [X|]; gset_disj_solve. Qed.
  Canonical Structure gset_disjUR := UcmraT (gset_disj K) gset_disj_ucmra_mixin.

  Arguments op _ _ _ _ : simpl never.

  Lemma gset_disj_alloc_updateP_strong P (Q : gset_disj K → Prop) X :
    (∀ Y, X ⊆ Y → ∃ j, j ∉ Y ∧ P j) →
    (∀ i, i ∉ X → P i → Q (GSet ({[i]} ∪ X))) → GSet X ~~>: Q.
  Proof.
    intros Hfresh HQ.
    apply cmra_discrete_updateP=> ? /gset_disj_valid_inv_l [Y [->?]].
    destruct (Hfresh (X ∪ Y)) as (i&?&?); first set_solver.
    exists (GSet ({[ i ]} ∪ X)); split.
    - apply HQ; set_solver by eauto.
    - apply gset_disj_valid_op. set_solver by eauto.
  Qed.
  Lemma gset_disj_alloc_updateP_strong' P X :
    (∀ Y, X ⊆ Y → ∃ j, j ∉ Y ∧ P j) →
    GSet X ~~>: λ Y, ∃ i, Y = GSet ({[ i ]} ∪ X) ∧ i ∉ X ∧ P i.
  Proof. eauto using gset_disj_alloc_updateP_strong. Qed.

  Lemma gset_disj_alloc_empty_updateP_strong P (Q : gset_disj K → Prop) :
    (∀ Y : gset K, ∃ j, j ∉ Y ∧ P j) →
    (∀ i, P i → Q (GSet {[i]})) → GSet ∅ ~~>: Q.
  Proof.
    intros. apply (gset_disj_alloc_updateP_strong P); eauto.
    intros i; rewrite right_id_L; auto.
  Qed.
  Lemma gset_disj_alloc_empty_updateP_strong' P :
    (∀ Y : gset K, ∃ j, j ∉ Y ∧ P j) →
    GSet ∅ ~~>: λ Y, ∃ i, Y = GSet {[ i ]} ∧ P i.
  Proof. eauto using gset_disj_alloc_empty_updateP_strong. Qed.

  Section fresh_updates.
    Local Set Default Proof Using "Type*".
    Context `{Fresh K (gset K), !FreshSpec K (gset K)}.

    Lemma gset_disj_alloc_updateP (Q : gset_disj K → Prop) X :
      (∀ i, i ∉ X → Q (GSet ({[i]} ∪ X))) → GSet X ~~>: Q.
    Proof.
      intro; eapply gset_disj_alloc_updateP_strong with (λ _, True); eauto.
      intros Y ?; exists (fresh Y); eauto using is_fresh.
    Qed.
    Lemma gset_disj_alloc_updateP' X :
      GSet X ~~>: λ Y, ∃ i, Y = GSet ({[ i ]} ∪ X) ∧ i ∉ X.
    Proof. eauto using gset_disj_alloc_updateP. Qed.

    Lemma gset_disj_alloc_empty_updateP (Q : gset_disj K → Prop) :
      (∀ i, Q (GSet {[i]})) → GSet ∅ ~~>: Q.
    Proof.
      intro. apply gset_disj_alloc_updateP. intros i; rewrite right_id_L; auto.
    Qed.
    Lemma gset_disj_alloc_empty_updateP' : GSet ∅ ~~>: λ Y, ∃ i, Y = GSet {[ i ]}.
    Proof. eauto using gset_disj_alloc_empty_updateP. Qed.
  End fresh_updates.

  Lemma gset_disj_dealloc_local_update X Y :
    (GSet X, GSet Y) ~l~> (GSet (X ∖ Y), GSet ∅).
  Proof.
    apply local_update_total_valid=> _ _ /gset_disj_included HYX.
    rewrite local_update_unital_discrete=> -[Xf|] _ /leibniz_equiv_iff //=.
    rewrite {1}/op /=. destruct (decide _) as [HXf|]; [intros[= ->]|done].
    by rewrite difference_union_distr_l_L
      difference_diag_L !left_id_L difference_disjoint_L.
  Qed.
  Lemma gset_disj_dealloc_empty_local_update X Z :
    (GSet Z ⋅ GSet X, GSet Z) ~l~> (GSet X, GSet ∅).
  Proof.
    apply local_update_total_valid=> /gset_disj_valid_op HZX _ _.
    assert (X = (Z ∪ X) ∖ Z) as HX by set_solver.
    rewrite gset_disj_union // {2}HX. apply gset_disj_dealloc_local_update.
  Qed.
  Lemma gset_disj_dealloc_op_local_update X Y Z :
    (GSet Z ⋅ GSet X, GSet Z ⋅ GSet Y) ~l~> (GSet X,GSet Y).
  Proof.
    rewrite -{2}(left_id ε _ (GSet Y)).
    apply op_local_update_frame, gset_disj_dealloc_empty_local_update.
  Qed.

  Lemma gset_disj_alloc_op_local_update X Y Z :
    Z ## X → (GSet X,GSet Y) ~l~> (GSet Z ⋅ GSet X, GSet Z ⋅ GSet Y).
  Proof.
    intros. apply op_local_update_discrete. by rewrite gset_disj_valid_op.
  Qed.
  Lemma gset_disj_alloc_local_update X Y Z :
    Z ## X → (GSet X,GSet Y) ~l~> (GSet (Z ∪ X), GSet (Z ∪ Y)).
  Proof.
    intros. apply local_update_total_valid=> _ _ /gset_disj_included ?.
    rewrite -!gset_disj_union //; last set_solver.
    auto using gset_disj_alloc_op_local_update.
  Qed.
  Lemma gset_disj_alloc_empty_local_update X Z :
    Z ## X → (GSet X, GSet ∅) ~l~> (GSet (Z ∪ X), GSet Z).
  Proof.
    intros. rewrite -{2}(right_id_L _ union Z).
    apply gset_disj_alloc_local_update; set_solver.
  Qed.
End gset_disj.

Arguments gset_disjC _ {_ _}.
Arguments gset_disjR _ {_ _}.
Arguments gset_disjUR _ {_ _}.