Require Import SetInterface SetFacts SetDecide.
Set Implicit Arguments.
Unset Strict Implicit.

Generalizable All Variables.
Local Open Scope set_scope.

(** This file corresponds to [FSetProperties.v] in the standard
   library and provides the same results for the typeclass-based
   version.
   *)
Hint Unfold transpose compat_op.

Lemma In_dec : forall `{HF : @FSetSpecs A HA F}
  x s, {In x s} + {~ In x s}.
Proof.
  intros; generalize (mem_iff s x); case (mem x s); intuition.
Qed.

Definition Add `{HF : @FSetSpecs A HA F} x s s' :=
  forall y, In y s' <-> x === y \/ In y s.

Lemma Add_Equal `{HF : @FSetSpecs A HA F} :
  forall x s s', Add x s s' <-> s' [=] add x s.
Proof.
  unfold Add.
  split; intros.
  red; intros.
  rewrite H; clear H.
  fsetdec.
  fsetdec.
Qed.

Ltac expAdd := repeat rewrite Add_Equal; intros.

Section BasicProperties.
  Context `{HF : @FSetSpecs elt Helt F}.
  Variable s s' s'' s1 s2 s3 : set elt.
  Variable x x' : elt.

  Lemma equal_refl : s[=]s.
  Proof. fsetdec. Qed.

  Lemma equal_sym : s[=]s' -> s'[=]s.
  Proof. fsetdec. Qed.

  Lemma equal_trans : s1[=]s2 -> s2[=]s3 -> s1[=]s3.
  Proof. fsetdec. Qed.

  Lemma subset_refl : s[<=]s.
  Proof. fsetdec. Qed.

  Lemma subset_trans : s1[<=]s2 -> s2[<=]s3 -> s1[<=]s3.
  Proof. fsetdec. Qed.

  Lemma subset_antisym : s[<=]s' -> s'[<=]s -> s[=]s'.
  Proof. fsetdec. Qed.

  Lemma subset_equal : s[=]s' -> s[<=]s'.
  Proof. fsetdec. Qed.

  Lemma subset_empty : empty[<=]s.
  Proof. fsetdec. Qed.

  Lemma subset_remove_3 : s1[<=]s2 -> remove x s1 [<=] s2.
  Proof. fsetdec. Qed.

  Lemma subset_diff : s1[<=]s3 -> diff s1 s2 [<=] s3.
  Proof. fsetdec. Qed.

  Lemma subset_add_3 : In x s2 -> s1[<=]s2 -> add x s1 [<=] s2.
  Proof. fsetdec. Qed.

  Lemma subset_add_2 : s1[<=]s2 -> s1[<=] add x s2.
  Proof. fsetdec. Qed.

  Lemma in_subset : In x s1 -> s1[<=]s2 -> In x s2.
  Proof. fsetdec. Qed.

  Lemma double_inclusion : s1[=]s2 <-> s1[<=]s2 /\ s2[<=]s1.
  Proof. intuition fsetdec. Qed.

  Lemma empty_is_empty_1 : Empty s -> s[=]empty.
  Proof. fsetdec. Qed.

  Lemma empty_is_empty_2 : s[=]empty -> Empty s.
  Proof. fsetdec. Qed.

  Lemma add_equal : In x s -> add x s [=] s.
  Proof. fsetdec. Qed.

  Lemma add_add : add x (add x' s) [=] add x' (add x s).
  Proof. fsetdec. Qed.

  Lemma remove_equal : ~ In x s -> remove x s [=] s.
  Proof. fsetdec. Qed.

  Lemma Equal_remove : s[=]s' -> remove x s [=] remove x s'.
  Proof. fsetdec. Qed.

  Lemma add_remove : In x s -> add x (remove x s) [=] s.
  Proof. fsetdec. Qed.

  Lemma remove_add : ~In x s -> remove x (add x s) [=] s.
  Proof. fsetdec. Qed.

  Lemma singleton_equal_add : singleton x [=] add x empty.
  Proof. fsetdec. Qed.

  Lemma remove_singleton_empty :
    In x s -> remove x s [=] empty -> singleton x [=] s.
  Proof. fsetdec. Qed. (** Bizarrement long ! *)

  Lemma union_sym : union s s' [=] union s' s.
  Proof. fsetdec. Qed.

  Lemma union_subset_equal : s[<=]s' -> union s s' [=] s'.
  Proof. fsetdec. Qed.

  Lemma union_equal_1 : s[=]s' -> union s s'' [=] union s' s''.
  Proof. fsetdec. Qed.

  Lemma union_equal_2 : s'[=]s'' -> union s s' [=] union s s''.
  Proof. fsetdec. Qed.

  Lemma union_assoc : union (union s s') s'' [=] union s (union s' s'').
  Proof. fsetdec. Qed.

  Lemma add_union_singleton : add x s [=] union (singleton x) s.
  Proof. fsetdec. Qed.

  Lemma union_add : union (add x s) s' [=] add x (union s s').
  Proof. fsetdec. Qed.

  Lemma union_remove_add_1 :
    union (remove x s) (add x s') [=] union (add x s) (remove x s').
  Proof. fsetdec. Qed.

  Lemma union_remove_add_2 :
    In x s -> union (remove x s) (add x s') [=] union s s'.
  Proof. fsetdec. Qed.

  Lemma union_subset_1 : s [<=] union s s'.
  Proof. fsetdec. Qed.

  Lemma union_subset_2 : s' [<=] union s s'.
  Proof. fsetdec. Qed.

  Lemma union_subset_3 : s[<=]s'' -> s'[<=]s'' -> union s s' [<=] s''.
  Proof. fsetdec. Qed.

  Lemma union_subset_4 : s[<=]s' -> union s s'' [<=] union s' s''.
  Proof. fsetdec. Qed.

  Lemma union_subset_5 : s[<=]s' -> union s'' s [<=] union s'' s'.
  Proof. fsetdec. Qed.

  Lemma empty_union_1 : Empty s -> union s s' [=] s'.
  Proof. fsetdec. Qed.

  Lemma empty_union_2 : Empty s -> union s' s [=] s'.
  Proof. fsetdec. Qed.

  Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s').
  Proof. fsetdec. Qed.

  Lemma inter_sym : inter s s' [=] inter s' s.
  Proof. fsetdec. Qed.

  Lemma inter_subset_equal : forall s s', s[<=]s' -> inter s s' [=] s.
  Proof. fsetdec. Qed.

  Lemma inter_equal_1 : s[=]s' -> inter s s'' [=] inter s' s''.
  Proof. fsetdec. Qed.

  Lemma inter_equal_2 : s'[=]s'' -> inter s s' [=] inter s s''.
  Proof. fsetdec. Qed.

  Lemma inter_assoc : inter (inter s s') s'' [=] inter s (inter s' s'').
  Proof. fsetdec. Qed.

  Lemma union_inter_1 :
      inter (union s s') s'' [=] union (inter s s'') (inter s' s'').
  Proof. fsetdec. Qed.

  Lemma union_inter_2 :
      union (inter s s') s'' [=] inter (union s s'') (union s' s'').
  Proof. fsetdec. Qed.

  Lemma inter_add_1 : In x s' -> inter (add x s) s' [=] add x (inter s s').
  Proof. fsetdec. Qed.

  Lemma inter_add_2 : ~ In x s' -> inter (add x s) s' [=] inter s s'.
  Proof. fsetdec. Qed.

  Lemma empty_inter_1 : Empty s -> Empty (inter s s').
  Proof. fsetdec. Qed.

  Lemma empty_inter_2 : Empty s' -> Empty (inter s s').
  Proof. fsetdec. Qed.

  Lemma inter_subset_1 : inter s s' [<=] s.
  Proof. fsetdec. Qed.

  Lemma inter_subset_2 : inter s s' [<=] s'.
  Proof. fsetdec. Qed.

  Lemma inter_subset_3 : s''[<=]s -> s''[<=]s' -> s''[<=] inter s s'.
  Proof. fsetdec. Qed.

  Lemma empty_diff_1 : Empty s -> Empty (diff s s').
  Proof. fsetdec. Qed.

  Lemma empty_diff_2 : Empty s -> diff s' s [=] s'.
  Proof. fsetdec. Qed.

  Lemma diff_subset : diff s s' [<=] s.
  Proof. fsetdec. Qed.

  Lemma diff_subset_equal : s[<=]s' -> diff s s' [=] empty.
  Proof. fsetdec. Qed.

  Lemma remove_diff_singleton : remove x s [=] diff s (singleton x).
  Proof. fsetdec. Qed.

  Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty.
  Proof. fsetdec. Qed.

  Lemma diff_inter_all : union (diff s s') (inter s s') [=] s.
  Proof. fsetdec. Qed.

  Lemma Add_add : Add x s (add x s).
  Proof. expAdd; fsetdec. Qed.

  Lemma Add_remove : In x s -> Add x (remove x s) s.
  Proof. expAdd; fsetdec. Qed.

  Lemma union_Add : Add x s s' -> Add x (union s s'') (union s' s'').
  Proof. expAdd; fsetdec. Qed.

  Lemma inter_Add :
    In x s'' -> Add x s s' -> Add x (inter s s'') (inter s' s'').
  Proof. (* expAdd; rewrite Add_Equal in H0; fsetdec. Qed. *) (** trop lent *)
    expAdd; rewrite H0; clear H0; fsetdec.
  Qed.

  Lemma union_Equal : In x s'' -> Add x s s' -> union s s'' [=] union s' s''.
  Proof. (* expAdd; rewrite Add_Equal in H0; fsetdec. Qed.  *) (** trop lent *)
    expAdd; rewrite H0; clear H0; fsetdec.
  Qed.

  Lemma inter_Add_2 : ~In x s'' -> Add x s s' -> inter s s'' [=] inter s' s''.
  Proof.
    expAdd; rewrite H0; clear H0; fsetdec.
  Qed.

End BasicProperties.

Hint Immediate @equal_sym @add_remove @remove_add @union_sym @inter_sym: set.
Hint Resolve @equal_refl @equal_trans @subset_refl @subset_equal
  @subset_antisym @subset_trans @subset_empty @subset_remove_3 @subset_diff
  @subset_add_3 @subset_add_2 @in_subset @empty_is_empty_1 @empty_is_empty_2
  @add_equal @remove_equal @singleton_equal_add @union_subset_equal
  @union_equal_1 @union_equal_2 @union_assoc @add_union_singleton @union_add
  @union_subset_1 @union_subset_2 @union_subset_3 @inter_subset_equal
  @inter_equal_1 @inter_equal_2 @inter_assoc @union_inter_1 @union_inter_2
  @inter_add_1 @inter_add_2 @empty_inter_1 @empty_inter_2 @empty_union_1
  @empty_union_2 @empty_diff_1 @empty_diff_2 @union_Add @inter_Add
  @union_Equal @inter_Add_2 @not_in_union @inter_subset_1 @inter_subset_2
  @inter_subset_3 @diff_subset @diff_subset_equal @remove_diff_singleton
  @diff_inter_empty @diff_inter_all @Add_add @Add_remove @Equal_remove
  @add_add : set.

(** * Properties of elements *)
Lemma elements_Empty `{HF : @FSetSpecs A HA F} :
  forall s, Empty s <-> elements s = nil.
Proof.
  intros.
  unfold Empty.
  split; intros.
  assert (forall a, ~ List.In a (elements s)).
  red; intros.
  apply (H a).
  rewrite elements_iff.
  rewrite InA_alt; exists a; auto.
  destruct (elements s) as [|e ?]; auto.
  elim (H0 e); simpl; auto.
  red; intros.
  rewrite elements_iff in H0.
  rewrite InA_alt in H0; destruct H0.
  rewrite H in H0; destruct H0 as (_,H0); inversion H0.
Qed.

Lemma elements_empty `{HF : @FSetSpecs A HA F} :
  elements empty = nil.
Proof.
  intros; rewrite <-elements_Empty; auto with set.
Qed.

(** * Conversions between lists and sets *)
Definition of_list `{HF : @FSetSpecs A HA F} (l : list A) :=
  List.fold_right add empty l.

Definition to_list `{HF : @FSetSpecs A HA F} :=
  elements.

Lemma of_list_1 `{HF : @FSetSpecs A HA F} :
  forall l x, In x (of_list l) <-> InA _eq x l.
Proof.
  induction l; simpl; intro x.
  rewrite empty_iff, InA_nil. intuition.
  rewrite add_iff, InA_cons, IHl. intuition.
Qed.

Lemma of_list_2 `{HF : @FSetSpecs A HA F} :
  forall l, equivlistA _eq (to_list (of_list l)) l.
Proof.
  unfold to_list; red; intros.
  rewrite <- elements_iff; apply of_list_1.
Qed.

Lemma of_list_3 `{HF : @FSetSpecs A HA F} :
  forall s, of_list (to_list s) [=] s.
Proof.
  unfold to_list; red; intros.
  rewrite of_list_1; symmetry; apply elements_iff.
Qed.

(** * Fold *)

Section Fold.
  Notation NoDup := (NoDupA _eq).
  Notation InA := (InA _eq).
  Notation t := (set _).

  Context `{HF : @FSetSpecs elt Helt F}.
  Let t := set elt.
  Hint Extern 1 (Equivalence _) => apply OT_Equivalence.

  (** ** Induction principles for fold (contributed by S. Lescuyer) *)

  (** In the following lemma, the step hypothesis is deliberately restricted
      to the precise set s we are considering. *)
  Theorem fold_rec :
    forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t),
      (forall s', Empty s' -> P s' i) ->
      (forall x a s' s'', In x s -> ~In x s' -> Add x s' s'' ->
        P s' a -> P s'' (f x a)) ->
      P s (fold f s i).
  Proof.
    intros A P f i s Pempty Pstep.
    rewrite fold_1, <- fold_left_rev_right.
    set (l:=rev (elements s)).
    assert (Pstep' : forall x a s' s'', InA x l -> ~In x s' -> Add x s' s'' ->
      P s' a -> P s'' (f x a)).
    intros; eapply Pstep; eauto.
    rewrite elements_iff, <- InA_rev; auto.
    assert (Hdup : NoDup l) by
      (unfold l; apply NoDupA_rev; eauto using elements_3w).
    assert (Hsame : forall x, In x s <-> InA x l) by
      (unfold l; intros; rewrite elements_iff, InA_rev; intuition).
    clear Pstep; clearbody l; revert s Hsame; induction l.
    (* empty *)
    intros s Hsame; simpl.
    apply Pempty. intro x. rewrite Hsame, InA_nil; intuition.
    (* step *)
    intros s Hsame; simpl.
    apply Pstep' with (of_list l); auto.
    inversion_clear Hdup; rewrite of_list_1; auto.
    red. intros. rewrite Hsame, of_list_1, InA_cons; intuition.
    apply IHl.
    intros; eapply Pstep'; eauto.
    inversion_clear Hdup; auto.
    exact (of_list_1 l).
  Qed.

  (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this
      case, [P] must be compatible with equality of sets *)
  Theorem fold_rec_bis :
    forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t),
      (forall s s' a, s[=]s' -> P s a -> P s' a) ->
      (P empty i) ->
      (forall x a s', In x s -> ~In x s' -> P s' a -> P (add x s') (f x a)) ->
      P s (fold f s i).
  Proof.
    intros A P f i s Pmorphism Pempty Pstep.
    apply fold_rec; intros.
    apply Pmorphism with empty; auto with set.
    rewrite Add_Equal in H1; auto with set.
    apply Pmorphism with (add x s'); auto with set.
  Qed.

  Lemma fold_rec_nodep :
    forall (A:Type)(P : A -> Type)(f : elt -> A -> A)(i:A)(s:t),
     P i -> (forall x a, In x s -> P a -> P (f x a)) ->
     P (fold f s i).
  Proof.
    intros; apply (fold_rec_bis (P := fun _ => P)); auto.
  Qed.

  (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] :
      the step hypothesis must here be applicable to any [x].
      At the same time, it looks more like an induction principle,
      and hence can be easier to use. *)
  Lemma fold_rec_weak :
    forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A),
    (forall s s' a, s[=]s' -> P s a -> P s' a) ->
    P empty i ->
    (forall x a s, ~In x s -> P s a -> P (add x s) (f x a)) ->
    forall s, P s (fold f s i).
  Proof.
    intros; apply fold_rec_bis; auto.
  Qed.

  Lemma fold_rel :
    forall (A B:Type)(R : A -> B -> Type)
     (f : elt -> A -> A)(g : elt -> B -> B)(i : A)(j : B)(s : t),
     R i j ->
     (forall x a b, In x s -> R a b -> R (f x a) (g x b)) ->
     R (fold f s i) (fold g s j).
  Proof.
    intros A B R f g i j s Rempty Rstep.
    do 2 rewrite fold_1, <- fold_left_rev_right.
    set (l:=rev (elements s)).
    assert (Rstep' : forall x a b, InA x l -> R a b -> R (f x a) (g x b)) by
      (intros; apply Rstep; auto; rewrite elements_iff, <- InA_rev; auto).
    clearbody l; clear Rstep s.
    induction l; simpl; auto.
  Qed.

  (** From the induction principle on [fold], we can deduce some general
      induction principles on sets. *)
  Lemma set_induction :
    forall P : t -> Type,
      (forall s, Empty s -> P s) ->
      (forall s s', P s -> forall x, ~In x s -> Add x s s' -> P s') ->
      forall s, P s.
  Proof.
    intros; apply
      (@fold_rec _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto.
  Qed.

  Lemma set_induction_bis :
    forall P : t -> Type,
      (forall s s', s [=] s' -> P s -> P s') ->
      P empty ->
      (forall x s, ~In x s -> P s -> P (add x s)) ->
      forall s, P s.
  Proof.
    intros.
    apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ => tt) tt s);
      eauto.
  Qed.

  (** [fold] can be used to reconstruct the same initial set. *)
  Lemma fold_identity : forall s, fold add s empty [=] s.
  Proof.
    intros.
    apply fold_rec with (P:=fun s acc => acc[=]s); auto with set.
    intros. rewrite H2; rewrite Add_Equal in H1; auto with set.
  Qed.

  (** ** Alternative (weaker) specifications for [fold] *)

  (** When [FSets] was first designed, the order in which Ocaml's [Set.fold]
      takes the set elements was unspecified. This specification reflects
      this fact:
  *)
  Lemma fold_0 :
    forall s (A : Type) (i : A) (f : elt -> A -> A),
      exists l : list elt,
        NoDup l /\
        (forall x : elt, In x s <-> InA x l) /\
        fold f s i = fold_right f i l.
  Proof.
    intros; exists (rev (elements s)); split.
    apply NoDupA_rev; eauto with set.
    split; intros.
    rewrite elements_iff; do 2 rewrite InA_alt.
    split; destruct 1;
      generalize (In_rev (elements s) x0); exists x0; intuition.
    rewrite fold_left_rev_right.
    apply fold_1.
  Qed.

  (** An alternate (and previous) specification for [fold] was based on
      the recursive structure of a set. It is now lemmas [fold_1] and
      [fold_2]. *)
  Lemma fold_1 :
   forall s (A : Type) {eqA : A -> A -> Prop}
     `{st : Equivalence A eqA} (i : A) (f : elt -> A -> A),
   Empty s -> eqA (fold f s i) i.
  Proof.
    unfold Empty; intros; destruct (fold_0 s i f) as (l,(H1, (H2, H3))).
    rewrite H3; clear H3.
    generalize H H2; clear H H2; case l; simpl; intros.
    reflexivity.
    elim (H e).
    elim (H2 e); intuition.
  Qed.

  Lemma fold_2 :
   forall s s' x (A : Type) {eqA : A -> A -> Prop}
     `{st : Equivalence A eqA} (i : A) (f : elt -> A -> A)
     `{Proper _ (_eq ==> eqA ==> eqA) f},
   transpose eqA f ->
   ~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)).
  Proof.
    intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2)));
      destruct (fold_0 s' i f) as (l',(Hl', (Hl'1, Hl'2))).
    rewrite Hl2; rewrite Hl'2; clear Hl2 Hl'2.
    apply fold_right_add with (eqA:=_eq)(eqB:=eqA); auto.
    rewrite <- Hl1; auto.
    intros a; rewrite InA_cons; rewrite <- Hl1; rewrite <- Hl'1;
      rewrite (H2 a); intuition.
  Qed.

  (** In fact, [fold] on empty sets is more than equivalent to
      the initial element, it is Leibniz-equal to it. *)

  Lemma fold_1b :
    forall s (A : Type)(i : A) (f : elt -> A -> A),
      Empty s -> (fold f s i) = i.
  Proof.
    intros.
    rewrite fold_1; auto.
  Qed.

  Section Fold_More.
    Variable A : Type.
    Context `{st : Equivalence A eqA}.
    Variable (f:elt->A->A).
    Context {Comp : Proper (_eq ==> eqA ==> eqA) f}.
    Hypothesis Ass : transpose eqA f.

    Lemma fold_commutes :
      forall i s x, eqA (fold f s (f x i)) (f x (fold f s i)).
    Proof.
      intros.
      apply fold_rel with (R:=fun u v => eqA u (f x v)); intros.
      reflexivity.
      transitivity (f x0 (f x b)); auto; rewrite H0; reflexivity.
    Qed.

    (** ** Fold is a morphism *)
    Lemma fold_init : forall i i' s, eqA i i' -> eqA (fold f s i) (fold f s i').
    Proof.
      intros. apply fold_rel with (R:=eqA); auto.
      intros; rewrite H1; reflexivity.
    Qed.

    Lemma fold_equal :
      forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i).
    Proof.
      intros i s; pattern s; apply set_induction; clear s; intros.
      transitivity i.
      apply fold_1; auto.
      symmetry; apply fold_1; auto.
      rewrite <- H0; auto.
      transitivity (f x (fold f s i)).
      apply (fold_2 (eqA := eqA)); auto.
      symmetry; apply (fold_2 (eqA := eqA)); auto.
      unfold Add in *; intros.
      rewrite <- H2; auto.
    Qed.

    (** ** Fold and other set operators *)

    Lemma fold_empty : forall i, fold f empty i = i.
    Proof.
      intros; apply fold_1b; auto with set.
    Qed.

    Lemma fold_add : forall i s x, ~In x s ->
      eqA (fold f (add x s) i) (f x (fold f s i)).
    Proof.
      intros; apply (fold_2 (st:=st)); auto with set.
    Qed.

    Lemma add_fold :
      forall i s x, In x s -> eqA (fold f (add x s) i) (fold f s i).
    Proof.
      intros; apply fold_equal; auto with set.
    Qed.

    Lemma remove_fold_1 :
      forall i s x, In x s -> eqA (f x (fold f (remove x s) i)) (fold f s i).
    Proof.
      intros.
      symmetry.
      apply (fold_2 (st:=st)); auto with set.
    Qed.

    Lemma remove_fold_2 :
      forall i s x, ~In x s -> eqA (fold f (remove x s) i) (fold f s i).
    Proof.
      intros.
      apply fold_equal; auto with set.
    Qed.

    Lemma fold_union_inter :
      forall i s s',
        eqA (fold f (union s s') (fold f (inter s s') i))
        (fold f s (fold f s' i)).
    Proof.
      intros; pattern s; apply set_induction; clear s; intros.
      transitivity (fold f s' (fold f (inter s s') i)).
      apply fold_equal; auto with set.
      transitivity (fold f s' i).
      apply fold_init; auto.
      apply fold_1; auto with set.
      symmetry; apply fold_1; auto.
      rename s'0 into s''.
      destruct (In_dec x s').
      (* In x s' *)
      transitivity
        (fold f (union s'' s') (f x (fold f (inter s s') i))); auto with set.
      apply fold_init; auto.
      apply (fold_2 (eqA:=eqA)); auto with set.
      rewrite inter_iff; intuition.
      transitivity (f x (fold f s (fold f s' i))).
      transitivity (fold f (union s s') (f x (fold f (inter s s') i))).
      apply fold_equal; auto.
      apply equal_sym; apply union_Equal with x; auto with set.
      transitivity (f x (fold f (union s s') (fold f (inter s s') i))).
      apply fold_commutes; auto.
      apply Comp; auto.
      symmetry; apply (fold_2 (eqA:=eqA)); auto.
      (* ~(In x s') *)
      transitivity (f x (fold f (union s s') (fold f (inter s'' s') i))).
      apply (fold_2 (eqA:=eqA)); auto with set.
      transitivity (f x (fold f (union s s') (fold f (inter s s') i))).
      apply Comp;auto.
      apply fold_init;auto.
      apply fold_equal;auto.
      apply equal_sym; apply inter_Add_2 with x; auto with set.
      transitivity (f x (fold f s (fold f s' i))).
      apply Comp; auto.
      symmetry; apply (fold_2 (eqA:=eqA)); auto.
    Qed.

    Lemma fold_diff_inter :
      forall i s s',
        eqA (fold f (diff s s') (fold f (inter s s') i)) (fold f s i).
    Proof.
      intros.
      transitivity (fold f (union (diff s s') (inter s s'))
        (fold f (inter (diff s s') (inter s s')) i)).
      symmetry; apply fold_union_inter; auto.
      transitivity (fold f s (fold f (inter (diff s s') (inter s s')) i)).
      apply fold_equal; auto with set.
      apply fold_init; auto.
      apply (fold_1 (eqA:=eqA)); auto with set.
    Qed.

    Lemma fold_union :
      forall i s s', (forall x, ~(In x s/\In x s')) ->
        eqA (fold f (union s s') i) (fold f s (fold f s' i)).
    Proof.
      intros.
      transitivity (fold f (union s s') (fold f (inter s s') i)).
      apply fold_init; auto.
      symmetry; apply fold_1; auto with set.
      unfold Empty; intro a; generalize (H a); set_iff; tauto.
      apply fold_union_inter; auto.
    Qed.
  End Fold_More.

  Lemma fold_plus :
   forall s p, fold (fun _ => S) s p = fold (fun _ => S) s 0 + p.
  Proof.
    intros. apply fold_rel with (R:=fun u v => u = v + p); simpl; auto.
  Qed.
End Fold.

(** * Cardinal *)

(** ** Characterization of cardinal in terms of fold *)

Lemma cardinal_fold `{HF : @FSetSpecs elt Helt F} :
  forall s, cardinal s = fold (fun _ => S) s 0.
Proof.
  intros; rewrite cardinal_1; rewrite SetInterface.fold_1; auto.
  symmetry; apply fold_left_length; auto.
Qed.

(** ** Old specifications for [cardinal]. *)

Lemma cardinal_0 `{HF : @FSetSpecs elt Helt F} :
  forall s, exists l : list elt,
    NoDupA _eq l /\
    (forall x : elt, In x s <-> InA _eq x l) /\
    cardinal s = length l.
Proof.
  intros; exists (elements s); intuition.
  apply cardinal_1.
Qed.

Lemma cardinal_1 `{HF : @FSetSpecs elt Helt F} :
  forall s, Empty s -> cardinal s = 0.
Proof.
  intros; rewrite cardinal_fold; apply fold_1; auto.
Qed.

Lemma cardinal_2 `{HF : @FSetSpecs elt Helt F} :
  forall s s' x, ~ In x s -> Add x s s' -> cardinal s' = S (cardinal s).
Proof.
  intros; do 2 rewrite cardinal_fold.
  change S with ((fun _ => S) x).
  apply (fold_2 (eqA:=@eq _)) ; auto.
  repeat intro; vm_compute; congruence.
Qed.

(** ** Cardinal and (non-)emptiness *)

Lemma cardinal_Empty `{HF : @FSetSpecs elt Helt F} :
  forall s, Empty s <-> cardinal s = 0.
Proof.
  intros.
  rewrite elements_Empty, SetInterface.cardinal_1.
  destruct (elements s); intuition; discriminate.
Qed.

Lemma cardinal_inv_1 `{HF : @FSetSpecs elt Helt F} :
  forall s, cardinal s = 0 -> Empty s.
Proof.
  intros; rewrite cardinal_Empty; auto.
Qed.
Hint Resolve @cardinal_inv_1.

Lemma cardinal_inv_2 `{HF : @FSetSpecs elt Helt F} :
  forall s n, cardinal s = S n -> { x : elt | In x s }.
Proof.
  intros; rewrite SetInterface.cardinal_1 in H.
  generalize (elements_2 (s:=s)).
  destruct (elements s); try discriminate.
  exists e; auto.
Qed.

Lemma cardinal_inv_2b `{HF : @FSetSpecs elt Helt F} :
  forall s, cardinal s <> 0 -> { x : elt | In x s }.
Proof.
  intros s;
    generalize (@cardinal_inv_2 _ _ _ _ s); destruct cardinal;
    [intuition|eauto].
Qed.

(** ** Cardinal is a morphism *)

Lemma Equal_cardinal `{HF : @FSetSpecs elt Helt F} :
  forall s s', s[=]s' -> cardinal s = cardinal s'.
Proof.
  symmetry.
  remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H.
  induction n; intros.
  apply cardinal_1; rewrite <- H; auto.
  destruct (cardinal_inv_2 Heqn) as (x,H2).
  revert Heqn.
  rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x)); auto with set.
  rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x)); eauto with set.
Qed.

Instance cardinal_m `{HF : @FSetSpecs elt Helt F} :
  Proper (Equal ==> @eq nat) cardinal.
Proof.
  repeat intro; auto using Equal_cardinal.
Qed.

Hint Resolve @Add_add @Add_remove @Equal_remove @cardinal_inv_1 @Equal_cardinal.

(** ** Cardinal and set operators *)

Lemma empty_cardinal `{HF : @FSetSpecs elt Helt F} :
  cardinal empty = 0.
Proof.
  intros; rewrite cardinal_fold; apply fold_1; auto with set.
Qed.

Hint Immediate @empty_cardinal @cardinal_1 : set.

Lemma singleton_cardinal `{HF : @FSetSpecs elt Helt F} :
  forall x, cardinal (singleton x) = 1.
Proof.
  intros.
  rewrite (singleton_equal_add x).
  replace 0 with (cardinal empty); auto with set.
  apply cardinal_2 with x; auto with set. fsetdec.
Qed.

Hint Resolve @singleton_cardinal: set.

Lemma diff_inter_cardinal `{HF : @FSetSpecs elt Helt F} :
  forall s s', cardinal (diff s s') + cardinal (inter s s') = cardinal s .
Proof.
  intros; do 3 rewrite cardinal_fold.
  rewrite <- fold_plus.
  apply fold_diff_inter with (eqA:=@Logic.eq nat); auto.
  repeat intros; vm_compute; congruence.
Qed.

Lemma union_cardinal `{HF : @FSetSpecs elt Helt F} :
  forall s s', (forall x, ~(In x s/\In x s')) ->
    cardinal (union s s')=cardinal s+cardinal s'.
Proof.
  intros; do 3 rewrite cardinal_fold.
  rewrite <- fold_plus.
  apply (fold_union (eqA:=@eq _)); auto.
  repeat intros; vm_compute; congruence.
Qed.

Lemma subset_cardinal `{HF : @FSetSpecs elt Helt F} :
  forall s s', s[<=]s' -> cardinal s <= cardinal s' .
Proof.
  intros.
  rewrite <- (diff_inter_cardinal s' s).
  rewrite (inter_sym s' s).
  rewrite (inter_subset_equal H); auto with arith.
Qed.

Lemma subset_cardinal_lt `{HF : @FSetSpecs elt Helt F} :
  forall s s' x, s[<=]s' -> In x s' -> ~In x s -> cardinal s < cardinal s'.
Proof.
  intros.
  rewrite <- (diff_inter_cardinal s' s).
  rewrite (inter_sym s' s).
  rewrite (inter_subset_equal H).
  generalize (@cardinal_inv_1 _ _ _ _ (diff s' s)).
  destruct (cardinal (diff s' s)).
  intro H2; destruct (H2 (refl_equal _) x).
  set_iff; auto.
  intros _.
  change (0 + cardinal s < S n + cardinal s).
  apply Plus.plus_lt_le_compat; auto with arith.
Qed.

Theorem union_inter_cardinal `{HF : @FSetSpecs elt Helt F} :
  forall s s', cardinal (union s s') + cardinal (inter s s') =
    cardinal s  + cardinal s' .
Proof.
  intros.
  do 4 rewrite cardinal_fold.
  do 2 rewrite <- fold_plus.
  apply fold_union_inter with (eqA:=@Logic.eq nat); auto.
  repeat intros; vm_compute; congruence.
Qed.

Lemma union_cardinal_inter `{HF : @FSetSpecs elt Helt F} :
  forall s s', cardinal (union s s') =
    cardinal s + cardinal s' - cardinal (inter s s').
Proof.
  intros.
  rewrite <- union_inter_cardinal.
  rewrite Plus.plus_comm.
  auto with arith.
Qed.

Lemma union_cardinal_le `{HF : @FSetSpecs elt Helt F} :
   forall s s', cardinal (union s s') <= cardinal s  + cardinal s'.
Proof.
  intros; generalize (union_inter_cardinal s s').
  intros; rewrite <- H; auto with arith.
Qed.

Lemma add_cardinal_1 `{HF : @FSetSpecs elt Helt F} :
  forall s x, In x s -> cardinal (add x s) = cardinal s.
Proof.
  auto with set.
Qed.

Lemma add_cardinal_2 `{HF : @FSetSpecs elt Helt F} :
  forall s x, ~In x s -> cardinal (add x s) = S (cardinal s).
Proof.
  intros.
  do 2 rewrite cardinal_fold.
  change S with ((fun _ => S) x);
    apply fold_add with (eqA:=@Logic.eq nat); auto.
  repeat intros; vm_compute; congruence.
Qed.

Lemma remove_cardinal_1 `{HF : @FSetSpecs elt Helt F} :
  forall s x, In x s -> S (cardinal (remove x s)) = cardinal s.
Proof.
  intros.
  do 2 rewrite cardinal_fold.
  change S with ((fun _ =>S) x).
  apply remove_fold_1 with (eqA:=@Logic.eq nat); auto.
  repeat intros; vm_compute; congruence.
Qed.

Lemma remove_cardinal_2 `{HF : @FSetSpecs elt Helt F} :
  forall s x, ~In x s -> cardinal (remove x s) = cardinal s.
Proof.
  auto with set.
Qed.

Hint Resolve @subset_cardinal @union_cardinal @add_cardinal_1 @add_cardinal_2.

(** Now comes some properties specific to the element ordering,
   invalid for Weak Sets. *)
(** First, a specialized version of SortA_equivlistA_eqlistA: *)
Lemma sort_equivlistA_eqlistA
  `{HF : @FSetSpecs elt Helt F} :
  forall l l' : list elt, sort _lt l -> sort _lt l' ->
    equivlistA _eq l l' -> eqlistA _eq l l'.
Proof.
  intros; apply SortA_equivlistA_eqlistA with _lt;
    eauto with typeclass_instances.
Qed.

Definition gtb `{Helt : OrderedType elt} (x y : elt) := x >> y.
Definition leb `{Helt : OrderedType elt} (x : elt) :=
  fun y => negb (x >> y).

Definition elements_lt
  `{HF : @FSetSpecs elt Helt F} x s :=
  List.filter (gtb x) (elements s).
Definition elements_ge
  `{HF : @FSetSpecs elt Helt F} x s :=
  List.filter (leb x) (elements s).

Lemma gtb_1 `{Helt : OrderedType elt} : forall x y, gtb x y = true <-> y <<< x.
Proof.
  intros; unfold gtb; destruct (gt_dec x y); intuition;
    try discriminate; order.
Qed.

Lemma leb_1 `{Helt : OrderedType elt} :
  forall x y, leb x y = true <-> ~y <<< x.
Proof.
  intros; unfold leb, gtb; destruct (gt_dec x y); intuition;
    try discriminate; order.
Qed.

Instance gtb_m `{Helt : OrderedType elt} :
  forall x, Proper (_eq ==> @eq bool) (gtb x).
Proof.
  red; intros x a b H.
  unfold gtb; destruct (gt_dec x a); destruct (gt_dec x b);
    auto; rewrite H in H0; contradiction.
Qed.
Corollary gtb_compat `{Helt : OrderedType elt} :
  forall x, compat_bool _eq (gtb x).
Proof.
  repeat intro; rewrite H; reflexivity.
Qed.

Instance leb_m `{Helt : OrderedType elt} :
  forall x, Proper (_eq ==> @eq bool) (leb x).
Proof.
  red; intros x a b H; unfold leb.
  f_equal; apply gtb_m; auto.
Qed.
Corollary leb_compat `{Helt : OrderedType elt} :
  forall x, compat_bool _eq (leb x).
Proof.
  repeat intro; rewrite H; reflexivity.
Qed.
Hint Resolve @leb_compat @gtb_compat.

(* Ltac normalize_notations := *)
(*   match goal with *)
(*  | H : ?R ?x ?y |- _ => *)
(*    progress ((change (x === y) in H) || (change (x <<< y) in H) || *)
(*      (change (x >>> y) in H)); normalize_notations *)
(*  | H : ~(?R ?x ?y) |- _ => *)
(*    progress ((change (x =/= y) in H) || (change (~ x <<< y) in H) || *)
(*      (change (~ y <<< x) in H)); normalize_notations *)
(*  | |- ?R ?x ?y => *)
(*    progress (change (x === y) || change (x <<< y) || change (y <<< x)) *)
(*  | |- ~?R ?x ?y => *)
(*    progress (change (x =/= y) || change (~x <<< y) || change (~y <<< x)) *)
(*  | _ => idtac *)
(*   end. *)

Lemma elements_split
  `{HF : @FSetSpecs elt Helt F} :
  forall x s, elements s = (elements_lt x s ++ elements_ge x s)%list.
Proof.
  unfold elements_lt, elements_ge, leb; intros.
  eapply (@filter_split _ _eq _ _lt); eauto with set typeclass_instances.
  intros; destruct (gt_dec x x0); destruct (gt_dec x y); try discriminate.
  order.
Qed.

Lemma elements_Add
  `{HF : @FSetSpecs elt Helt F} :
  forall s s' x, ~In x s -> Add x s s' ->
    eqlistA _eq (elements s') (elements_lt x s ++ x :: elements_ge x s)%list.
Proof.
  assert (Z : forall x, Proper (_eq ==> eq) (leb x)).
  repeat intro; unfold leb;
    destruct (gt_dec x x0); destruct (gt_dec x y); order.
  assert (Z' : forall x, Proper (_eq ==> eq) (gtb x)).
  repeat intro; unfold gtb;
    destruct (gt_dec x x0); destruct (gt_dec x y); order.
  intros; unfold elements_ge, elements_lt.
  apply sort_equivlistA_eqlistA; auto with set.
  apply (@SortA_app _ _eq); auto.
  apply (@filter_sort _ _eq); auto with set; eauto with set; intros; order.
  constructor; auto.
  apply (@filter_sort _ _eq); auto with set; eauto with set;
    try (intros; order).
  rewrite Inf_alt by
    (apply (@filter_sort _ _eq); eauto with set; intros; order).
  intros; rewrite filter_InA in H1; auto; destruct H1.
  rewrite leb_1 in H2.
  rewrite <- elements_iff in H1.
  assert (x =/= y). intro abs; apply H; rewrite abs; auto. order.
  intros.
  rewrite filter_InA in H1; auto; destruct H1.
  rewrite gtb_1 in H3.
  inversion_clear H2.
  order.
  rewrite filter_InA in H4; auto; destruct H4.
  rewrite leb_1 in H4.
  order.
  red; intros a.
  rewrite InA_app_iff; auto. rewrite InA_cons.
  rewrite !filter_InA; auto.
  do 2 rewrite <- elements_iff.
  rewrite leb_1; rewrite gtb_1.
  rewrite (H0 a); intuition.
  destruct (compare_dec a x); intuition.
  right; right; split; auto.
  order.
Qed.

Definition Above `{HF : @FSetSpecs elt Helt F}
  x s := forall y, In y s -> y <<< x.
Definition Below `{HF : @FSetSpecs elt Helt F}
  x s := forall y, In y s -> x <<< y.

Lemma elements_Add_Above
  `{HF : @FSetSpecs elt Helt F} :
  forall s s' x, Above x s -> Add x s s' ->
    eqlistA _eq (elements s') (elements s ++ x::nil)%list.
Proof.
  intros.
  apply sort_equivlistA_eqlistA; auto with set.
  apply (@SortA_app _ _eq); auto with set.
  intros.
  inversion_clear H2.
  rewrite <- elements_iff in H1.
  apply lt_eq with x; auto.
  inversion H3.
  red; intros a.
  rewrite InA_app_iff; auto; rewrite InA_cons; rewrite InA_nil.
  do 2 rewrite <- elements_iff; rewrite (H0 a); intuition.
Qed.

Lemma elements_Add_Below
  `{HF : @FSetSpecs elt Helt F} :
  forall s s' x, Below x s -> Add x s s' ->
    eqlistA _eq (elements s') (x::elements s).
Proof.
  intros.
  apply sort_equivlistA_eqlistA; auto with set.
  change (sort _lt ((x::nil) ++ elements s)).
  apply (@SortA_app _ _eq); auto with set.
  intros.
  inversion_clear H1.
  rewrite <- elements_iff in H2.
  apply eq_lt with x; auto.
  inversion H3.
  red; intros a.
  rewrite InA_cons.
  do 2 rewrite <- elements_iff; rewrite (H0 a); intuition.
Qed.

(** Two other induction principles on sets: we can be more restrictive
   on the element we add at each step.  *)
Lemma set_induction_max
  `{HF : @FSetSpecs elt Helt F} :
  forall P : set elt -> Type,
    (forall s, Empty s -> P s) ->
    (forall s s', P s -> forall x, Above x s -> Add x s s' -> P s') ->
    forall s, P s.
Proof.
  intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto.
  case_eq (max_elt s); intros.
  apply X0 with (remove e s) e; auto with set.
  apply IHn.
  assert (S n = S (cardinal (remove e s))).
  rewrite Heqn; apply cardinal_2 with e; auto with set.
  inversion H0; auto.
  red; intros.
  rewrite remove_iff in H0; destruct H0.
  generalize (@max_elt_2 _ _ _ _ s e y H H0); order.

  assert (H0:=max_elt_3 H).
  rewrite cardinal_Empty in H0; rewrite H0 in Heqn; inversion Heqn.
Qed.

Lemma set_induction_min
  `{HF : @FSetSpecs elt Helt F} :
  forall P : set elt -> Type,
    (forall s, Empty s -> P s) ->
    (forall s s', P s -> forall x, Below x s -> Add x s s' -> P s') ->
    forall s, P s.
Proof.
  intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto.
  case_eq (min_elt s); intros.
  apply X0 with (remove e s) e; auto with set.
  apply IHn.
  assert (S n = S (cardinal (remove e s))).
   rewrite Heqn; apply cardinal_2 with e; auto with set.
  inversion H0; auto.
  red; intros.
  rewrite remove_iff in H0; destruct H0.
  generalize (@min_elt_2 _ _ _ _ s e y H H0); order.

  assert (H0:=min_elt_3 H).
  rewrite cardinal_Empty in H0; auto; rewrite H0 in Heqn; inversion Heqn.
Qed.

(** More properties of [fold] : behavior with respect to Above/Below *)
Lemma fold_3
  `{HF : @FSetSpecs elt Helt F} :
  forall s s' x (A : Type) (eqA : A -> A -> Prop)
    (st : Equivalence eqA) (i : A)
    (f : elt -> A -> A) `{Proper _ (_eq ==> eqA ==> eqA) f},
    Above x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)).
Proof.
  intros.
  do 2 rewrite SetInterface.fold_1.
  do 2 rewrite <- fold_left_rev_right.
  change (f x (fold_right f i (rev (elements s)))) with
    (fold_right f i (rev (x::nil)++rev (elements s))).
  apply (@fold_right_eqlistA _ _eq A eqA st); auto.
  rewrite <- distr_rev.
  apply eqlistA_rev.
  apply elements_Add_Above; auto.
Qed.

Lemma fold_4
  `{HF : @FSetSpecs elt Helt F} :
  forall s s' x (A : Type) (eqA : A -> A -> Prop)
    (st : Equivalence eqA) (i : A)
    (f : elt -> A -> A) `{Proper _ (_eq ==> eqA ==> eqA) f},
    Below x s -> Add x s s' -> eqA (fold f s' i) (fold f s (f x i)).
Proof.
  intros.
  do 2 rewrite SetInterface.fold_1.
  set (g:=fun (a : A) (e : elt) => f e a).
  change (eqA (fold_left g (elements s') i) (fold_left g (x::elements s) i)).
  unfold g.
  do 2 rewrite <- fold_left_rev_right.
  apply (@fold_right_eqlistA elt _eq A eqA st); auto.
  apply eqlistA_rev.
  apply elements_Add_Below; auto.
Qed.

(** The following results have already been proved earlier, *)
(*    but we can now prove them with one hypothesis less: *)
(*    no need for [(transpose eqA f)]. *)
Section FoldOpt.
  Lemma fold_equal_ord
    `{HF : @FSetSpecs elt Helt F} :
    forall (A : Type) {eqA : A -> A -> Prop}
     `{st : Equivalence A eqA} (i : A) (f : elt -> A -> A)
     `{Proper _ (_eq ==> eqA ==> eqA) f},
     forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i).
  Proof.
    intros; do 2 rewrite SetInterface.fold_1.
    do 2 rewrite <- fold_left_rev_right.
    apply (@fold_right_eqlistA _ _eq A eqA st); auto.
    apply eqlistA_rev.
    apply sort_equivlistA_eqlistA; auto with set.
    red; intro a; do 2 rewrite <- elements_iff; auto.
  Qed.

  Lemma add_fold_ord
    `{HF : @FSetSpecs elt Helt F} :
    forall (A : Type) {eqA : A -> A -> Prop}
     `{st : Equivalence A eqA} (i : A) (f : elt -> A -> A)
     `{Proper _ (_eq ==> eqA ==> eqA) f},
     forall i s x, In x s -> eqA (fold f (add x s) i) (fold f s i).
  Proof.
    intros; apply (fold_equal_ord (st:=st)); auto with set.
  Qed.

  Lemma remove_fold_2_ord
    `{HF : @FSetSpecs elt Helt F} :
    forall (A : Type) {eqA : A -> A -> Prop}
     `{st : Equivalence A eqA} (i : A) (f : elt -> A -> A)
     `{Proper _ (_eq ==> eqA ==> eqA) f},
     forall i s x, ~In x s -> eqA (fold f (remove x s) i) (fold f s i).
  Proof.
    intros; apply (fold_equal_ord (st:=st)); auto with set.
  Qed.
End FoldOpt.

(** An alternative version of [choose_3] *)
Lemma choose_equal
  `{HF : @FSetSpecs elt Helt F} :
  forall s s', Equal s s' ->
  match choose s, choose s' with
    | Some x, Some x' => x === x'
    | None, None => True
    | _, _ => False
  end.
Proof.
  intros s s' H.
  generalize (choose_1 (s:=s))(choose_2 (s:=s))
    (choose_1 (s:=s'))(choose_2 (s:=s'))(choose_3 (s:=s) (s':=s'));
    destruct (choose s); destruct (choose s'); simpl; intuition.
  apply H5 with e; rewrite <-H; auto.
  apply H5 with e; rewrite H; auto.
Qed.

(** * Facts about [For_all] and [Exists]: since these predicates
   quantify over a finite set, they are dual in a classical way when
   they are applied to decidable properties (such as in [for_all]
   and [exists]). *)
Section For_all_Exists.
  Context `{HF : @FSetSpecs elt Helt F}.
  Variable f : elt -> bool.
  Context `{Hf : Proper _ (_eq ==> @eq bool) f}.

  Property For_all_Exists_iff : forall s,
    For_all (fun x => f x = true) s <-> ~ (Exists (fun x => f x = false) s).
  Proof.
    apply set_induction_bis; unfold For_all; unfold Exists; intros;
      split; intros; try intros [w Hw].
    (* morphism *)
    rewrite <- H in Hw.
    apply (proj1 H0); [| exists w; exact Hw].
    intro y; rewrite H; exact (H1 y).
    apply (proj2 H0); [| rewrite H; assumption].
    intros [y Hy]; apply H1; exists y; rewrite <- H; assumption.
    (* init *)
    contradiction (empty_1 (proj1 Hw)).
    contradiction (empty_1 H0).
    (* step *)
    apply (proj1 H0).
    intros; auto with set.
    destruct Hw as [Hw1 Hw2]; exists w; split; auto.
    apply add_3 with x; auto; intro abs.
    rewrite (H1 w) in Hw2; [discriminate | rewrite abs; auto with set].
    rewrite add_iff in H2; destruct H2 as [Hx | Hs].
    rewrite <- Hx; case_eq (f x); auto; intro.
    contradiction H1; exists x; split; [auto with set | assumption].
    apply (proj2 H0); auto.
    intros [w Hw]; apply H1; exists w; intuition (auto with set).
  Qed.

  Property Exists_For_all_iff : forall s,
     Exists (fun x => f x = true) s <-> ~ For_all (fun x => f x = false) s.
  Proof.
    apply set_induction_bis; unfold For_all; unfold Exists; intros;
      split; try intros [w Hw]; try intro Hall.
    (* morphism *)
    rewrite <- H in Hw.
    apply (proj1 H0); [exists w; exact Hw|].
    intro y; rewrite H; exact (Hall y).
    destruct (proj2 H0) as [w Hw].
    intro Z; apply Hall; intros; apply Z; rewrite H; auto.
    exists w; rewrite <- H; auto.
    (* init *)
    contradiction (empty_1 (proj1 Hw)).
    contradiction Hall; intros; contradiction (empty_1 H).
    (* step *)
    apply (proj1 H0).
    destruct Hw as [Hw1 Hw2]; exists w; split; auto.
    apply add_3 with x; auto; intro abs.
    rewrite (Hall w) in Hw2; [discriminate | rewrite abs; auto with set].
    intros; auto with set.
    case_eq (f x); intros.
    exists x; split; auto with set.
    destruct (proj2 H0) as [w Hw].
    intro Z; apply Hall; intros.
    rewrite add_iff in H2; destruct H2; auto. rewrite <- H2; assumption.
    exists w; intuition (auto with set).
  Qed.
End For_all_Exists.

(** * More precise reflexive view of [for_all] and [_exists] than the one
   in [SetFacts] using the duality results above. *)
Section for_all_exists_spec.
  Context `{HF : @FSetSpecs elt Helt F}.
  Variable s : set elt.
  Variable f : elt -> bool.

  CoInductive for_all_spec : bool -> Prop :=
  | for_all_spec_true :
    forall (Htrue : For_all (fun x => f x = true) s), for_all_spec true
  | for_all_spec_false :
    forall w (Hin : In w s) (Hw : f w = false), for_all_spec false.
  CoInductive exists_spec : bool -> Prop :=
  | exists_spec_true :
    forall w (Hin : In w s) (Hw : f w = true), exists_spec true
  | exists_spec_false :
    forall (Hfalse : For_all (fun x => f x = false) s), exists_spec false.

  Context `{Hf : Proper _ (_eq ==> @eq bool) f}.
  Property for_all_dec2 : for_all_spec (for_all f s).
  Proof.
    destruct (@for_all_dec _ _ _ _ s f Hf).
    constructor; assumption.
    set (negf := fun x => negb (f x)).
    assert (Exists (fun x => negf x = true) s).
    rewrite Exists_For_all_iff.
    intro abs; apply Hfalse; repeat intro; generalize (abs x H).
    unfold negf; destruct (f x); auto.
    repeat intro; unfold negf; rewrite H; reflexivity.
    destruct H as [w [Hw1 Hw2]]; constructor 2 with w; auto.
    unfold negf in Hw2; destruct (f w); auto.
  Qed.
  Property exists_dec2 : exists_spec (exists_ f s).
  Proof.
    destruct (@exists_dec _ _ _ _ s f Hf).
    destruct Htrue as [w Hw]; constructor 1 with w; tauto.
    constructor 2.
    repeat intro; case_eq (f x); auto; intros.
    contradiction Hfalse; exists x; tauto.
  Qed.
End for_all_exists_spec.


Require Import Sty Shape Tac.

Lemma shape_dec :
  forall S sh, {shape S = sh} + {shape S <> sh}.
Proof. decide equality. Qed.

Definition shape_prop (sh : Shape) (S : Sty) : Prop :=
  match sh with
  | unitS => S = unit
  | sendS => exists B S', S = send B S'
  | recvS => exists B S', S = recv B S'
  | echoiceS => exists S1 S2, S = echoice S1 S2
  | ichoiceS => exists S1 S2, S = ichoice S1 S2
  | muS => exists X S', S = mu X S'
  | varS => exists X, S = var X
  end
.

Lemma shape_inv_helper S sh (p : shape S = sh) : shape_prop sh S.
Proof. destruct sh; destruct S; simpl; try discriminate; iauto. Qed.

Ltac shape_inv H :=
  let inv S sh p :=
    let H := fresh in
    pose proof (shape_inv_helper S sh p) as H;
    simpl in H;
    try (decompose_ex H);
    rewrite H in *;
    clear H p
  in
    match type of H with
    | shape ?S = ?sh => inv S sh H
    | ?sh = shape ?S => symmetry in H; shape_inv H
    end
.

Ltac shape_inv_auto :=
  match goal with
  | H : shape _ = _ |- _ => shape_inv H
  | H : _ = shape _ |- _ => shape_inv H
  end;
  try shape_inv_auto
.


Unset Positivity Checking.
Inductive BushSenior (A : Type) : Type :=
| E : BushSenior A
| N : A -> BushSenior (BushSenior (BushSenior A)) -> BushSenior A.
Set Positivity Checking.

Arguments E {A}.
Arguments N {A} _ _.

Unset Guard Checking.
Fixpoint map {A B : Type} (f : A -> B) (b : BushSenior A) {struct b} : BushSenior B :=
match b with
| E => E
| N x b' => N (f x) (map (map (map f)) b')
end.

Fixpoint sum (b : BushSenior nat) : nat :=
match b with
| E => 0
| N x b' => x + sum (map sum (map (map sum) b'))
end.

Fixpoint size {A : Type} (b : BushSenior A) {struct b} : nat :=
match b with
| E => 0
| N _ b' => 1 + sum (map sum (map (map size) b'))
end.

Fixpoint nums (n : nat) : BushSenior nat :=
match n with
| 0 => N 0 E
| S n' => N n (map (map nums) (map nums (nums n')))
end.

(* Compute size (nums 8). *)

Set Guard Checking.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                                                                          *)
(* Jean-Francois.Monin@lannion.cnet.fr                                      *)
(* December 1994, Coq V5.10                                                 *)
(*                                                                          *)
(****************************************************************************)
(*                                 cps_Nx.v                                 *)
(****************************************************************************)

(*
   The following primitives  should be used in a section
   beginning with

Load DeclareNx.

*)

Section defcont.

Variable X : Set.
Variable P : Prop.
Variable e : P -> X.

Definition Nxglob (C : Prop) (A : Set) := (C -> P) -> (A -> X) -> X.

Let Nx := Nxglob.

Notation "c \/+ s" := (Nx c s)
  (at level 85, right associativity, format "c  \/+  '/  ' s").

Definition Nx_unit_glob (C : Prop) (A : Set) (a : A) :
  C \/+ A := fun (i : C -> P) (k : A -> X) => k a.

Definition Nx_raise_glob (C : Prop) (A : Set) (c : C) :
  C \/+ A := fun (i : C -> P) (k : A -> X) => e (i c).

Definition Nx_elim_Nx_glob (A A' : Set) (C C' : Prop)
  (f : A -> C' \/+ A') (j : C -> C') (nx : C \/+ A) :
  C' \/+ A' :=
  fun (i : C' -> P) (k : A' -> X) =>
  nx (fun c : C => i (j c)) (fun a : A => f a i k).

Definition Nx_handle_glob (C : Prop) (A : Set) (nx : C \/+ A) :
  (C -> P) -> (A -> X) -> X := nx.

End defcont.


(* Require Import core core_axioms fintype. *)
(* core_axioms can now be removed *)
Require Import core fintype.
Import ScopedNotations.

(* Lemma scons_eta {T} {n : nat} (f : fin (S n) -> T) : *)
(*   f var_zero .: shift >> f = f. *)
(* Proof. fext. intros [x|]; reflexivity.  Qed. *)

Lemma scons_eta' {T} {n : nat} (f : fin (S n) -> T) (x: fin (S n)):
  (f var_zero .: (shift >> f)) x = f x.
Proof.
  destruct x; reflexivity.
Qed.

(* Lemma scons_eta_id {n : nat} : var_zero .: shift = id :> (fin (S n) -> fin (S n)). *)
(* Proof. fext. intros [x|]; reflexivity. Qed. *)

Lemma scons_eta_id' {n : nat} (x: fin (S n)): (var_zero .: shift) x = id x.
Proof. destruct x; reflexivity. Qed.

(* Lemma scons_comp' {T:Type} {U} {m} {s: T} (sigma: fin m -> T) (tau: T -> U) : forall t, ((s .: sigma) >> tau) t = ((tau s) .: (sigma >> tau)) t. *)
(* Proof. *)
(*   intros [x|]. reflexivity. simpl. reflexivity. *)
(* Qed. *)

Lemma scons_comp' {T:Type} {U} {m} {s: T} (sigma: fin m -> T) (tau: T -> U) (t: fin (S m)): ((s .: sigma) >> tau) t = ((tau s) .: (sigma >> tau)) t.
Proof.
  destruct t; reflexivity.
Qed.

(* Lemma scons_comp (T: Type) U {m} (s: T) (sigma: fin m -> T) (tau: T -> U ) : *)
(*   (s .: sigma) >> tau = (tau s) .: (sigma >> tau) . *)
(* Proof. *)
(*   fext. intros [x|]. reflexivity. simpl. reflexivity. *)
(* Qed. *)

(* Lemma scons_p_head X m n (f : fin m -> X) (g : fin n -> X) : *)
(*   (zero_p m >> scons_p m f g) = f. *)
(* Proof. fext. intros z. unfold funcomp. apply scons_p_head'. Qed. *)

(* Lemma scons_p_tail X  m n (f : fin m -> X) (g : fin n -> X) : *)
(*   shift_p m  >> scons_p m f g = g. *)
(* Proof. fext. intros z. unfold funcomp. apply scons_p_tail'. Qed. *)

(* Lemma scons_p_comp {X Y m n} {f : fin m -> X} {g : fin n -> X} {h : X -> Y} : *)
(*   (scons_p m f g) >> h = scons_p m (f >> h) (g >> h). *)
(* Proof. fext. intros z. unfold funcomp. apply scons_p_comp'. Qed. *)

Ltac eta_reduce :=
     repeat match goal with
            | [|- context[(fun x => ?b x)]] => change (fun x => b x) with b
            end.

(** Generic fsimpl tactic: simplifies the above primitives in a goal. *)
Ltac fsimpl :=
  repeat match goal with
         | [|- context[id >> ?f]] => change (id >> f) with f (* AsimplCompIdL *)
         | [|- context[?f >> id]] => change (f >> id) with f (* AsimplCompIdR *)
         | [|- context [id ?s]] => change (id s) with s
         (* we don't use this additional comp *)
         (* | [|- context[comp ?f ?g]] => change (comp f g) with (g >> f) (* AsimplCompIdL *) *)
         | [|- context[(?f >> ?g) >> ?h]] =>
           change ((f >> g) >> h) with (f >> (g >> h)) (* AsimplComp *)

         (* | [|- zero_p >> scons_p ?f ?g] => rewrite scons_p_head *)

         | [|- context[(?s .: ?sigma) var_zero]] => change ((s.:sigma) var_zero) with s
         | [|- context[(?s .: ?sigma) (shift ?m)]] => change ((s.:sigma) (shift m)) with (sigma m)

         | [|- context[idren >> ?f]] => change (idren >> f) with f
         | [|- context[?f >> idren]] => change (f >> idren) with f
         | [|- context[?f >> (?x .: ?g)]] => change (f >> (x .: g)) with g (* f should evaluate to shift *)
         (* the scons should always already be applied to an argument *)
         | [|- context[(?x2 .: (fun x => ?f (shift x))) ?y]] => change ((scons x2 (fun x => f (shift x))) y) with ((scons (f var_zero) (fun x => f (shift x))) y); rewrite (@scons_eta' _ _ f); idtac "scons_eta"
         | [|- context[(?f var_zero .: ?g) ?y]] => change ((scons (f var_zero) g) y) with ((scons (f var_zero) (fun x => f (shift x))) y); rewrite scons_eta'; idtac "scons_eta"
         (* we completely unfold funcomp *)
         (* |[|- _ =  ?h (?f ?s)] => change (h (f s)) with ((f >> h) s) *)
         (* |[|-  ?h (?f ?s) = _] => change (h (f s)) with ((f >> h) s) *)
         | [|- context[(scons ?s ?sigma) >> ?tau]] => rewrite scons_comp'; idtac "scons_comp"; eta_reduce
         | [|- context[scons (@var_zero ?n) shift]] => change (scons (@var_zero n) shift) with (fun x => (scons (@var_zero n) shift) x); rewrite scons_eta_id'; idtac "scons_eta_id"; eta_reduce
         | _ => progress autorewrite with FunctorInstances; idtac "autorewrite"
         end.

(** Generic fsimpl tactic: simplifies the above primitives in the context *)
Ltac fsimplc :=
  repeat match goal with
         | [H: context[id >> ?f] |- _] => change (id >> f) with f in H(* AsimplCompIdL *)
         | [H: context[?f >> id]|- _] => change (f >> id) with f in H(* AsimplCompIdR *)
         | [H: context [id ?s]|- _] => change (id s) with s in H
         | [H: context[comp ?f ?g]|- _] => change (comp f g) with (g >> f) in H (* AsimplCompIdL *)
         | [H: context[(?f >> ?g) >> ?h]|- _] =>
           change ((f >> g) >> h) with (f >> (g >> h)) in H (* AsimplComp *)
         | [H: context[(?s.:?sigma) var_zero]|- _] => change ((s.:sigma) var_zero) with s in H
         | [H: context[(?s.:?sigma) var_zero]|- _] => change ((s.:sigma) var_zero) with s in H
         | [H: context[(?s.:?sigma) (shift ?m)]|- _] => change ((s.:sigma) (shift m)) with (sigma m) in H
                                                                                |[H : context[ _ =  ?h (?f ?s)]|- _] => change (h (f s)) with ((f >> h) s) in H
         (* |[H: context[?h (?f ?s) = _]|- _] => change (h (f s)) with ((f >> h) s) in H *)
         | [H: context[idren >> ?f]|- _] => change (idren >> f) with f in H
         | [H: context[?f >> idren]|- _] => change (f >> idren) with f in H
         | [H: context[?f >> (?x .: ?g)]|- _] =>
           change (f >> (x .: g)) with g in H
         (* | [H: context[?x2 .: shift >> ?f]|- _] => *)
         (*   change x2 with (f var_zero) in H; rewrite (@scons_eta _ _ f) in H *)
         (* | [H: context[?f var_zero .: ?g]|- _] => *)
           (* change g with (shift >> f) in H; rewrite scons_eta in H *)
         (* | _ => first [progress (rewrite scons_comp in * ) | progress (rewrite scons_eta_id in * ) | progress (autorewrite with FunctorInstances in * )] *)
         end.

(** Simplification in both the goal and the context *)
Tactic Notation "fsimpl" "in" "*" :=
  fsimpl; fsimplc.

(* Hint Rewrite @scons_p_comp scons_p_head scons_p_tail : FunctorInstances. *)


Require Import Undecidability.Axioms.EA.
Require Import Undecidability.Shared.Pigeonhole.
Require Import Undecidability.Synthetic.FinitenessFacts.
Require Import Undecidability.Synthetic.reductions Undecidability.Synthetic.truthtables.
Require Import Undecidability.Synthetic.DecidabilityFacts Undecidability.Synthetic.SemiDecidabilityFacts.
Require Import Undecidability.Shared.ListAutomation.
Require Import List Arith.

Import ListNotations ListAutomationNotations.

Definition productive (p : nat -> Prop) := exists f : nat -> nat, forall c, (forall x, W c x -> p x) -> p (f c) /\ ~ W c (f c).

Lemma productive_nonenumerable p :
  productive p -> ~ enumerable p.
Proof.
  intros [f Hf] [c Hc] % W_spec.
  destruct (Hf c) as [H1 % Hc H2].
  eapply Hc. tauto.
Qed.

Lemma K0_productive :
  productive (compl K0).
Proof.
  exists (fun n => n). intros c H.
  specialize (H c). firstorder.
Qed.

Lemma productive_dedekind_infinite p :
  productive p -> dedekind_infinite p.
Proof.
  specialize List_id as [c_l c_spec]. intros [f Hf].
  eapply (weakly_generative_dedekind_infinite). econstructor.
  intros l.
  exists (f (c_l l)). intros Hl. split.
  - specialize (Hf (c_l l)).
    rewrite <- c_spec. eapply Hf.
    intros x. rewrite c_spec. eapply Hl.
  - eapply Hf. intros x. rewrite c_spec. eapply Hl.
Qed.

Lemma productive_subpredicate p :
  productive p ->
  exists q : nat -> Prop, enumerable q /\ dedekind_infinite q /\ (forall x, q x -> p x).
Proof.
  intros H.
  eapply dedekind_infinite_problem.
  eapply productive_dedekind_infinite. eauto.
Qed.

Lemma productive_red p q :
  p ⪯ₘ q -> productive p -> productive q.
Proof.
  intros [f Hf] [g Hg].
  specialize (SMN' f) as [k Hk].
  exists (fun c => f (g (k c))). intros c Hs.
  assert (Hkc : forall x, W (k c) x -> p x) by  (intros; now eapply Hf, Hs, Hk).
  split.
  - now eapply Hf, Hg.
  - intros ?. eapply Hg, Hk; eauto.
Qed.

Lemma many_one_complete_subpredicate p :
  m-complete p ->
  exists q : nat -> Prop, enumerable q /\ dedekind_infinite q /\ (forall x, q x -> compl p x).
Proof.
  intros Hcomp. eapply productive_subpredicate.
  eapply productive_red.
  - eapply red_m_complement. eapply Hcomp. eapply K0_enum.
  - eapply K0_productive.
Qed.

Definition simple (p : nat -> Prop) :=
  semi_decidable p /\ ~ exhaustible (compl p) /\ ~ exists q, semi_decidable q /\ ~ exhaustible q /\ (forall x, q x -> compl p x).

Lemma simple_non_semi_decidable p :
  simple p -> ~ semi_decidable (compl p).
Proof.
  intros (H1 & H2 & H3) H4.
  apply H3. eauto.
Qed.

Lemma simple_undecidable p :
  simple p -> ~ decidable p.
Proof.
  now intros ? ? % decidable_complement % decidable_semi_decidable % simple_non_semi_decidable.
Qed.

Lemma simple_m_incomplete p :
  simple p -> ~ m-complete p.
Proof.
  intros (H1 & H2 & H3) (q & Hq1 & Hq2 & Hq3) % many_one_complete_subpredicate.
  eapply H3. exists q; repeat split; eauto.
  - eapply enumerable_semi_decidable. eapply discrete_nat. eauto.
  - now eapply unbounded_non_finite, dedekind_infinite_unbounded.
Qed.

Lemma non_finite_non_empty {X} (p : X -> Prop) :
  ~ exhaustible p -> ~~ exists x, p x.
Proof.
  intros H1 H2. apply H1. exists []. firstorder.
Qed.

Lemma simple_no_cylinder p :
  (fun '((x, n) : nat * nat) => p x) ⪯₁ p -> ~ simple p.
Proof.
  intros [f [inj_f Hf]] (H1 & H2 & H3). red in Hf.
  apply (non_finite_non_empty _ H2). intros [x0 Hx0].
  apply H3.
  exists (fun x => exists n, x = f (x0, n)). split. 2:split.
  - exists (fun x n => Nat.eqb x (f (x0, n))).
    intros x. split; intros [n H]; exists n; destruct (Nat.eqb_spec x (f (x0, n))); firstorder congruence.
  - eapply unbounded_non_finite, dedekind_infinite_unbounded.
    exists (fun n => f (x0, n)). intros. split. eauto.
    now intros ? [=] % inj_f.
  - intros ? [n ->]. red. now rewrite <- (Hf (x0, n)).
Qed.


Require Import init.

Require Import zorn_real_base.
Require Import zorn_real_arch.
Require Import zorn_real_zorn.
Require Import zorn_real_quotient.

Require Import fraction_base.
Require Import fraction_plus.
Require Import fraction_mult.
Require Import fraction_order.
Require Import set.
Require Import polynomial_base.
Require Import ring_ideal.
Require Import nat.

Global Program Instance real_sup_complete : SupremumComplete le (U := real).
Next Obligation.
    rename H into a.
    rename H1 into Sa.
    destruct H0 as [b b_upper].
    pose (cut x := ¬is_upper_bound le S x).
    assert (cut_in : ∃ a, cut a).
    {
        exists (a - 1).
        intros a_upper.
        specialize (a_upper a Sa).
        rewrite <- le_plus_0_a_b_ba in a_upper.
        apply pos_neg in a_upper.
        rewrite neg_neg in a_upper.
        rewrite <- nlt_le in a_upper.
        apply a_upper.
        exact one_pos.
    }
    assert (cut_out : ∃ b, ¬cut b).
    {
        exists (b + 1).
        unfold cut.
        rewrite not_not.
        intros x Sx.
        specialize (b_upper x Sx).
        apply (trans b_upper).
        rewrite <- le_plus_0_a_b_ba.
        apply one_pos.
    }
    assert (cut_lt : ∀ l u, cut u → l ≤ u → cut l).
    {
        intros l u u_cut lu l_upper.
        apply u_cut.
        intros x Sx.
        specialize (l_upper x Sx).
        exact (trans l_upper lu).
    }
    pose (ZP := zorn_real_plus cut cut_in cut_out cut_lt).
    pose (ZPA := zorn_real_plus_assoc cut cut_in cut_out cut_lt).
    pose (ZPC := zorn_real_plus_comm cut cut_in cut_out cut_lt).
    pose (ZZ := zorn_real_zero cut cut_in cut_out cut_lt).
    pose (ZPZ := zorn_real_plus_lid cut cut_in cut_out cut_lt).
    pose (ZN := zorn_real_neg cut cut_in cut_out cut_lt).
    pose (ZPN := zorn_real_plus_linv cut cut_in cut_out cut_lt).
    pose (ZM := zorn_real_mult cut cut_in cut_out cut_lt).
    pose (ZL := zorn_real_ldist cut cut_in cut_out cut_lt).
    pose (ZMA := zorn_real_mult_assoc cut cut_in cut_out cut_lt).
    pose (ZMC := zorn_real_mult_comm cut cut_in cut_out cut_lt).
    pose (ZE := zorn_real_one cut cut_in cut_out cut_lt).
    pose (ZME := zorn_real_mult_lid cut cut_in cut_out cut_lt).
    pose (ZML := zorn_real_mult_lcancel cut cut_in cut_out cut_lt).
    pose (ZO := zorn_real_order cut cut_in cut_out cut_lt).
    pose (ZOC := zorn_real_order_le_connex cut cut_in cut_out cut_lt).
    pose (ZOA := zorn_real_order_le_antisym cut cut_in cut_out cut_lt).
    pose (ZOT := zorn_real_order_le_trans cut cut_in cut_out cut_lt).
    pose (ZOP := zorn_real_order_le_lplus cut cut_in cut_out cut_lt).
    pose (ZOM := zorn_real_order_le_mult cut cut_in cut_out cut_lt).
    pose (ZOML := zorn_real_order_le_mult_lcancel cut cut_in cut_out cut_lt).
    pose (ZT := zorn_real_quotient_not_trivial cut cut_in cut_out cut_lt).
    pose (ZA := zorn_real_quotient_arch cut cut_in cut_out cut_lt).
    pose (zrq := zorn_real_quotient cut cut_in cut_out cut_lt).
    pose (real_ext := frac zrq).
    pose (real_ext_not_trivial := frac_not_trivial zrq).
    pose (real_ext_plus := frac_plus zrq).
    pose (real_ext_plus_comm := frac_plus_comm zrq).
    pose (real_ext_plus_assoc := frac_plus_assoc zrq).
    pose (real_ext_zero := frac_zero zrq).
    pose (real_ext_plus_lid := frac_plus_lid zrq).
    pose (real_ext_neg := frac_neg zrq).
    pose (real_ext_plus_linv := frac_plus_linv zrq).
    pose (real_ext_mult := frac_mult zrq).
    pose (real_ext_mult_comm := frac_mult_comm zrq).
    pose (real_ext_mult_assoc := frac_mult_assoc zrq).
    pose (real_ext_ldist := frac_ldist zrq).
    pose (real_ext_one := frac_one zrq).
    pose (real_ext_mult_lid := frac_mult_lid zrq).
    pose (real_ext_div := frac_div zrq).
    pose (real_ext_mult_linv := frac_mult_linv zrq).
    pose (real_ext_order := frac_order zrq).
    pose (real_ext_le_connex := frac_le_connex zrq).
    pose (real_ext_le_antisym := frac_le_antisym zrq).
    pose (real_ext_le_trans := frac_le_trans zrq).
    pose (real_ext_le_lplus := frac_le_lplus zrq).
    pose (real_ext_le_mult := frac_le_mult zrq).
    pose (real_ext_arch := frac_arch zrq).
    pose (real_ext_aof := aof_ex real_ext).
    pose (PL := polynomial_ldist real_cring).
    pose proof (real_maximal real_ext_aof) as f_ex.
    cbn in f_ex.
    change (set_type (aof_set real_aof)) with real in f_ex.
    pose (f1 (x : real) := to_polynomial real_cring x).
    pose (f2 (x : polynomial real_cring) := to_qring
                    (zorn_real_ideal cut cut_in cut_out cut_lt) x : zrq).
    pose (f3 (x : zrq) := to_frac zrq x).
    pose (f4 (x : frac zrq) := aof_ex_f x).
    pose (f x := f4 (f3 (f2 (f1 x)))).
    assert (arch_ordered_homo real_aof real_ext_aof f) as f_homo.
    {
        unfold f, f1, f2, f3, f4.
        split; [>|split; [>|split; [>|split]]].
        -   rewrite to_polynomial_zero.
            rewrite to_qring_zero.
            rewrite to_frac_zero.
            reflexivity.
        -   rewrite to_polynomial_one.
            rewrite to_qring_one.
            rewrite to_frac_one.
            reflexivity.
        -   intros x y.
            rewrite to_polynomial_plus.
            rewrite to_qring_plus.
            rewrite to_frac_plus.
            unfold plus at 2; cbn.
            do 2 rewrite aof_ex_f_eq1.
            reflexivity.
        -   intros x y.
            rewrite to_polynomial_mult.
            rewrite to_qring_mult.
            rewrite to_frac_mult.
            unfold mult at 2; cbn.
            do 2 rewrite aof_ex_f_eq1.
            reflexivity.
        -   intros x y xy.
            unfold le; cbn.
            do 2 rewrite aof_ex_f_eq1.
            apply to_frac_le.
            1: exact ZOA.
            1: exact ZOT.
            apply (land (zorn_real_quotient_le _ _ _ _ _ _)).
            apply zorn_real_q_le_to_poly.
            exact xy.
    }
    prove_parts f_ex.
    {
        exists f.
        exact f_homo.
    }
    destruct f_ex as [f5 f5_homo].
    assert (∀ x, x = f5 (f x)) as f_eq.
    {
        intros x.
        assert ((λ x, f5 (f x)) = identity) as f_eq.
        {
            apply arch_ordered_homo_identity.
            apply (arch_ordered_homo_compose real_aof real_ext_aof real_aof).
            -   exact f_homo.
            -   exact f5_homo.
        }
        change x with (identity x) at 1.
        rewrite <- f_eq.
        reflexivity.
    }
    pose (α := f5 (f4 (f3 (f2 (polynomial_x real_cring))))).
    exists α.
    assert (∀ x y, zorn_real_q_le cut cut_in cut_out cut_lt x y →
        f5 (f4 (f3 (f2 x))) ≤ f5 (f4 (f3 (f2 y)))) as f_le.
    {
        intros x y xy.
        rewrite <- (arch_ordered_homo_le _ _ _ f5_homo).
        unfold f4, le; cbn.
        do 2 rewrite aof_ex_f_eq1.
        apply to_frac_le.
        1: exact ZOA.
        1: exact ZOT.
        apply (land (zorn_real_quotient_le _ _ _ _ _ _)).
        exact xy.
    }
    assert (∀ x, ¬is_upper_bound le S x → x ≤ α) as α_ge.
    {
        intros x x_nupper.
        unfold α.
        rewrite (f_eq x).
        apply f_le.
        apply zorn_real_q_le_in.
        exact x_nupper.
    }
    assert (∀ x, is_upper_bound le S x → α ≤ x) as α_le.
    {
        intros x x_upper.
        unfold α.
        rewrite (f_eq x).
        apply f_le.
        apply zorn_real_q_le_out.
        unfold cut.
        rewrite not_not.
        exact x_upper.
    }
    split.
    -   intros x Sx.
        classic_case (is_upper_bound le S x) as [x_upper|x_nupper].
        2: exact (α_ge _ x_nupper).
        classic_contradiction ltq.
        specialize (α_ge ((x + α) / 2)).
        prove_parts α_ge.
        {
            intros upper.
            specialize (upper x Sx).
            rewrite rdist in upper.
            rewrite le_plus_rlmove in upper.
            rewrite <- (plus_half x) in upper at 2.
            rewrite plus_llinv in upper.
            apply le_mult_rcancel_pos in upper.
            2: apply div_pos; exact two_pos.
            contradiction.
        }
        rewrite rdist in α_ge.
        rewrite le_plus_lrmove in α_ge.
        rewrite <- (plus_half α) in α_ge at 1.
        rewrite plus_rrinv in α_ge.
        apply le_mult_rcancel_pos in α_ge.
        2: apply div_pos; exact two_pos.
        contradiction.
    -   intros y y_upper.
        apply α_le.
        exact y_upper.
Qed.


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

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


(*** Tactics for manipulating polynomial equations *)
Require Coq.nsatz.Nsatz.
Require Import Coq.Lists.List.

Generalizable All Variables.
Lemma cring_sub_diag_iff {R zero eq sub} `{cring:Cring.Cring (R:=R) (ring0:=zero) (ring_eq:=eq) (sub:=sub)}
  : forall x y, eq (sub x y) zero <-> eq x y.
Proof.
  split;intros Hx.
  { eapply Nsatz.psos_r1b. eapply Hx. }
  { eapply Nsatz.psos_r1. eapply Hx. }
Qed.

Ltac get_goal := lazymatch goal with |- ?g => g end.

Ltac nsatz_equation_implications_to_list eq zero g :=
  lazymatch g with
  | eq ?p zero => constr:(p::nil)
  | eq ?p zero -> ?g => let l := nsatz_equation_implications_to_list eq zero g in constr:(p::l)
  end.

Ltac nsatz_reify_equations eq zero :=
  let g := get_goal in
  let lb := nsatz_equation_implications_to_list eq zero g in
  lazymatch (eval red in (Ncring_tac.list_reifyl (lterm:=lb))) with
    (?variables, ?le) =>
    lazymatch (eval compute in (List.rev le)) with
    | ?reified_goal::?reified_givens => constr:((variables, reified_givens, reified_goal))
    end
  end.

Ltac nsatz_get_free_variables reified_package :=
  lazymatch reified_package with (?fv, _, _) => fv end.

Ltac nsatz_get_reified_givens reified_package :=
  lazymatch reified_package with (_, ?givens, _) => givens end.

Ltac nsatz_get_reified_goal reified_package :=
  lazymatch reified_package with (_, _, ?goal) => goal end.

Require Import Coq.setoid_ring.Ring_polynom.
(* Kludge for 8.4/8.5 compatibility *)
Module Import mynsatz_compute.
  Import Nsatz.
  Global Ltac mynsatz_compute x := nsatz_compute x.
End mynsatz_compute.
Ltac nsatz_compute x := mynsatz_compute x.

Ltac nsatz_compute_to_goal sugar nparams reified_goal power reified_givens :=
  nsatz_compute (PEc sugar :: PEc nparams :: PEpow reified_goal power :: reified_givens).

Ltac nsatz_compute_get_leading_coefficient :=
  lazymatch goal with
    |- Logic.eq ((?a :: _ :: ?b) :: ?c) _ -> _ => a
  end.

Ltac nsatz_compute_get_certificate :=
  lazymatch goal with
    |- Logic.eq ((?a :: _ :: ?b) :: ?c) _ -> _ => constr:((c,b))
  end.

Ltac nsatz_rewrite_and_revert domain :=
  lazymatch type of domain with
  | @Integral_domain.Integral_domain ?F ?zero _ _ _ _ _ ?eq ?Fops ?FRing ?FCring =>
    lazymatch goal with
    | |- eq _ zero => idtac
    | |- eq _ _ => rewrite <-(cring_sub_diag_iff (cring:=FCring))
    end;
    repeat match goal with
           | [H : eq _ zero |- _ ] => revert H
           | [H : eq _ _ |- _ ] => rewrite <-(cring_sub_diag_iff (cring:=FCring)) in H; revert H
           end
  end.

(** As per https://coq.inria.fr/bugs/show_bug.cgi?id=4851, [nsatz]
    cannot handle duplicate hypotheses.  So we clear them. *)
Ltac nsatz_clear_duplicates_for_bug_4851 domain :=
  lazymatch type of domain with
  | @Integral_domain.Integral_domain _ _ _ _ _ _ _ ?eq _ _ _ =>
    repeat match goal with
           | [ H : eq ?x ?y, H' : eq ?x ?y |- _ ] => clear H'
           end
  end.

Ltac nsatz_nonzero :=
  try solve [apply Integral_domain.integral_domain_one_zero
            |apply Integral_domain.integral_domain_minus_one_zero
            |trivial
            |assumption].

Ltac nsatz_domain_sugar_power domain sugar power :=
  let nparams := constr:(BinInt.Zneg BinPos.xH) in (* some symbols can be "parameters", treated as coefficients *)
  lazymatch type of domain with
  | @Integral_domain.Integral_domain ?F ?zero _ _ _ _ _ ?eq ?Fops ?FRing ?FCring =>
    nsatz_clear_duplicates_for_bug_4851 domain;
    nsatz_rewrite_and_revert domain;
    let reified_package := nsatz_reify_equations eq zero in
    let fv := nsatz_get_free_variables reified_package in
    let interp := constr:(@Nsatz.PEevalR _ _ _ _ _ _ _ _ Fops fv) in
    let reified_givens := nsatz_get_reified_givens reified_package in
    let reified_goal := nsatz_get_reified_goal reified_package in
    nsatz_compute_to_goal sugar nparams reified_goal power reified_givens;
    let a := nsatz_compute_get_leading_coefficient in
    let crt := nsatz_compute_get_certificate in
    intros _ (* discard [nsatz_compute] output *); intros;
    apply (fun Haa refl cond => @Integral_domain.Rintegral_domain_pow _ _ _ _ _ _ _ _ _ _ _ domain (interp a) _ (BinNat.N.to_nat power) Haa (@Nsatz.check_correct _ _ _ _ _ _ _ _ _ _ FCring fv reified_givens (PEmul a (PEpow reified_goal power)) crt refl cond));
    [ nsatz_nonzero; cbv iota beta delta [Nsatz.PEevalR PEeval InitialRing.gen_phiZ InitialRing.gen_phiPOS]
    | solve [vm_compute; exact (eq_refl true)] (* exact_no_check (eq_refl true) *)
    | solve [repeat (split; [assumption|]); exact I] ]
  end.

Ltac nsatz_guess_domain :=
  match goal with
  | |- ?eq _ _ => constr:(_:Integral_domain.Integral_domain (ring_eq:=eq))
  | |- not (?eq _ _) =>  constr:(_:Integral_domain.Integral_domain (ring_eq:=eq))
  | [H: ?eq _ _ |- _ ] =>  constr:(_:Integral_domain.Integral_domain (ring_eq:=eq))
  | [H: not (?eq _ _) |- _] =>  constr:(_:Integral_domain.Integral_domain (ring_eq:=eq))
  end.

Ltac nsatz_sugar_power sugar power :=
  let domain := nsatz_guess_domain in
  nsatz_domain_sugar_power domain sugar power.

Ltac nsatz_power power :=
  let power_N := (eval compute in (BinNat.N.of_nat power)) in
  nsatz_sugar_power BinInt.Z0 power_N.

Ltac nsatz := nsatz_power 1%nat.

Tactic Notation "nsatz" := nsatz.
Tactic Notation "nsatz" constr(n) := nsatz_power n.

(** If the goal is of the form [?x <> ?y] and assuming [?x = ?y]
    contradicts any hypothesis of the form [?x' <> ?y'], we turn this
    problem about inequalities into one about equalities and give it
    to [nsatz]. *)
Ltac nsatz_contradict_single_hypothesis domain :=
  lazymatch type of domain with
  | @Integral_domain.Integral_domain _ ?zero ?one _ _ _ _ ?eq ?Fops ?FRing ?FCring =>
    unfold not in *;
    match goal with
    | [ H : eq _ _ -> False |- eq _ _ -> False ]
      => intro; apply H; nsatz
    | [ H : eq _ _ -> False |- False ]
      => apply H; nsatz
    end
  end.

Ltac nsatz_contradict :=
  let domain := nsatz_guess_domain in
  nsatz_contradict_single_hypothesis domain
  || (unfold not;
      intros;
      lazymatch type of domain with
      | @Integral_domain.Integral_domain _ ?zero ?one _ _ _ _ ?eq ?Fops ?FRing ?FCring =>
        assert (eq one zero) as Hbad;
        [nsatz; nsatz_nonzero
        |destruct (Integral_domain.integral_domain_one_zero (Integral_domain:=domain) Hbad)]
      end).


(**
This file is part of the Elfic library

Copyright (C) Boldo, Clément, Leclerc

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

From Coq Require Import
    Utf8
    ssreflect

    Rdefinitions
    RIneq
    Rbasic_fun
    Lia
    Lra
.

From Coquelicot Require Import
    Hierarchy
    Rbar
.

Require Import
    hierarchy_notations
    simpl_fun
    sigma_algebra
    measurable_fun
    series
    R_compl
.

Open Scope nat_scope.
Open Scope R_scope.

(*
Dans cette première section, je reprend exactement le code de Coquelicot où
je retire les existentiels pour obtenir des preuves constructives.
*)

Section filterlim_complete_constr.

    Context {T : Type}.
    Context {U : CompleteSpace}.

    Lemma filterlim_locally_closely_correct :
        forall {F} {FF : ProperFilter F} (f : T -> U),
            filterlim (fun x => (f (fst x), f (snd x))) (filter_prod F F) closely ->
            filterlim f F (locally (lim (filtermap f F))).
    Proof.
        intros F FF f H.
        intros P [eps HP].
        refine (_ (complete_cauchy (filtermap f F) _ _ eps)).
        + now apply filter_imp.
        + apply cauchy_distance'.
        apply filter_le_trans with (2 := H).
        apply prod_filtermap_le.
    Qed.

    Lemma filterlim_locally_cauchy_correct :
        forall {F} {FF : ProperFilter F} (f : T -> U),
            (forall eps : posreal, exists P, F P /\ forall u v : T, P u -> P v -> ball (f u) eps (f v)) ->
            filterlim f F (locally (lim (filtermap f F))).
    Proof.
        intros F FF f H.
        apply (filterlim_locally_closely_correct f).
        apply filterlim_closely => //.
    Qed.

End filterlim_complete_constr.

Definition Cauchy_seq {S : UniformSpace} (u : nat -> S) : Prop :=
    ∀ ɛ : R, ɛ > 0 -> ∃ n : nat, ∀ p q : nat,
        p ≥ n -> q ≥ n -> ball (u p) ɛ (u q).

Section Cauchy_lim_seq_def.

    Context {S : CompleteSpace}.

    Definition lim_seq (u : nat -> S) :=
        lim (filtermap u eventually).

    Lemma lim_seq_ext :
        ∀ u u' : nat -> S,
            (∀ n : nat, u n = u' n) -> ∀ l : S,
            filterlim u eventually (locally l) -> filterlim u' eventually (locally l).
    Proof.
        move => u u' Huu' l Hl.
        apply filterlim_ext with u => //.
    Qed.

    Lemma filterlim_cauchy_seq_correct :
        ∀ u : nat → S,
            (∀ eps : posreal, ∃ P, eventually P ∧ ∀ p q : nat, P p → P q → ball (u p) eps (u q))
            -> filterlim u eventually (locally (lim_seq u)).
    Proof.
        move => u Hu.
        apply filterlim_locally_cauchy_correct => //.
    Qed.

    Lemma Cauchy_seq_eventually {u : nat -> S} :
        Cauchy_seq u -> (∀ eps : posreal, ∃ P, eventually P ∧ ∀ p q : nat, P p → P q → ball (u p) eps (u q)).
    Proof.
        unfold Cauchy_seq => Hu ɛ.
        case: ɛ => ɛ Pɛ.
        pose Pɛ' := Rlt_gt _ _ Pɛ; clearbody Pɛ'.
        case: (Hu ɛ Pɛ') => N HuN.
        exists (fun n => n ≥ N); split => //.
        exists N => //.
    Qed.

    Lemma is_filterlim_Cauchy_lim_seq :
        ∀ (u : nat -> S), Cauchy_seq u ->
            filterlim u eventually (locally (lim_seq u)).
    Proof.
        move => u /Cauchy_seq_eventually π.
        apply (filterlim_cauchy_seq_correct u π).
    Qed.

End Cauchy_lim_seq_def.

Section lim_seq_prop.

    Context {S : UniformSpace}.
    Context {T : UniformSpace}.

    Lemma lim_seq_cte :
        ∀ s : S,
        filterlim (fun _ : nat => s) eventually (locally s).
    Proof.
        move => s.
        apply filterlim_const.
    Qed.

    Lemma lim_seq_continuity :
        ∀ f : S -> T, ∀ s : S,
        filterlim f (locally s) (locally (f s))
            -> ∀ u : nat -> S,
            filterlim u eventually (locally s) -> filterlim (fun n => f (u n)) eventually (locally (f s)).
    Proof.
        move => f s Hf u Hu.
        apply filterlim_comp with (locally s) => //.
    Qed.

    Lemma lim_seq_pair :
        ∀ u : nat -> S, ∀ v : nat -> T, ∀ lu : S, ∀ lv : T,
            filterlim u eventually (locally lu) ->
            filterlim v eventually (locally lv) ->
            filterlim (fun n => (u n, v n)) eventually (filter_prod (locally lu) (locally lv)).
    Proof.
        move => u v lu lv Hu Hv.
        apply filterlim_pair => //.
    Qed.

End lim_seq_prop.

Definition NM_Cauchy_seq {A : AbsRing} {E : NormedModule A} (u : nat -> E) : Prop :=
    ∀ ɛ : R, ɛ > 0 -> ∃ n : nat, ∀ p q : nat,
        p ≥ n -> q ≥ n -> ball_norm (u p) ɛ (u q).

Section NM_Cauchy_lim_seq_def.

    Context {A : AbsRing}.
    Context {E : CompleteNormedModule A}.

    Lemma NM_Cauchy_seq_Cauchy_seq :
        ∀ u : nat -> E, NM_Cauchy_seq u -> Cauchy_seq u.
    Proof.
        move => u.
        unfold NM_Cauchy_seq, Cauchy_seq.
        move => Hnorm ɛ Hɛ.
        case: (Hnorm ɛ Hɛ).
        move => N Hn.
        exists N => p q Hp Hq.
        pose HnormNpq := Hn p q Hp Hq; clearbody HnormNpq.
        apply: norm_compat1 => //.
    Qed.

    Lemma NM_Cauchy_seq_lim_seq_correct :
        ∀ (u : nat -> E), ∀ (π : NM_Cauchy_seq u),
            is_lim_seq u (lim_seq u).
    Proof.
        move => u /NM_Cauchy_seq_Cauchy_seq π.
        apply: is_filterlim_Cauchy_lim_seq => //.
    Qed.

    Lemma NM_is_lim_seq_unique :
        ∀ u : nat -> E, ∀ l l' : E,
            is_lim_seq u l -> is_lim_seq u l' -> l = l'.
    Proof.
        move => u l l' Hl Hl';
            unfold is_lim_seq in Hl;
            unfold is_lim_seq in Hl'.
        pose H := filterlim_locally_unique u l l'.
        pose H' := H eventually (Proper_StrongProper _ eventually_filter);
            clearbody H'.
        apply H' => //.
    Qed.

    Lemma lim_seq_eq :
        ∀ u : nat -> E, ∀ l : E,
            is_lim_seq u l -> lim_seq u = l.
    Proof.
        move => u l Hl.
        assert (is_lim_seq u (lim_seq u)).
            apply NM_Cauchy_seq_lim_seq_correct.
            unfold NM_Cauchy_seq => ɛ Hɛ.
            move: Hl => /filterlim_locally_ball_norm => Hl.
            pose sighalfɛ := RIneq.mkposreal (ɛ * /2) (R_compl.Rmult_lt_pos_pos_pos _ _ (RIneq.Rgt_lt _ _ Hɛ) RIneq.pos_half_prf).
            case: (Hl sighalfɛ) => N /= HN; clear Hl.
            exists N => p q Hp Hq; replace ɛ with (ɛ*/2 + ɛ*/2)
                by rewrite Rlimit.eps2 => //.
            apply ball_norm_triangle with l.
            apply (ball_norm_sym l (u p) sighalfɛ) => /=.
            1, 2 : apply HN => //.
        apply (NM_is_lim_seq_unique u) => //.
    Qed.

End NM_Cauchy_lim_seq_def.

Section NM_lim_seq_prop.

    Open Scope hy_scope.
    Open Scope fun_scope.

    Lemma is_lim_seq_epsilon {A : AbsRing} {E : NormedModule A} :
        ∀ u : nat -> E, ∀ l : E,
            is_lim_seq u l <->
            (∀ ɛ : R, 0 < ɛ -> ∃ N : nat, ∀ n : nat, N ≤ n -> (‖ minus (u n) l ‖%hy < ɛ)%R).
    Proof.
        move => u l; split.
        unfold is_lim_seq, filterlim, eventually.
        move => H.
        assert (filter_le
        (filtermap u (λ P : nat → Prop, ∃ N : nat, ∀ n : nat, N ≤ n → P n))
        (locally_norm l)).
        apply filter_le_trans with (locally l) => //.
        apply locally_le_locally_norm.
        clear H => ɛ Hɛ.
        unfold filter_le, filtermap, locally_norm in H0.
        assert (∃ η : posreal, ∀ y : E, ball_norm l η y -> ball_norm l ɛ y).
        exists (RIneq.mkposreal ɛ Hɛ) => //.
        case: (H0 _ H) => N HN.
        exists N; unfold ball_norm in HN.
        assumption.
        move => Hloc.
        unfold is_lim_seq, filterlim, eventually.
        suff: (filter_le (filtermap u (λ P : nat → Prop, ∃ N : nat, ∀ n : nat, N ≤ n → P n))
        (locally_norm l)).
        move => H.
        apply filter_le_trans with (locally_norm l) => //.
        apply locally_norm_le_locally.
        unfold locally_norm, filter_le, filtermap.
        move => P; case; case => ɛ Hɛ Hloc'.
        case: (Hloc ɛ Hɛ) => N HN.
        exists N => n; move => /HN/Hloc'//.
    Qed.

    Context {A : AbsRing}.
    Context {E : NormedModule A}.

    Lemma lim_seq_plus :
        ∀ u v : nat -> E, ∀ lu lv : E,
            is_lim_seq u lu -> is_lim_seq v lv ->
                is_lim_seq (u + v) (lu + lv)%hy.
    Proof.
        move => u v lu lv Hu Hv.
        apply
            (filterlim_comp
                nat (E * E) E
                (fun n : nat => (u n, v n)) (fun c : E * E => fst c + snd c)%hy
                eventually (filter_prod (locally lu) (locally lv)) (locally (lu + lv)%hy)
            ).
        apply lim_seq_pair => //.
        apply filterlim_plus.
    Qed.

    Lemma lim_seq_scal :
        ∀ a : nat -> A, ∀ u : nat -> E, ∀ la : A, ∀ lu : E,
            is_lim_seq a la -> is_lim_seq u lu ->
                is_lim_seq (fun n : nat => (a n) ⋅ (u n))%hy (la ⋅ lu)%hy.
    Proof.
        move => a u la lu Ha Hu.
        apply
            (filterlim_comp
                nat (A * E) E
                (fun n : nat => (a n, u n)) (fun c : A * E => (fst c) ⋅ (snd c))%hy
                eventually (filter_prod (locally la) (locally lu)) (locally (la ⋅ lu)%hy)
            ).
        apply lim_seq_pair => //.
        apply filterlim_scal.
    Qed.

    Lemma lim_seq_scal_r :
        ∀ a : A, ∀ u : nat -> E, ∀ lu : E,
            is_lim_seq u lu ->
                is_lim_seq (a ⋅ u) (a ⋅ lu)%hy.
    Proof.
        move => a u lu Hu.
        apply (lim_seq_continuity (fun x : E => a ⋅ x)%hy) => //.
        apply filterlim_scal_r.
    Qed.

    Lemma lim_seq_scal_l :
        ∀ a : nat -> A, ∀ u : E, ∀ la : A,
            is_lim_seq a la ->
                is_lim_seq (fun n => a n ⋅ u)%hy (la ⋅ u)%hy.
    Proof.
        move => a u la Ha.
        apply (lim_seq_continuity (fun b : A => b ⋅ u)%hy) => //.
        apply filterlim_scal_l.
    Qed.

    Lemma lim_seq_opp :
        ∀ u : nat -> E, ∀ lu : E,
            is_lim_seq u lu ->
                is_lim_seq (fun n : nat => opp (u n)) (opp lu).
    Proof.
        move => u lu Hu.
        apply (lim_seq_continuity (fun x : E => opp x)) => //.
        apply filterlim_opp.
    Qed.

    Lemma lim_seq_mult :
        ∀ a b : nat -> A, ∀ la lb : A,
        is_lim_seq a la -> is_lim_seq b lb ->
            is_lim_seq (fun n => (a n) * (b n)) (la * lb)%hy.
    Proof.
        move => a b la lb Ha Hb.
        apply
            (filterlim_comp
                nat (A * A) A
                (fun n : nat => (a n, b n)) (fun c : A * A => fst c * snd c)%hy
                eventually (filter_prod (locally la) (locally lb)) (locally (la * lb)%hy)
            ).
        apply lim_seq_pair => //.
        apply filterlim_mult.
    Qed.

    Lemma lim_seq_norm :
        ∀ u : nat -> E, ∀ lu : E,
        is_lim_seq u lu -> is_lim_seq (‖ u ‖)%fn (‖ lu ‖)%hy.
    Proof.
        move => u lu Hu.
        apply (lim_seq_continuity (fun x : E => norm x)) => //.
        apply filterlim_norm.
    Qed.

    Lemma lim_seq_norm_zero :
        ∀ u : nat -> E,
        is_lim_seq (‖u‖)%fn 0 -> is_lim_seq u zero.
    Proof.
        move => u Hu.
        apply filterlim_norm_zero => //.
    Qed.

    Lemma lim_seq_power :
        ∀ p : posreal, ∀ u : nat -> R, (∀ n : nat, 0 <= u n) -> ∀ l : R,
        is_lim_seq u l -> is_lim_seq (u ^ p) (Rpow l p).
    Proof.
        move => p u u_pos l Hu.
        unfold fun_power, Rpow.
        assert (0 <= l) as l_pos.
            assert (Lim_seq.is_lim_seq u (Rbar.Finite l)) as Hu' by easy.
            suff: Rbar.Rbar_le (Rbar.Finite 0) (Rbar.Finite l).
            simpl => //.
            apply Lim_seq.is_lim_seq_le with (fun _ => 0) u.
            assumption.
            apply lim_seq_cte.
            assumption.
        case: (Req_EM_T l 0); swap 1 2.
        move => H.
        suff: (Lim_seq.is_lim_seq (λ x : nat,
        match Req_EM_T (u x) 0 with | left _ => 0 | right _ => Rtrigo_def.exp (p * Rpower.ln (u x)) end)
        (Rbar.Finite (Rtrigo_def.exp (p * Rpower.ln l)))).
        easy.
        apply Lim_seq.is_lim_seq_ext_loc with (fun n => Rtrigo_def.exp (p * Rpower.ln (u n))).
        assert (0 < l) as l_stpos by lra.
        pose sigl := {| RIneq.pos := l; RIneq.cond_pos := l_stpos |}.
        move: Hu => /is_lim_seq_epsilon Hu.
        case: (Hu sigl) => //.
        move => N HN; exists N => n /HN.
        unfold norm => /=; unfold abs => /=.
        unfold minus, plus, opp => /=/Rcomplements.Rabs_lt_between'.
        move => [Hul _]; rewrite Rminus_eq_0 in Hul.
        case: (Req_EM_T (u n) 0); lra.
        apply: filterlim_comp.
        2 : apply: ElemFct.continuous_exp.
        suff: (Lim_seq.is_lim_seq (λ x : nat, (p * Rpower.ln (u x))%R) (Rbar_mult p (Rpower.ln l))%R).
        easy.
        apply Lim_seq.is_lim_seq_scal_l.
        apply: filterlim_comp.
        exact Hu.
        apply ElemFct.continuous_ln.
        lra.

        move => Eql0; rewrite Eql0 in Hu.
        apply is_lim_seq_epsilon => ɛ Hɛ.
        move: ElemFct.is_lim_exp_m.
        unfold Continuity.is_lim, filterlim, filter_le, filtermap,
            Rbar_locally, Rbar_locally', locally => Hexp.
        move: ElemFct.is_lim_ln_0.
        unfold Continuity.is_lim, filterlim, filter_le, filtermap,
            Rbar_locally, Rbar_locally', at_right, within, locally => Hln.
            assert ((∃ eps : posreal, ∀ y : R_UniformSpace, ball 0 eps y → ball 0 ɛ y)) as Hballɛ.
            exists (RIneq.mkposreal ɛ Hɛ); easy.
            case: (Hexp _ Hballɛ) => M HM; clear Hballɛ.
            assert (∃ M' : R, ∀ x : R, x < M' → x < M*/p) as HMloc.
            exists (M*/p) => //.
            case: (Hln _ HMloc) => sigη Hη; clear HMloc.
        unfold is_lim_seq, filterlim, eventually, filter_le, filtermap, locally in Hu.
        assert (∃ eps : posreal, ∀ y : R_NormedModule, ball 0 eps y → ball 0 sigη y) as Hballη.
        exists sigη => //.
        case: (Hu _ Hballη) => N HN; clear Hballη.
        exists N => n /HN/Hη Hun.
        case: (Req_EM_T (u n) 0).
        move => _; rewrite minus_eq_zero.
        rewrite norm_zero //.
        move => Nequn0.
        assert (Rpower.ln (u n) < M * / p).
        apply Hun; pose Hun' := u_pos n; lra.
        assert (p * Rpower.ln (u n) < M).
        replace M with (p.(RIneq.pos) * (M * /p.(RIneq.pos))).
        all : swap 1 2.
        setoid_rewrite Rmult_comm.
        rewrite Rmult_assoc.
        rewrite Raxioms.Rinv_l.
        rewrite Rmult_1_r => //.
        case p => p' Hp' /=; lra.
        unfold mult => /=.
        apply Rmult_lt_compat_l.
        case p => p' Hp' /=; lra.
        assumption.
        clear H; move: H0 => /HM//.
    Qed.

    Lemma lim_seq_bounded :
        ∀ u : nat -> E,
            (∃ lu : E, is_lim_seq u lu)
            -> { M : R | ∀ n : nat, (‖ u n ‖)%hy <= M }.
    Proof.
        move => u Hu.
        apply filterlim_bounded => //.
    Qed.

    Lemma measurable_fun_lim_seq {X : Set} {gen : (X -> Prop) -> Prop} :
        ∀ s : nat -> X -> E, (∀ n : nat, measurable_fun gen open (s n)) ->
        ∀ f : X -> E,
            (∀ x : X, is_lim_seq (fun n => s n x) (f x))
            -> measurable_fun gen open f.
    Proof.
        move => s Hs f Hf.
        suff: (∀ U : E -> Prop, open U -> measurable gen (λ x : X, U (f x))).
            move => H P HP.
            induction HP.
            move: H0 => /H//.
            apply measurable_empty.
            apply measurable_compl => //.
            apply measurable_union_countable => //.
            move => U HU.
        pose Ω := fun r : nat => (fun x : E => ∃ d : R, ( / (INR r + 1)) < d ∧ (∀ y : E, U y ∨ (‖ minus x y ‖%hy > d))).
        assert (∀ x : X, (∃ r : nat, Ω r (f x)) ↔ U (f x)) as Decomp.
            move => x; split.
            case => r; unfold Ω; case => [d [Hlt H]].
            case (H (f x)) => //.
            rewrite minus_eq_zero norm_zero => Abs.
            apply False_ind.
            assert (0 < /(INR r + 1)).
            apply RiemannInt.RinvN_pos.
            apply (Rlt_asym _ _ H0) => //.
            apply Rlt_trans with d => //.
            move => Ufx.
            unfold open in HU.
            move: (HU (f x) Ufx) => /locally_norm_le_locally.
            case; move => [ɛ Hɛ] Hloc.
            assert (0 < ɛ*/2) as Hhalfɛ by lra.
            case: (Rtrigo_def.archimed_cor1 (ɛ*/2) Hhalfɛ).
            move => m' [Hm'0 Hm'1].
            assert (m' = (m' - 1) + 1)%nat by lia.
            pose m := (m' - 1)%nat.
            fold m in H; rewrite H in Hm'0.
            replace (m + 1)%nat with (S m) in Hm'0 by lia.
            rewrite RIneq.S_INR in Hm'0.
            clear H; clearbody m; clear Hm'1 m'.
            exists m.
            exists (ɛ*/2); split => //.
            move => y.
            case: (ball_norm_dec (f x) y {| pos := ɛ; cond_pos := Hɛ |}).
                move => /Hloc; left => //.
                move => /Rnot_gt_le/=H; right.
                apply Rlt_gt, RIneq.Rlt_le_trans with ɛ => //.
                apply Rlimit.Rlt_eps2_eps => //.
                rewrite <-norm_opp, opp_minus => //.
        apply measurable_ext with (fun x => ∃ r : nat, Ω r (f x)).
        exact Decomp.
        apply measurable_ext with (fun x => ∃ r : nat, ∃ m : nat, ∀ n : nat, m ≤ n -> Ω r (s n x)).
            move => x; split.
            case => r; case => m H.
            apply Decomp.
            unfold Ω in H.
            unfold is_lim_seq in Hf.
            pose sigr := {|
                RIneq.pos := / (INR r + 1);
                RIneq.cond_pos := RiemannInt.RinvN_pos r |}.
            assert (locally (f x) (ball_norm (f x) sigr)) as Hloc_norm.
            apply locally_le_locally_norm; unfold locally_norm.
                exists sigr => //.
            pose Hloc := Hf x (ball_norm (f x) sigr) Hloc_norm; clearbody Hloc; clear Hloc_norm.
            case: Hloc => N /= HN.
            assert (m ≤ max m N) as Ineq by lia.
            case: (H (max m N) Ineq) => d [Hlt {}H].
            case: (H (f x)) => //.
            move => Abs; apply False_ind.
            assert (N ≤ max m N) as Ineq' by lia.
            pose Abs' := (HN (max m N) Ineq'); clearbody Abs'.
            unfold ball_norm in Abs'.
            apply (Rlt_asym _ _ Abs).
            apply Rlt_trans with (/ (INR r + 1)) => //.
            case => r Ωrfx.
            exists r.
            unfold is_lim_seq, filterlim, eventually, filter_le, filtermap
                in Hf.
            case: Ωrfx => d; move => [Hlt Hloc].
            apply Hf.
            pose ɛ := (d - / (INR r + 1))%R.
            assert (0 < ɛ) as Hɛ.
            apply Rlt_Rminus => //.
            pose sigɛ := {| pos := ɛ; cond_pos := Hɛ |}.
            suff: locally_norm (f x) (Ω r).
            apply locally_le_locally_norm.
            exists sigɛ => y Hy.
            pose (d' := (d - ‖ minus y (f x) ‖%hy)%R).
            assert (/ (INR r + 1) < d') as Hlt'.
            unfold ball_norm in Hy; simpl in Hy.
            unfold d'; unfold ɛ in Hy; lra.
            exists d'; split => //.
            move => z.
            case: (Hloc z).
                left => //.
                move => Hz.
                right.
                unfold d'.
                apply Rlt_gt.
                unfold Rminus.
                apply Rlt_le_trans with ((‖ minus (f x) z ‖)%hy + - (‖ minus y (f x) ‖)%hy)%R.
                apply Rplus_lt_compat_r => //.
                setoid_rewrite <-norm_opp at 2.
                setoid_rewrite opp_minus.
                apply Rle_trans with (‖ minus (minus (f x) z) (minus (f x) y) ‖)%hy.
                apply Rle_trans with (| ‖ minus (f x) z ‖%hy - ‖ minus (f x) y ‖%hy |)%R.
                apply Rbasic_fun.Rle_abs.
                apply norm_triangle_inv.
                unfold minus.
                rewrite opp_plus opp_opp.
                rewrite plus_assoc.
                rewrite plus_comm.
                rewrite plus_assoc.
                setoid_rewrite plus_comm at 3.
                do 2 rewrite <-plus_assoc.
                rewrite plus_opp_r plus_zero_r.
                apply Rle_refl.
                apply measurable_union_countable => r.
                apply measurable_union_countable => m.
                apply measurable_inter_countable => n.
                case_eq (m <=? n).
                    move => /Nat.leb_le Lemn.
                    apply measurable_ext with (λ x : X, Ω r (s n x)).
                    move => x; split => //.
                    move => H; exact (H Lemn).
                    apply (Hs n).
                    apply measurable_gen.
                    move => x; case => d [Hd H].
                    suff: (locally_norm x (Ω r)).
                    apply locally_le_locally_norm.
                    pose ɛ := (d - / (INR r + 1))%R.
                    assert (0 < ɛ) as Hɛ.
                    apply Rlt_Rminus => //.
                    pose sigɛ := {| pos := ɛ; cond_pos := Hɛ |}.
                    exists sigɛ => y Hy.
                    pose (d' := (d - ‖ minus y x ‖%hy)%R).
                    assert (/ (INR r + 1) < d') as Hlt'.
                    unfold ball_norm in Hy; simpl in Hy.
                    unfold d'; unfold ɛ in Hy; lra.
                    exists d'; split => //.
                    move => z.
                    case: (H z).
                        left => //.
                        move => Hz.
                        right.
                        unfold d'.
                        apply Rlt_gt.
                        unfold Rminus.
                        apply Rlt_le_trans with ((‖ minus x z ‖)%hy + - (‖ minus y x ‖)%hy)%R.
                        apply Rplus_lt_compat_r => //.
                        setoid_rewrite <-norm_opp at 2.
                        setoid_rewrite opp_minus.
                        apply Rle_trans with (‖ minus (minus x z) (minus x y) ‖)%hy.
                        apply Rle_trans with (| ‖ minus x z ‖%hy - ‖ minus x y ‖%hy |)%R.
                        apply Rbasic_fun.Rle_abs.
                        apply norm_triangle_inv.
                        unfold minus.
                        rewrite opp_plus opp_opp.
                        rewrite plus_assoc.
                        rewrite plus_comm.
                        rewrite plus_assoc.
                        setoid_rewrite plus_comm at 3.
                        do 2 rewrite <-plus_assoc.
                        rewrite plus_opp_r plus_zero_r.
                        apply Rle_refl.
                move => /Nat.leb_gt Ltnm.
                apply measurable_ext with (fun _ => True).
                move => x; split => //.
                    move => _ Abs; lia.
                apply measurable_full.
    Qed.

End NM_lim_seq_prop.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* Instantiation of the Ring tactic for the naturals of Arith $*)

Require Import Bool.
Require Export LegacyRing.
Require Export Arith.
Require Import Eqdep_dec.

Local Open Scope nat_scope.

Fixpoint nateq (n m:nat) {struct m} : bool :=
  match n, m with
  | O, O => true
  | S n', S m' => nateq n' m'
  | _, _ => false
  end.

Lemma nateq_prop : forall n m:nat, Is_true (nateq n m) -> n = m.
Proof.
  simple induction n; simple induction m; intros; try contradiction.
  trivial.
  unfold Is_true in H1.
  rewrite (H n1 H1).
  trivial.
Qed.

Hint Resolve nateq_prop: arithring.

Definition NatTheory : Semi_Ring_Theory plus mult 1 0 nateq.
  split; intros; auto with arith arithring.
(*  apply (fun n m p:nat => plus_reg_l m p n) with (n := n).
  trivial.*)
Defined.

Add Legacy Semi Ring nat plus mult 1 0 nateq NatTheory [ 0 S ].

Goal forall n:nat, S n = 1 + n.
intro; reflexivity.
Save S_to_plus_one.

(* Replace all occurrences of (S exp) by (plus (S O) exp), except when
   exp is already O and only for those occurrences than can be reached by going
   down plus and mult operations  *)
Ltac rewrite_S_to_plus_term t :=
  match constr:(t) with
  | 1 => constr:(1)
  | (S ?X1) =>
      let t1 := rewrite_S_to_plus_term X1 in
      constr:(1 + t1)
  | (?X1 + ?X2) =>
      let t1 := rewrite_S_to_plus_term X1
      with t2 := rewrite_S_to_plus_term X2 in
      constr:(t1 + t2)
  | (?X1 * ?X2) =>
      let t1 := rewrite_S_to_plus_term X1
      with t2 := rewrite_S_to_plus_term X2 in
      constr:(t1 * t2)
  | _ => constr:(t)
  end.

(* Apply S_to_plus on both sides of an equality *)
Ltac rewrite_S_to_plus :=
  match goal with
  |  |- (?X1 = ?X2) =>
      try
       let t1 :=
       (**)  (**)
       rewrite_S_to_plus_term X1
       with t2 := rewrite_S_to_plus_term X2 in
       change (t1 = t2)
  |  |- (?X1 = ?X2) =>
      try
       let t1 :=
       (**)  (**)
       rewrite_S_to_plus_term X1
       with t2 := rewrite_S_to_plus_term X2 in
       change (t1 = t2)
  end.

Ltac ring_nat := rewrite_S_to_plus; ring.